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 Math::GSL::Sys qw/gsl_nan gsl_isnan gsl_isinf/;
  11 use Carp qw/croak/;
  12 our @EXPORT = qw();
  13 our @EXPORT_OK = qw(
  14                      is_similar ok_similar
  15                      ok_similar_relative
  16                      is_similar_relative
  17                      verify verify_results
  18                      is_windows
  19                      ok_status
  20 );
  21 use constant GSL_IS_WINDOWS =>  ($^O =~ /MSWin32/i)  ?  1 : 0 ;
  22
  23 =head1 NAME
  24
  25 Math::GSL::Test - Assertions and such
  26
  27 =head1 SYNOPSIS
  28
  29
  30     use Math::GSL::Test qw/:all/;
  31     ok_similar($x,$y, $msg, $eps);
  32
  33 =cut
  34
  35 our %EXPORT_TAGS = (
  36                      all => \@EXPORT_OK,
  37                    );
  38
  39 sub _dump_result($)
  40 {
  41     my $r=shift;
  42     printf "result->err: %.18g\n", $r->{err};
  43     printf "result->val: %.18g\n", $r->{val};
  44 }
  45
  46 =head2 is_windows()
  47
  48 Returns true if current system is Windows-like.
  49
  50 =cut
  51
  52 sub is_windows() { GSL_IS_WINDOWS }
  53
  54 =head2 is_similar($x,$y;$eps,$similarity_function)
  55
  56     is_similar($x,$y);
  57     is_similar($x, $y, 1e-7);
  58     is_similar($x,$y, 1e-3, sub { ... } );
  59
  60 Return true if $x and $y are within $eps of each other, i.e.
  61
  62     abs($x-$y) <= $eps
  63
  64 If passed a code reference $similarity_function, it will pass $x and $y as parameters to it and
  65 will check to see if
  66
  67     $similarity_function->($x,$y_) <= $eps
  68
  69 The default value of $eps is 1e-8. Don't try sending anything to the moon with this value...
  70
  71 =cut
  72
  73 sub is_similar {
  74     my ($x,$y, $eps, $similarity_function) = @_;
  75     $eps ||= 1e-8;
  76     if (ref $x eq 'ARRAY' && ref $y eq 'ARRAY') {
  77         if ( $#$x != $#$y ){
  78             warn "is_similar(): argument of different lengths, $#$x != $#$y !!!";
  79             return 0;
  80         } else {
  81             map {
  82                     my $delta = (gsl_isnan($x->[$_]) or gsl_isnan($y->[$_])) ? gsl_nan() : abs($x->[$_] - $y->[$_]);
  83                     if($delta > $eps){
  84                         warn "\n\tElements start differing at index $_, delta = $delta\n";
  85                         warn qq{\t\t\$x->[$_] = } . $x->[$_] . "\n";
  86                         warn qq{\t\t\$y->[$_] = } . $y->[$_] . "\n";
  87                         return 0;
  88                     }
  89                 } (0..$#$x);
  90             return 1;
  91         }
  92     } else {
  93         if( ref $similarity_function eq 'CODE') {
  94                $similarity_function->($x,$y) <= $eps ? return 1 : return 0;
  95         } elsif( defined $x && defined $y) {
  96             my $delta = (gsl_isnan($x) or gsl_isnan($y)) ? gsl_nan() : abs($x-$y);
  97             $delta > $eps ? warn qq{\t\t\$x=$x\n\t\t\$y=$y\n\t\tdelta=$delta\n} && return 0 : return 1;
  98         } else {
  99             return 0;
 100         }
 101     }
 102 }
 103
 104 # this is a huge hack
 105 sub verify_results
 106 {
 107     my ($results,$class) = @_;
 108     # GSL uses a factor of 100
 109     my $factor   = 20;
 110     my $eps      = 2048*$Math::GSL::Machine::GSL_DBL_EPSILON; # TOL3
 111     my ($x,$res);
 112     local $Test::Builder::Level = $Test::Builder::Level + 1;
 113
 114     croak "Usage: verify_results(%results, \$class)" unless $class;
 115     while (my($code,$expected)=each %$results){
 116         my $r        = Math::GSL::SF::gsl_sf_result_struct->new;
 117         my $status   = eval qq{${class}::$code};
 118
 119         ok(0, qq{'$code' died} ) if !defined $status;
 120
 121         if ( defined $r && $code =~ /_e\(.*\$r/) {
 122             $x   = $r->{val};
 123             $eps = $factor*$r->{err};
 124             $res = abs($x-$expected);
 125
 126             if ($ENV{DEBUG} ){
 127                 _dump_result($r);
 128                 print "got $code = $x\n";
 129                 printf "expected   : %.18g\n", $expected ;
 130                 printf "difference : %.18g\n", $res;
 131                 printf "unexpected error of %.18g\n", $res-$eps if ($res-$eps>0);
 132             }
 133             if (gsl_isnan($x)) {
 134                     ok( gsl_isnan($expected), "'$expected'?='$x'" );
 135             } elsif(gsl_isinf($x)) {
 136                     ok( gsl_isinf($expected), "'$expected'?='$x'" );
 137             } else {
 138                 ok( $res <= $eps, "$code ?= $x,\nres= +-$res, eps=$eps" );
 139             }
 140         }
 141     }
 142 }
 143 sub verify
 144 {
 145     my ($results,$class) = @_;
 146     local $Test::Builder::Level = $Test::Builder::Level + 1;
 147     croak "Usage: verify(%results, \$class)" unless $class;
 148     while (my($code,$result)=each %$results){
 149         my $x = eval qq{${class}::$code};
 150         ok(0, $@) if $@;
 151
 152         my ($expected,$eps);
 153         if (ref $result){
 154             ($expected,$eps)=@$result;
 155         } else {
 156             ($expected,$eps)=($result,1e-8);
 157         }
 158         my $res = abs($x - $expected);
 159
 160         if (gsl_isnan($x)) {
 161                ok( gsl_isnan($expected), "'$expected'?='$x'" );
 162         } elsif(gsl_isinf($x)) {
 163                ok( gsl_isinf($expected), "'$expected'?='$x'" );
 164         } else {
 165             ok( $res <= $eps, "$code ?= $x,\nres= +-$res, eps=$eps" );
 166         }
 167     }
 168 }
 169
 170 =head2 ok_status( $got_status; $expected_status )
 171
 172     ok_status( $status );                  # defaults to checking for $GSL_SUCCESS
 173
 174     ok_status( $status, $GSL_ECONTINUE );
 175
 176 Pass a test if the GSL status codes match, with a default expected status of $GSL_SUCCESS. This
 177 function also stringifies the status codes into meaningful messages when it fails.
 178
 179 =cut
 180
 181 sub ok_status {
 182     my ($got, $expected) = @_;
 183     local $Test::Builder::Level = $Test::Builder::Level + 1;
 184     $expected ||= $GSL_SUCCESS;
 185     ok( defined $got && $got == $expected, gsl_strerror(int($got)) );
 186 }
 187
 188 =head2 ok_similar( $x, $y, $msg, $eps)
 189
 190     ok_similar( $x, $y);
 191     ok_similar( $x, $y, 'reason');
 192     ok_similar( $x, $y, 'reason', 1e-4);
 193
 194 Pass a test if is_similar($x,$y,$msg,$eps) is true, otherwise fail.
 195
 196 =cut
 197
 198 sub ok_similar {
 199     my ($x,$y, $msg, $eps) = @_;
 200     local $Test::Builder::Level = $Test::Builder::Level + 1;
 201     ok(is_similar($x,$y,$eps), $msg);
 202 }
 203
 204 sub is_similar_relative {
 205     my ($x,$y, $eps) = @_;
 206     return is_similar($x,$y,$eps, sub { abs( ($_[0] - $_[1])/abs($_[1]) ) } );
 207 }
 208
 209 sub ok_similar_relative {
 210     my ($x,$y, $msg, $eps,) = @_;
 211     local $Test::Builder::Level = $Test::Builder::Level + 1;
 212     ok(is_similar_relative($x,$y,$eps), $msg );
 213 }
 214
 215 1;