Skip to content

Commit

Permalink
core tests replace approx with is_pdl - #34
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed Oct 30, 2024
1 parent a6073c0 commit 8ba0b86
Show file tree
Hide file tree
Showing 2 changed files with 90 additions and 130 deletions.
146 changes: 61 additions & 85 deletions Basic/t/core.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -134,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 approx( $b_dbl->sclr, 5 ), "sclr test of 1-elem pdl (dbl)";
is $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 @@ -162,18 +162,18 @@ ok eq_array( [ $y->dims ], [3,4] ), "reshape()";
my $x = ones 3,1,4;
my $y = $x->reshape(-1);
my $c = $x->squeeze;
ok eq_array( [ $y->dims ], [3,4] ), "reshape(-1)";
ok all( $y == $c ), "squeeze";
is_pdl $y->shape, indx([3,4]), "reshape(-1)";
is_pdl $y, $c, "squeeze";
$c++; # check dataflow in reshaped PDL
ok all( $y == $c ), "dataflow"; # should flow back to y
ok all( $x == 2 ), "dataflow";
is_pdl $y, $c, "dataflow"; # should flow back to y
is_pdl $x, pdl(2)->slice('*3,*1,*4'), "dataflow";
}

{
my $d = pdl(5); # zero dim ndarray and reshape/squeeze
ok $d->reshape(-1)->ndims==0, "reshape(-1) on 0-dim PDL gives 0-dim PDL";
ok $d->reshape(1)->ndims==1, "reshape(1) on 0-dim PDL gives 1-dim PDL";
ok $d->reshape(1)->reshape(-1)->ndims==0, "reshape(-1) on 1-dim, 1-element PDL gives 0-dim PDL";
is_pdl $d->reshape(-1)->shape, empty(indx), "reshape(-1) on 0-dim PDL gives 0-dim PDL";
is_pdl $d->reshape(1)->shape, indx([1]), "reshape(1) on 0-dim PDL gives 1-dim PDL";
is_pdl $d->reshape(1)->reshape(-1)->shape, empty(indx), "reshape(-1) on 1-dim, 1-element PDL gives 0-dim PDL";
}

{
Expand Down Expand Up @@ -260,11 +260,10 @@ my $subobj = PDL::Trivial->new(6);
isa_ok $subobj, 'PDL::Trivial';
isa_ok +PDL->topdl($subobj), 'PDL::Trivial';
isa_ok $subobj->inplace, 'PDL::Trivial';
isa_ok( PDL->topdl(1), "PDL", "topdl(1) returns an ndarray" );
isa_ok( PDL->topdl([1,2,3]), "PDL", "topdl([1,2,3]) returns an ndarray" );
isa_ok( PDL->topdl(1,2,3), "PDL", "topdl(1,2,3) returns an ndarray" );
my $x=PDL->topdl(1,2,3);
ok (($x->nelem == 3 and all($x == pdl(1,2,3))), "topdl(1,2,3) returns a 3-ndarray containing (1,2,3)");
isa_ok +PDL->topdl(1), "PDL", "topdl(1) returns an ndarray";
isa_ok +PDL->topdl([1,2,3]), "PDL", "topdl([1,2,3]) returns an ndarray";
isa_ok +PDL->topdl(1,2,3), "PDL", "topdl(1,2,3) returns an ndarray";
is_pdl +PDL->topdl(1,2,3), pdl(1,2,3), "topdl(1,2,3) returns a 3-ndarray containing (1,2,3)";
eval {PDL->topdl({})};
isnt $@, '', 'topdl({}) no segfault';
}
Expand Down Expand Up @@ -331,63 +330,52 @@ is $PDL::undefval, 0, "default value of \$PDL::undefval is 0";

{
my $x = [ [ 2, undef ], [3, 4 ] ];
my $y = pdl( $x );
my $c = pdl( [ 2, 0, 3, 4 ] )->reshape(2,2);
ok all( $y == $c ), "undef converted to 0 (dbl)";
ok eq_array( $x, [[2,undef],[3,4]] ), "pdl() has not changed input array";
$y = pdl( long, $x );
$c = pdl( long, [ 2, 0, 3, 4 ] )->reshape(2,2);
ok all( $y == $c ), "undef converted to 0 (long)";
}

{
local($PDL::undefval) = -999;
my $x = [ [ 2, undef ], [3, 4 ] ];
my $y = pdl( $x );
my $c = pdl( [ 2, -999, 3, 4 ] )->reshape(2,2);
ok all( $y == $c ), "undef converted to -999 (dbl)";
$y = pdl( long, $x );
$c = pdl( long, [ 2, -999, 3, 4 ] )->reshape(2,2);
ok all( $y == $c ), "undef converted to -999 (long)";
my $y = pdl($x);
my $c = pdl([[2, 0],[3, 4]]);
is_pdl $y, $c, "undef converted to 0 (dbl)";
is_deeply $x, [[2,undef],[3,4]], "pdl() has not changed input array";
is_pdl long($x), long($c), "undef converted to 0 (long)";
}

{
local($PDL::undefval) = -999;
my $x = [ [ 2, undef ], [3, 4 ] ];
my $y = pdl($x);
my $c = pdl('2 -999; 3 4');
is_pdl $y, $c, "undef converted to -999 (dbl)";
is_pdl long($x), long($c), "undef converted to -999 (long)";
};

{
# Funky constructor cases
# pdl of a pdl
my $x = pdl(pdl(5));
ok all( $x== pdl(5)), "pdl() can piddlify an ndarray";
$x = pdl(null);
ok $x->isnull, 'pdl(null) gives null' or diag "x(", $x->info, ")";
is_pdl pdl(pdl(5)), pdl(5), "pdl() can piddlify an ndarray";
is_pdl pdl(null), null, 'pdl(null) gives null';

$x = pdl(null, null);
is_deeply [$x->dims], [0,2], 'pdl(null, null) gives empty' or diag "x(", $x->info, ")";
ok !$x->isnull, 'pdl(null, null) gives non-null' or diag "x(", $x->info, ")";
is_pdl pdl(null, null), zeroes(0,2), 'pdl(null, null) gives empty';

# pdl of mixed-dim pdls: pad within a dimension
$x = pdl( zeroes(5), ones(3) );
ok all($x == pdl([0,0,0,0,0],[1,1,1,0,0])),"Piddlifying two ndarrays concatenates them and pads to length" or diag("x=$x\n");
is_pdl pdl( zeroes(5), ones(3) ), pdl([0,0,0,0,0],[1,1,1,0,0]),"Piddlifying two ndarrays concatenates them and pads to length";

# pdl of mixed-dim pdls: pad a whole dimension
$x = pdl( [[9,9],[8,8]], xvals(3)+1 );
ok all($x == pdl([[[9,9],[8,8],[0,0]] , [[1,0],[2,0],[3,0]] ])),"can concatenate mixed-dim ndarrays" or diag("x=$x\n");
is_pdl pdl( [[9,9],[8,8]], xvals(3)+1 ), pdl([[[9,9],[8,8],[0,0]] , [[1,0],[2,0],[3,0]] ]),"can concatenate mixed-dim ndarrays";

# pdl of mixed-dim pdls: a hairier case
my $c = pdl [1], pdl[2,3,4], pdl[5];
ok all($c == pdl([[[1,0,0],[0,0,0]],[[2,3,4],[5,0,0]]])),"Can concatenate mixed-dim ndarrays: hairy case" or diag("c=$c\n");
is_pdl pdl([1], pdl[2,3,4], pdl[5]), pdl([[[1,0,0],[0,0,0]],[[2,3,4],[5,0,0]]]),"Can concatenate mixed-dim ndarrays: hairy case";
}

# same thing, with undefval set differently
{
local($PDL::undefval) = 99;
my $c = pdl undef;
ok all($c == pdl(99)), "explicit, undefval of 99 works" or diag("c=$c\n");
is_pdl $c, pdl(99), "explicit, undefval of 99 works";
$c = pdl [1], pdl[2,3,4], pdl[5];
ok all($c == pdl([[[1,99,99],[99,99,99]],[[2,3,4],[5,99,99]]])), "implicit, undefval works for padding" or diag("c=$c\n");
is_pdl $c, pdl([[[1,99,99],[99,99,99]],[[2,3,4],[5,99,99]]]), "implicit, undefval works for padding";
$PDL::undefval = undef;
$c = pdl undef;
ok all($c == pdl(0)), "explicit, undefval of undef falls back to 0" or diag("c=$c\n");
is_pdl $c, pdl(0), "explicit, undefval of undef falls back to 0";
$c = pdl [1], [2,3,4];
ok all($c == pdl([1,0,0],[2,3,4])), "implicit, undefval of undef falls back to 0" or diag("c=$c\n");
is_pdl $c, pdl([1,0,0],[2,3,4]), "implicit, undefval of undef falls back to 0";
$PDL::undefval = inf;
$c = pdl undef;
ok all($c == inf), "explicit, undefval of PDL scalar works" or diag("c=$c\n");
Expand All @@ -400,22 +388,17 @@ ok all($c == pdl([[[1,0,0],[0,0,0]],[[2,3,4],[5,0,0]]])),"Can concatenate mixed-
my $x = eval {zeroes(2,0,1);};
is($@, '', "zeroes accepts empty PDL specification");

my $y = eval { pdl($x,sequence(2,0,1)); };
is $@, '';
ok all(pdl($y->dims) == pdl(2,0,1,2)), "concatenating two empties gives an empty";
my $y = pdl($x,sequence(2,0,1));
is_pdl $y->shape, indx(2,0,1,2), "concatenating two empties gives an empty";

eval { $y = pdl($x,sequence(2,1,1)); };
is $@, '';
ok all(pdl($y->dims) == pdl(2,1,1,2)), "concatenating an empty and a nonempty treats the empty as a filler";
$y = pdl($x,sequence(2,1,1));
is_pdl $y->shape, indx(2,1,1,2), "concatenating an empty and a nonempty treats the empty as a filler";

eval { $y = pdl($x,5) };
is $@, '';
ok all(pdl($y->dims)==pdl(2,1,1,2)), "concatenating an empty and a scalar on the right works";
$y = pdl($x,5);
is_pdl $y->shape, indx(2,1,1,2), "concatenating an empty and a scalar on the right works";

eval { $y = pdl(5,$x) };
is $@, '';
ok all(pdl($y->dims)==pdl(2,1,1,2)), "concatenating an empty and a scalar on the left works";
ok( all($y==pdl([[[5,0]]],[[[0,0]]])), "concatenating an empty and a scalar on the left gives the right answer");
$y = pdl(5,$x);
is_pdl $y, pdl([[[5,0]]],[[[0,0]]]), "concatenating an empty and a scalar on the left gives the right answer";
}

# cat problems
Expand Down Expand Up @@ -445,12 +428,7 @@ like($@, qr/\(argument 1\)/,
'cat properly identifies the first actual ndarray in combined screw-ups');
}

{
my $x = eval {cat(pdl(1),pdl(2,3));};
is($@, '', 'cat(pdl(1),pdl(2,3)) succeeds');
is_deeply [$x->dims], [2,2], 'weird cat case has the right shape';
ok( all( $x == pdl([1,1],[2,3]) ), "cat does the right thing with catting a 0-pdl and 2-pdl together");
}
is_pdl cat(pdl(1),pdl(2,3)), pdl([1,1],[2,3]), "cat does the right thing with catting a 0-pdl and 2-pdl together";

{
my $lo=sequence(long,5)+32766;
Expand All @@ -460,13 +438,13 @@ my $by=sequence(byte,5)+253;
my @list = ($lo,$so,$fl,$by);
my $c2 = cat(@list);
is($c2->type,'float','concatenating different datatypes returns the highest type');
ok(all($_==shift @list),"cat/dog symmetry for values") for $c2->dog;
is_pdl $_, shift @list, {require_equal_types=>0, test_name=>"cat/dog symmetry for values"} for $c2->dog;
my ($dogcopy) = $c2->dog({Break=>1});
$dogcopy++;
ok all($dogcopy != $c2->slice(':,(0)')), 'Break means copy'; # not lo as cat no flow
is_pdl $dogcopy, $c2->slice(':,(0)')+1, 'Break means copy'; # not lo as cat no flow
my ($dogslice) = $c2->dog;
$dogslice++;
ok all($dogslice == $c2->slice(':,(0)')), 'no Break means dataflow' or diag "got=$dogslice\nexpected=$lo";
is_pdl $dogslice, $c2->slice(':,(0)'), 'no Break means dataflow';
eval {pdl([3])->dog(5)};
like $@, qr/Usage/, "error if excess args";
for ([[], qr/at least/], [[5]], [[4,5]]) {
Expand All @@ -489,36 +467,36 @@ my $y = $x->copy;
ok $x->is_inplace,"original item true inplace flag after copy";
ok !$y->is_inplace,"copy has false inplace flag";
$y++;
ok all($y!=sequence(byte,5)),"copy returns severed copy of the original thing if inplace is set";
is_pdl $y, sequence(byte,5)+1,"copy returns severed copy of the original thing if inplace is set";
ok $x->is_inplace,"original item still true inplace flag";
ok !$y->is_inplace,"copy still false inplace flag";
ok all($x==sequence(byte,5)),"copy really is severed";
is_pdl $x, sequence(byte,5),"copy really is severed";
}

{
# new_or_inplace
my $x = sequence(byte,5);
my $y = $x->new_or_inplace;
ok( all($y==$x) && ($y->get_datatype == $x->get_datatype), "new_or_inplace with no pref returns something like the orig.");
is_pdl $y, $x, "new_or_inplace with no pref returns something like the orig.";
$y++;
ok(all($y!=$x),"new_or_inplace with no inplace flag returns something disconnected from the orig.");
is_pdl $y, $x+1, "new_or_inplace with no inplace flag returns something disconnected from the orig.";

$y = $x->new_or_inplace("float,long");
ok($y->type eq 'float',"new_or_inplace returns the first type in case of no match");
is $y->type, 'float',"new_or_inplace returns first type in case of no match";

$y = $x->inplace->new_or_inplace;
$y++;
ok(all($y==$x),"new_or_inplace returns the original thing if inplace is set");
ok(!($y->is_inplace),"new_or_inplace clears the inplace flag");
is_pdl $y, $x, "new_or_inplace returns the original thing if inplace is set";
ok !$y->is_inplace,"new_or_inplace clears the inplace flag";
}

{
# check reshape and dims. While we're at it, check null & empty creation too.
my $empty = empty();
is $empty->type->enum, 0, 'empty() gives lowest-numbered type';
is empty(float)->type, 'float', 'empty(float) works';
ok($empty->nelem==0,"you can make an empty PDL with zeroes(0)");
ok("$empty" =~ m/Empty/, "an empty PDL prints 'Empty'");
is $empty->nelem, 0, "you can make an empty PDL with zeroes(0)";
like "$empty", qr/Empty/, "an empty PDL prints 'Empty'";
}

{
Expand All @@ -545,11 +523,10 @@ like $@, qr/null/, 'null->long gives right error';
}

{
my $x = short pdl(3,4,5,6);
my $x = short(3,4,5,6);
eval { $x->reshape(2,2);};
is($@, '', "reshape succeeded in the normal case");
ok( ( $x->ndims==2 and $x->dim(0)==2 and $x->dim(1)==2 ), "reshape did the right thing");
ok(all($x == short pdl([[3,4],[5,6]])), "reshape moved the elements to the right place");
is_pdl $x, short([[3,4],[5,6]]), "reshape moved the elements to the right place";
my $y = $x->slice(":,:");
eval { $y->reshape(4); };
unlike $@, qr/Can't/, "reshape doesn't fail on a PDL with a parent";
Expand Down Expand Up @@ -584,9 +561,8 @@ SKIP: {
my $neg = -684394069604;
my $straight_pdl = pdl($neg);
my $multed = pdl(1) * $neg;
ok $straight_pdl == $multed, 'upgrade of large negative SV to ndarray'
or diag "straight=$straight_pdl mult=$multed\n",
"straight:", $straight_pdl->info, " mult:", $multed->info;
is $straight_pdl, $multed, 'upgrade of large negative SV to ndarray'
or diag "straight:", $straight_pdl->info, " mult:", $multed->info;
}
{
my $fromuv_r = pdl('10223372036854775507');
Expand Down
Loading

0 comments on commit 8ba0b86

Please sign in to comment.