lib/Math/GSL/Test.pm

   1 package Math::GSL::Test;
   2 use base qw(Exporter);
   3 use base qw(DynaLoader);
   4 use strict;
   5 use warnings;
   6 use Test::More;
   7 use Math::GSL::Errno qw/:all/;
   8 use Math::GSL::Machine qw/:all/;
   9 use Math::GSL::Const qw/:all/;
  10 use Carp qw/croak/;
  11 our @EXPORT = qw();
  12 our @EXPORT_OK = qw(
  13                      is_similar ok_similar
  14                      ok_similar_relative
  15                      is_similar_relative
  16                      verify verify_results
  17                      is_windows
  18                      ok_status
  19 );
  20 use constant GSL_IS_WINDOWS =>  ($^O =~ /MSWin32/i)  ?  1 : 0 ;
  21
  22 our %EXPORT_TAGS = (
  23                      all => \@EXPORT_OK,
  24                    );
  25
  26 sub _dump_result($)
  27 {
  28     my $r=shift;
  29     printf "result->err: %.18g\n", $r->{err};
  30     printf "result->val: %.18g\n", $r->{val};
  31 }
  32
  33 sub is_windows() { GSL_IS_WINDOWS }
  34
  35 sub is_similar {
  36     my ($x,$y, $eps, $similarity_function) = @_;
  37     $eps ||= 1e-8;
  38     if (ref $x eq 'ARRAY' && ref $y eq 'ARRAY') {
  39         if ( $#$x != $#$y ){
  40             warn "is_similar(): argument of different lengths, $#$x != $#$y !!!";
  41             return 0;
  42         } else {
  43             map {
  44                     my $delta = abs($x->[$_] - $y->[$_]);
  45                     if($delta > $eps){
  46                         warn "\n\tElements start differing at index $_, delta = $delta\n";
  47                         warn qq{\t\t\$x->[$_] = } . $x->[$_] . "\n";
  48                         warn qq{\t\t\$y->[$_] = } . $y->[$_] . "\n";
  49                         return 0;
  50                     }
  51                 } (0..$#$x);
  52             return 1;
  53         }
  54     } else {
  55         if( ref $similarity_function eq 'CODE') {
  56                $similarity_function->($x,$y) <= $eps ? return 1 : return 0;
  57         } elsif( defined $x && defined $y) {
  58             abs($x-$y) <= $eps ? return 1 : return 0;
  59         } else {
  60             return 0;
  61         }
  62     }
  63 }
  64
  65 # this is a huge hack
  66 sub verify_results
  67 {
  68     my ($results,$class) = @_;
  69     # GSL uses a factor of 100
  70     my $factor   = 20;
  71     my $eps      = 2048*$Math::GSL::Machine::GSL_DBL_EPSILON; # TOL3
  72     my ($x,$res);
  73     local $Test::Builder::Level = $Test::Builder::Level + 1;
  74
  75     croak "Usage: verify_results(%results, \$class)" unless $class;
  76     while (my($code,$expected)=each %$results){
  77         my $r        = Math::GSL::SF::gsl_sf_result_struct->new;
  78         my $status   = eval qq{${class}::$code};
  79
  80         ok(0, qq{'$code' died} ) if !defined $status;
  81
  82         if ( defined $r && $code =~ /_e\(.*\$r/) {
  83             $x   = $r->{val};
  84             $eps = $factor*$r->{err};
  85             $res = abs($x-$expected);
  86
  87             if ($ENV{DEBUG} ){
  88                 _dump_result($r);
  89                 print "got $code = $x\n";
  90                 printf "expected   : %.18g\n", $expected ;
  91                 printf "difference : %.18g\n", $res;
  92                 printf "unexpected error of %.18g\n", $res-$eps if ($res-$eps>0);
  93             }
  94             if ($x =~ /nan|inf/i) {
  95                     ok( $expected eq $x, "'$expected'?='$x'" );
  96             } else {
  97                 ok( $res <= $eps, "$code ?= $x,\nres= +-$res, eps=$eps" );
  98             }
  99         }
 100     }
 101 }
 102 sub verify
 103 {
 104     my ($results,$class) = @_;
 105     local $Test::Builder::Level = $Test::Builder::Level + 1;
 106     croak "Usage: verify(%results, \$class)" unless $class;
 107     while (my($code,$result)=each %$results){
 108         my $x = eval qq{${class}::$code};
 109         ok(0, $@) if $@;
 110
 111         my ($expected,$eps);
 112         if (ref $result){
 113             ($expected,$eps)=@$result;
 114         } else {
 115             ($expected,$eps)=($result,1e-8);
 116         }
 117         my $res = abs($x - $expected);
 118         if ($x =~ /nan|inf/i ){
 119             ok( $expected eq $x, "'$expected' ?='$x'" );
 120         } else {
 121             ok( $res <= $eps, "$code ?= $x,\nres= +-$res, eps=$eps" );
 122         }
 123     }
 124 }
 125 sub ok_status {
 126     my ($got, $expected) = @_;
 127     local $Test::Builder::Level = $Test::Builder::Level + 1;
 128     $expected ||= $GSL_SUCCESS;
 129     ok( $got == $expected, gsl_strerror(int($got)) );
 130 }
 131 sub ok_similar {
 132     my ($x,$y, $msg, $eps) = @_;
 133     local $Test::Builder::Level = $Test::Builder::Level + 1;
 134     ok(is_similar($x,$y,$eps), $msg);
 135 }
 136
 137 sub is_similar_relative {
 138     my ($x,$y, $eps) = @_;
 139     return is_similar($x,$y,$eps, sub { abs( ($_[0] - $_[1])/abs($_[1]) ) } );
 140 }
 141
 142 sub ok_similar_relative {
 143     my ($x,$y, $msg, $eps,) = @_;
 144     ok(is_similar_relative($x,$y,$eps), $msg );
 145 }
 146
 147 1;