Skip to content

Commit

Permalink
Core, Math, PP tests replace tapprox with is_pdl - #34
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed Oct 29, 2024
1 parent 5ffd3c5 commit 3a664ee
Show file tree
Hide file tree
Showing 3 changed files with 41 additions and 54 deletions.
23 changes: 5 additions & 18 deletions Basic/t/01-pptest.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -395,37 +395,27 @@ BEGIN { $ENV{PDL_AUTOPTHREAD_TARG} = 1 } # for continue-in-broadcastloop test
use PDL::LiteF;
use PDL::Types;
use PDL::Dbg;
use Test::PDL -require_equal_types => 0;
BEGIN {
warning_like{ require PDL::Tests; PDL::Tests->import; }
qr/deprecated.*PDL::Test::Fancy/,
"PP deprecation should emit warnings";
}
# Is there any good reason we don't use PDL's approx function?
sub tapprox {
my($x,$y) = @_;
my $c = abs($x-$y);
my $d = max($c);
return $d < 0.01;
}
my $x = xvals(zeroes(byte, 2, 4));
my $y;
# $P() affine tests
foop($x,($y=null));
ok( tapprox($x,$y) )
or diag $y;
is_pdl $x,$y;
foop($x->transpose,($y=null));
ok( tapprox($x->transpose,$y) )
or diag $y;
is_pdl $x->transpose,$y;
my $vaff = $x->dummy(2,3)->xchg(1,2);
foop($vaff,($y=null));
ok( tapprox($vaff,$y) )
or diag ($vaff, $vaff->dump);
is_pdl $vaff,$y;
eval { foop($x,($y=pdl([1]))) };
isnt $@, '', '[phys] with multi-used mismatched dim of 1 throws exception';
Expand Down Expand Up @@ -465,11 +455,8 @@ is_deeply \@msg, [], 'no warnings' or diag explain \@msg;
my $exp = $in->copy;
my $tmp = $exp->where( ! ($in % 2) );
$tmp .= 0;
broadcastloop_continue( $in, $got );
ok( tapprox( $got, $exp ), "continue works in broadcastloop" )
or do { diag "got : $got"; diag "expected: $exp" };
is_pdl $got, $exp, "continue works in broadcastloop";
}
polyfill_pp(zeroes(5,5), ones(2,3), 1);
Expand Down
24 changes: 10 additions & 14 deletions Basic/t/core.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,19 +3,14 @@ use warnings;
use Test::More;
use Test::Exception;
use PDL::LiteF;
use Test::PDL;
use PDL::Math; # for polyroots with [phys] params, for dim compat tests
use PDL::MatrixOps; # for simq with [phys] params, for dim compat tests
use Config;
use PDL::Types;
use Math::Complex ();
use Devel::Peek;

sub tapprox ($$) {
my ( $x, $y ) = @_;
my $d = abs( $x - $y );
return $d <= 0.0001;
}

for my $type (PDL::Types::types()) {
ok defined pdl($type, 0), "constructing PDL of type $type";
}
Expand Down Expand Up @@ -139,7 +134,7 @@ my $b_dbl = $a_dbl->slice('5');
my $c_long = $a_long->slice('4:7');
my $c_dbl = $a_dbl->slice('4:7');
is $b_long->sclr, 5, "sclr test of 1-elem pdl (long)";
ok tapprox( $b_dbl->sclr, 5 ), "sclr test of 1-elem pdl (dbl)";
ok approx( $b_dbl->sclr, 5 ), "sclr test of 1-elem pdl (dbl)";
eval { $c_long->sclr };
like $@, qr/multielement ndarray in 'sclr' call/, "sclr failed on multi-element ndarray (long)";
eval { $c_dbl->sclr };
Expand Down Expand Up @@ -198,13 +193,13 @@ eval {empty->copy->make_physical};
is $@, '', 'can physicalise the copy of an empty';

# capture ancient pptest.t test for Solaris segfault
ok all(tapprox(norm(pdl 3,4), pdl(0.6,0.8))), 'vector quasi-copy works';
is_pdl norm(pdl 3,4), pdl(0.6,0.8), 'vector quasi-copy works';
# pptest for null input
eval {(my $tmp=null) .= null}; like $@, qr/input.*null/;
# pptest for OtherPars=>named dim
ok all(tapprox((5*sequence(5))->maximum_n_ind(3), pdl(4,3,2))), 'named dim';
is_pdl +(5*sequence(5))->maximum_n_ind(3), indx(4,3,2), 'named dim';
# pptest for dim with fixed value
ok all(tapprox(crossp([1..3],[4..6]), pdl(-3,6,-3))), 'named dim=3';
is_pdl crossp([1..3],[4..6]), longlong(-3,6,-3), 'named dim=3';

subtest 'dim compatibility' => sub {
for (
Expand All @@ -213,7 +208,7 @@ subtest 'dim compatibility' => sub {
[\&append, [pdl(1), pdl(2), null], 2, [ 1, 2 ], 'output=null; required [2]'],
[\&append, [pdl(1), pdl(2), zeroes(2)], 2, [ 1, 2 ], 'output=[2]; required [2]'],
[\&append, [zeroes(1), zeroes(1), zeroes(3)], 2, qr/dim has size 3/, 'output=[3]; required [2]. output too large'],
[\&append, [zeroes(1), zeroes(0), zeroes()], 2, [0], 'output=scalar; required [1]'],
[\&append, [zeroes(1), zeroes(0), zeroes()], 2, 0, 'output=scalar; required [1]'],
[\&append, [zeroes(1), zeroes(1), zeroes()], 2, qr/can't broadcast/, 'output=scalar; required [2]. output too small'],
[\&append, [zeroes(1), zeroes(1), zeroes(1,1)], 2, qr/dim has size 1/, 'output=[1,1]; required [2]. output too small'],
[\&append, [pdl(1), pdl(2), zeroes(2,1)], 2, [[ 1, 2 ]], 'output=[2,1]; required [2]'],
Expand Down Expand Up @@ -249,7 +244,7 @@ subtest 'dim compatibility' => sub {
} else {
$func->( @$args );
my $got = $args->[$exp_index];
ok all(tapprox $got, pdl($exp)), $label or diag $got;
is_pdl $got, pdl($exp), $label;
}
}
};
Expand Down Expand Up @@ -769,8 +764,9 @@ for (['ones', 1], ['zeroes', 0], ['nan', '.*NaN'], ['inf', '.*Inf'], ['i', 'i',
$w = $name->($y); is_deeply [$w->dims], \@dims;
$w = $y->$name; is_deeply [$w->dims], \@dims;
next if $val =~ /\D/;
$w = $y->copy; $name->(inplace $w); ok all tapprox $w, pdl($val) or diag "$name got:$w";
$w = $y->copy; $w->inplace->$name; ok all tapprox $w, pdl($val);
my $exp = pdl($val)->slice('*1,*2,*3');
$w = $y->copy; $name->(inplace $w); is_pdl $w, $exp, $name;
$w = $y->copy; $w->inplace->$name; is_pdl $w, $exp, $name;
}

is short(1)->zeroes->type, 'short', '$existing->zeroes right type';
Expand Down
48 changes: 26 additions & 22 deletions Basic/t/math.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,54 +3,55 @@ use warnings;
use Test::More;
use PDL::LiteF;
use PDL::Math;
use Test::PDL -atol => 0.01;
use Config;

sub tapprox {
my($pa,$pb) = @_;
all approx $pa, $pb, 0.01;
}

ok( tapprox(bessj0(0.5),0.9384) && tapprox(bessj0(0),1) ,"bessj0");
ok( tapprox(bessj1(0.1),0.0499) && tapprox(bessj1(0),0) ,"bessj1");
ok( tapprox(bessjn(0.8,3),0.010) && tapprox(bessyn(0.2,2),-32.15714) ,"bessjn");
is_pdl bessj0(0.5), pdl(0.9384), "bessj0";
is_pdl bessj0(0), ldouble(1), "bessj0";
is_pdl bessj1(0.1), pdl(0.0499), "bessj1";
is_pdl bessj1(0), ldouble(0) ,"bessj1";
is_pdl bessjn(0.8,3), pdl(0.010), "bessjn";
is_pdl bessyn(0.2,2), pdl(-32.15714) ,"bessyn";

{
# test inplace
my $pa = pdl(0.5,0.0);
$pa->inplace->bessj0;
is_pdl $pa, pdl(0.9384,1), "bessj0 inplace";
eval { $pa->inplace->bessj0(PDL->null) };
isnt $@, '', 'check providing explicit output arg to inplace throws exception';
ok( tapprox($pa,pdl(0.9384,1)), "bessj0 inplace" );
}

{
my $pa = pdl(0.2);
$pa->inplace->bessyn(2);
ok( tapprox( $pa, -32.15714 ), "bessyn inplace" );
is_pdl $pa, pdl(-32.15714), "bessyn inplace";
}

ok( tapprox( pow(2,3),8), "pow");
ok( tapprox(erf(0.),0.) && tapprox(erf(30.),1.),"erf(0), erf(30)");
ok( tapprox(erf(0.5),1.-erfc(0.5)), "erf and erfc");
ok( tapprox(erf(erfi(0.5)),0.5) && tapprox(erfi(erf(0.5)),0.5), "erfi (both ways)");
is_pdl pow(2,3), sbyte(8), "pow";
is_pdl erf(0.), pdl(0.),"erf(0)";
is_pdl erf(30.), pdl(1.),"erf(30)";
is_pdl erf(0.5), pdl(1.-erfc(0.5)), "erf and erfc";
is_pdl erf(erfi(0.5)), pdl(0.5), "erfi (both ways)";
is_pdl erfi(erf(0.5)), pdl(0.5), "erfi (both ways)";

{
my $pa = pdl(0.0,30.0);
$pa->inplace->erf;
ok( tapprox( $pa, pdl(0.0,1.0) ), "erf inplace" );
is_pdl $pa, pdl(0.0,1.0), "erf inplace";
}

{
my $pa = pdl(0.5);
$pa->inplace->erfc;
ok( tapprox( 1.0-$pa, erf(0.5) ), "erfc inplace" );
is_pdl 1.0-$pa, erf(0.5), "erfc inplace";
}

{
my $pa = pdl( 0.01, 0.0 );
ok( all( approx( erfi($pa), pdl(0.00886,0.0) )), "erfi" );
is_pdl erfi($pa), my $exp = pdl(0.00886,0.0), "erfi";
$pa->inplace->erfi;
ok( all( approx( $pa, pdl(0.00886,0.0) )), "erfi inplace" );
is_pdl $pa, $exp, "erfi inplace";
}

eval {polyroots(1,0)};
Expand Down Expand Up @@ -90,15 +91,18 @@ my $ans_rint = pdl(-5,-5,-4,-4,-4,-4,-4,-3,-3,-3,-2,-2,-2,-2,-2,
ok(all(rint($pa)==$ans_rint),"rint");
}

ok( tapprox(sinh(0.3),0.3045) && tapprox(acosh(42.1),4.43305), "sinh, acosh");
ok( tapprox(acos(0.3),1.2661) && tapprox(tanh(0.4),0.3799), "acos, tanh");
ok( tapprox(cosh(2.0),3.7621) && tapprox(atan(0.6),0.54041), "cosh, atan");
is_pdl sinh(0.3), pdl(0.3045), "sinh";
is_pdl acosh(42.1), pdl(4.43305), "acosh";
is_pdl acos(0.3), pdl(1.2661), "acos";
is_pdl tanh(0.4), pdl(0.3799), "tanh";
is_pdl cosh(2.0), pdl(3.7621), "cosh";
is_pdl atan(0.6), pdl(0.54041), "atan";

{
# inplace
my $pa = pdl(0.3);
$pa->inplace->sinh;
ok( tapprox($pa, pdl(0.3045)), "sinh inplace" );
is_pdl $pa, pdl(0.3045), "sinh inplace";
}

if ($Config{cc} ne 'cl') {
Expand Down

0 comments on commit 3a664ee

Please sign in to comment.