"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "t/primitive.t" between
PDL-2.082.tar.gz and PDL-2.083.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

[ To the main PDL source changes report ]

primitive.t  (PDL-2.082):primitive.t  (PDL-2.083)
use strict; use strict;
use warnings; use warnings;
use Test::More; use Test::More;
use Test::Exception; use Test::Exception;
use PDL::LiteF; use PDL::LiteF;
use PDL::Types; use PDL::Types;
sub tapprox { sub tapprox {
my($x,$y) = @_; my($x,$y) = @_;
$_ = pdl($_) for $x, $y; $_ = pdl($_) for $x, $y;
if(join(',',$x->dims) ne join(',',$y->dims)) { if((my $dims_x = join(',',$x->dims)) ne (my $dims_y = join(',',$y->dims))) {
diag "APPROX: $x $y\n"; diag "APPROX: $x $y\n";
diag "UNEQDIM\n"; diag "UNEQDIM: |$dims_x| |$dims_y|\n";
return 0; return 0;
} }
return 1 if $x->isempty and $y->isempty; return 1 if $x->isempty and $y->isempty;
my $d = max( abs($x-$y) ); my $d = max( abs($x-$y) );
if($d >= 0.01) { if($d >= 0.01) {
diag "got=$x expected=$y\n"; diag "got=$x expected=$y\n";
} }
$d < 0.01; $d < 0.01;
} }
skipping to change at line 88 skipping to change at line 88
is $q.'', '[0 6 7 9 2]', "minimum_n_ind BAD"; is $q.'', '[0 6 7 9 2]', "minimum_n_ind BAD";
$p = pdl '[1 BAD 3 4 BAD BAD]'; $p = pdl '[1 BAD 3 4 BAD BAD]';
$q = zeroes 5; $q = zeroes 5;
minimum_n_ind $p, $q; minimum_n_ind $p, $q;
is $q.'', '[0 2 3 BAD BAD]', "minimum_n_ind insufficient good"; is $q.'', '[0 2 3 BAD BAD]', "minimum_n_ind insufficient good";
$p = pdl '[1 BAD 3 4 BAD BAD 3 1 5 8 9]'; $p = pdl '[1 BAD 3 4 BAD BAD 3 1 5 8 9]';
$q = zeroes 5; $q = zeroes 5;
minimum_n_ind $p, $q; minimum_n_ind $p, $q;
is $q.'', '[0 7 2 6 3]', "minimum_n_ind some bad, sufficient good"; is $q.'', '[0 7 2 6 3]', "minimum_n_ind some bad, sufficient good";
eval {is random()->type, 'double'};
is $@, '', 'random() works, defaults to double';
eval {is randsym()->type, 'double'};
is $@, '', 'randsym() works, defaults to double';
my $got;
##############################
# Test some operations with empty ndarrays
is random(1,1,0)->type, 'double'; # used to segfault
is_deeply $got=[append(zeroes(2,0),zeroes(3,0))->dims], [5,0] or diag "got:", ex
plain $got;
is_deeply append(zeroes(float,2,0),zeroes(3,0))->type, 'float';
is_deeply $got=[zeroes(2,3,1)->whereND(pdl '0 0')->dims], [0,3,1] or diag "got:"
, explain $got;
eval {is_deeply [zeroes(2,0)->whereND(pdl '1 1')->dims], [2,0]};
is $@, '', "zeroes(2,0)->whereND(pdl '1 1') works";
############################## ##############################
# check that our random functions work with Perl's srand # check that our random functions work with Perl's srand
TODO: { TODO: {
local $TODO = 'Some CPAN Testers fails for OpenBSD'; local $TODO = 'Some CPAN Testers fails for OpenBSD';
srand 5; srand 5;
my $r1 = random 10; my $r1 = random 10;
srand 5; srand 5;
my $r2 = random 10; my $r2 = random 10;
ok(tapprox($r1, $r2), "random and srand"); ok(tapprox($r1, $r2), "random and srand");
skipping to change at line 146 skipping to change at line 161
# Nontrivial empty mask case returns matching Empty -- whichND(Empty[2x0x2]) sho uld return Empty[3x0] # Nontrivial empty mask case returns matching Empty -- whichND(Empty[2x0x2]) sho uld return Empty[3x0]
$y = whichND(zeroes(2,0,2)); $y = whichND(zeroes(2,0,2));
is_deeply [$y->dims], [3,0], "whichND(Empty[2x0x2]) returns Empty[3x0]"; is_deeply [$y->dims], [3,0], "whichND(Empty[2x0x2]) returns Empty[3x0]";
$r = zeroes(7, 7); $r->set(3, 4, 1); $r = zeroes(7, 7); $r->set(3, 4, 1);
is $r->whichND.'', <<EOF, 'whichND works right (was failing on 32-bit)'; is $r->whichND.'', <<EOF, 'whichND works right (was failing on 32-bit)';
\n[\n [3 4]\n] \n[\n [3 4]\n]
EOF EOF
$x = pdl('[[i 2+3i] [4+5i 6+7i]]'); $x = pdl('[[i 2+3i] [4+5i 6+7i]]');
ok all(approx $x->norm, pdl(<<'EOF')), 'native complex norm works' or diag $x->n orm; ok tapprox $x->norm, pdl(<<'EOF'), 'native complex norm works' or diag $x->norm;
[ [
[0.267261i 0.534522+0.801783i] [0.267261i 0.534522+0.801783i]
[0.356348+0.445435i 0.534522+0.623609i] [0.356348+0.445435i 0.534522+0.623609i]
] ]
EOF EOF
############################## ##############################
# Simple test case for interpND # Simple test case for interpND
$x = xvals(10,10)+yvals(10,10)*10; $x = xvals(10,10)+yvals(10,10)*10;
my $index = cat(3+xvals(5,5)*0.25,7+yvals(5,5)*0.25)->reorder(2,0,1); my $index = cat(3+xvals(5,5)*0.25,7+yvals(5,5)*0.25)->reorder(2,0,1);
skipping to change at line 236 skipping to change at line 251
$y = which(($temp % 3) == 0); $y = which(($temp % 3) == 0);
$c = setops($x, 'AND', $y); $c = setops($x, 'AND', $y);
ok(tapprox($c, pdl([0, 6])), "setops AND"); ok(tapprox($c, pdl([0, 6])), "setops AND");
ok(tapprox(intersect($x,$y),pdl([0,6])), "intersect same as setops AND"); ok(tapprox(intersect($x,$y),pdl([0,6])), "intersect same as setops AND");
$c = setops($x,'OR',$y); $c = setops($x,'OR',$y);
ok(tapprox($c, pdl([0,2,3,4,6,8,9])), "setops OR"); ok(tapprox($c, pdl([0,2,3,4,6,8,9])), "setops OR");
$c = setops($x,'XOR',$y); $c = setops($x,'XOR',$y);
ok(tapprox($c, pdl([2,3,4,8,9])), "setops XOR"); ok(tapprox($c, pdl([2,3,4,8,9])), "setops XOR");
#Test intersect again #Test intersect again
my $intersect_test=intersect(pdl(1,-5,4,0), pdl(0,3,-5,2)); my $intersect_test=intersect(pdl(1,-5,4,0), pdl(0,3,-5,2));
ok (all($intersect_test==pdl(-5,0)), 'Intersect test values'); ok tapprox($intersect_test, pdl(-5,0)), 'Intersect test values';
{ {
# based on cases supplied by @jo-37 # based on cases supplied by @jo-37
my @cases = ( my @cases = (
[ pdl(1), empty(), empty() ], [ pdl(1), empty(), empty() ],
[ ones(1), empty(), empty() ], [ ones(1), empty(), empty() ],
[ ones(4), empty(), empty() ], [ ones(4), empty(), empty() ],
[ sequence(4), empty(), empty() ], [ sequence(4), empty(), empty() ],
[ pdl(1), ones(2), ones(1) ], [ pdl(1), ones(2), ones(1) ],
[ ones(1), ones(2), ones(1) ], [ ones(1), ones(2), ones(1) ],
[ ones(4), ones(2), ones(1) ], [ ones(4), ones(2), ones(1) ],
skipping to change at line 273 skipping to change at line 288
eval { $c = all($y==pdl([0])) }; eval { $c = all($y==pdl([0])) };
is $@, ''; is $@, '';
ok $c, "uniqind"; ok $c, "uniqind";
is $y->ndims, 1, "uniqind, SF bug 3076570"; is $y->ndims, 1, "uniqind, SF bug 3076570";
############################## ##############################
# Test whereND # Test whereND
$x = sequence(4,3,2); $x = sequence(4,3,2);
$y = pdl(0,1,1,0); $y = pdl(0,1,1,0);
$c = whereND($x,$y); $c = whereND($x,$y);
ok(all(pdl($c->dims)==pdl(2,3,2))) and is_deeply [$c->dims], [2,3,2];
ok(all($c==pdl q[ [ [ 1 2] [ 5 6] [ 9 10] ] ok tapprox($c, pdl q[[[1 2] [5 6] [9 10]] [[13 14] [17 18] [21 22]]]), "whereND
[ [13 14] [17 18] [21 22] ] ]), [4]";
"whereND [4]");
$y = pdl q[ 0 0 1 1 ; 0 1 0 0 ; 1 0 0 0 ]; $y = pdl q[ 0 0 1 1 ; 0 1 0 0 ; 1 0 0 0 ];
$c = whereND($x,$y); $c = whereND($x,$y);
ok(all(pdl($c->dims)==pdl(4,2))) and is_deeply [$c->dims], [4,2];
ok(all($c==pdl q[ 2 3 5 8 ; 14 15 17 20 ]), ok tapprox($c, pdl q[ 2 3 5 8 ; 14 15 17 20 ]), "whereND [4,3]";
"whereND [4,3]");
$y = (random($x)<0.3); $y = (random($x)<0.3);
$c = whereND($x,$y); $c = whereND($x,$y);
ok(all($c==where($x,$y)), "whereND vs where"); ok tapprox($c->squeeze, where($x,$y)), "whereND vs where";
# sf.net bug #3415115, whereND fails to handle all zero mask case # sf.net bug #3415115, whereND fails to handle all zero mask case
$y = zeros(4); $y = zeros(4);
$c = whereND($x,$y); $c = whereND($x,$y);
ok($c->isempty, 'whereND of all-zeros mask'); ok($c->isempty, 'whereND of all-zeros mask');
# Make sure whereND functions as an lvalue: # Make sure whereND functions as an lvalue:
$x = sequence(4,3); $x = sequence(4,3);
$y = pdl(0, 1, 1, 1); $y = pdl(0, 1, 1, 1);
eval { $x->whereND($y) *= -1 }; eval { $x->whereND($y) *= -1 };
is($@, '', 'using whereND in lvalue context does not croak'); is($@, '', 'using whereND in lvalue context does not croak');
ok(all($x->slice("1:-1") < 0), 'whereND in lvalue context works'); ok(all($x->slice("1:-1") < 0), 'whereND in lvalue context works');
#Test fibonacci. #Test fibonacci.
my $fib=fibonacci(15); my $fib=fibonacci(15);
my $fib_ans = pdl(1,1,2,3,5,8,13,21,34,55,89,144,233,377,610); my $fib_ans = pdl(1,1,2,3,5,8,13,21,34,55,89,144,233,377,610);
ok(all($fib == $fib_ans), 'Fibonacci sequence'); ok tapprox($fib, $fib_ans), 'Fibonacci sequence';
#Test which_both. #Test which_both.
my $which_both_test=pdl(1,4,-2,0,5,0,1); my $which_both_test=pdl(1,4,-2,0,5,0,1);
my ($nonzero,$zero)=which_both($which_both_test); my ($nonzero,$zero)=which_both($which_both_test);
ok(all($nonzero==pdl(0,1,2,4,6)), 'Which_both nonzero indices'); ok tapprox($nonzero, pdl(0,1,2,4,6)), 'Which_both nonzero indices';
ok(all($zero==pdl(3,5)), 'Which_both zero indices'); ok tapprox($zero, pdl(3,5)), 'Which_both zero indices';
###### Testing Begins ######### ###### Testing Begins #########
my $im = new PDL [ my $im = PDL->new([
[ 1, 2, 3, 3 , 5], [ 1, 2, 3, 3 , 5],
[ 2, 3, 4, 5, 6], [ 2, 3, 4, 5, 6],
[13, 13, 13, 13, 13], [13, 13, 13, 13, 13],
[ 1, 3, 1, 3, 1], [ 1, 3, 1, 3, 1],
[10, 10, 2, 2, 2,] [10, 10, 2, 2, 2,]
]; ]);
my @minMax = $im->minmax; my @minMax = $im->minmax;
ok($minMax[0] == 1, "minmax min" ); ok($minMax[0] == 1, "minmax min" );
ok($minMax[1] == 13, "minmax max" ); ok($minMax[1] == 13, "minmax max" );
ok(($im x $im)->sum == 3429, "matrix multiplication" ); ok(($im x $im)->sum == 3429, "matrix multiplication" );
my @statsRes = $im->stats; my @statsRes = $im->stats;
ok(tapprox($statsRes[0],5.36), "stats: mean" ); ok(tapprox($statsRes[0],5.36), "stats: mean" );
ok(tapprox($statsRes[1],4.554), "stats: prms"); ok(tapprox($statsRes[1],4.554), "stats: prms");
ok(tapprox($statsRes[2],3), "stats: median"); ok(tapprox($statsRes[2],3), "stats: median");
ok(tapprox($statsRes[3],1), "stats: min"); ok(tapprox($statsRes[3],1), "stats: min");
ok(tapprox($statsRes[4],13), "stats: max"); ok(tapprox($statsRes[4],13), "stats: max");
skipping to change at line 347 skipping to change at line 359
ok(tapprox($statsRes[0],5.36), "stats: trivial weights mean" ); ok(tapprox($statsRes[0],5.36), "stats: trivial weights mean" );
ok(tapprox($statsRes[1],4.554), "stats: trivial weights prms" ); ok(tapprox($statsRes[1],4.554), "stats: trivial weights prms" );
ok(tapprox($statsRes[2],3), "stats: trivial weights median" ); ok(tapprox($statsRes[2],3), "stats: trivial weights median" );
ok(tapprox($statsRes[3],1), "stats: trivial weights min" ); ok(tapprox($statsRes[3],1), "stats: trivial weights min" );
ok(tapprox($statsRes[4],13), "stats: trivial weights max" ); ok(tapprox($statsRes[4],13), "stats: trivial weights max" );
ok(tapprox($statsRes[6],4.462), "stats: trivial weights rms"); ok(tapprox($statsRes[6],4.462), "stats: trivial weights rms");
# complex matmult # complex matmult
my $cm1 = pdl('1 1+i 1'); my $cm1 = pdl('1 1+i 1');
my $cm2 = pdl('2 3 i')->transpose; my $cm2 = pdl('2 3 i')->transpose;
my $got = $cm1 x $cm2; $got = $cm1 x $cm2;
ok all(approx $got, pdl('5+4i')), 'complex matmult' or diag $got; ok tapprox($got, pdl('[[5+4i]]')), 'complex matmult';
throws_ok { scalar $cm1->transpose x $cm2 } qr/mismatch/, 'good error on mismatc h matmult'; throws_ok { scalar $cm1->transpose x $cm2 } qr/mismatch/, 'good error on mismatc h matmult';
{ {
my $pa = pdl [[ 1, 2, 3, 0], my $pa = pdl [[ 1, 2, 3, 0],
[ 1, -1, 2, 7], [ 1, -1, 2, 7],
[ 1, 0, 0, 1]]; [ 1, 0, 0, 1]];
my $pb = pdl [[1, 1], my $pb = pdl [[1, 1],
[0, 2], [0, 2],
[0, 2], [0, 2],
[1, 1]]; [1, 1]];
my $pc = pdl [[ 1, 11], my $pc = pdl [[ 1, 11],
[ 8, 10], [ 8, 10],
[ 2, 2]]; [ 2, 2]];
my $res = $pa x $pb; my $res = $pa x $pb;
ok(all approx($pc,$res)) or diag "got: $res"; ok tapprox($pc,$res);
$res = null; matmult($pa, $pb, $res = null);
matmult($pa, $pb, $res); ok tapprox($pc,$res), 'res=null';
ok(all(approx $pc,$res), 'res=null') or diag "got: $res";
my $pa_sliced = $pa->dummy(0, 3)->dummy(-1, 3)->make_physical->slice('(1),,,(1)' ); my $pa_sliced = $pa->dummy(0, 3)->dummy(-1, 3)->make_physical->slice('(1),,,(1)' );
$res = $pa_sliced x $pb; $res = $pa_sliced x $pb;
ok(all approx($pc,$res)) or diag "got: $res"; ok tapprox($pc,$res);
$res = zeroes(2, 3); $res = zeroes(2, 3);
matmult($pa, $pb, $res); matmult($pa, $pb, $res);
ok(all(approx $pc,$res), 'res=zeroes') or diag "got: $res"; ok tapprox($pc,$res), 'res=zeroes';
$res = ones(2, 3); $res = ones(2, 3);
matmult($pa, $pb, $res); matmult($pa, $pb, $res);
ok(all(approx $pc,$res), 'res=ones') or diag "got: $res"; ok tapprox($pc,$res), 'res=ones';
my $eq = float [[1,1,1,1]]; # a 4,1-matrix ( 1 1 1 1 ) my $eq = float [[1,1,1,1]]; # a 4,1-matrix ( 1 1 1 1 )
# Check collapse: output should be a 1x2... # Check collapse: output should be a 1x2...
ok(all approx($eq x $pb , pdl([[2,6]]) )); # ([4x1] x [2x4] -> [1x2]) ok tapprox($eq x $pb , pdl([[2,6]])); # ([4x1] x [2x4] -> [1x2])
# Check dimensional exception: mismatched dims should throw an error # Check dimensional exception: mismatched dims should throw an error
dies_ok { dies_ok {
my $pz = $pb x $eq; # [2x4] x [4x1] --> error (2 != 1) my $pz = $pb x $eq; # [2x4] x [4x1] --> error (2 != 1)
}; };
{ {
# Check automatic scalar multiplication # Check automatic scalar multiplication
my $pz; my $pz;
lives_ok { $pz = $pb x 2; }; lives_ok { $pz = $pb x 2; };
ok( all approx($pz,$pb * 2)); ok tapprox($pz,$pb * 2);
} }
{ {
my $pz; my $pz;
lives_ok { $pz = pdl(3) x $pb; }; lives_ok { $pz = pdl(3) x $pb; };
ok( all approx($pz,$pb * 3)); ok tapprox($pz,$pb * 3);
} }
} }
# which ND test # which ND test
my $a1 = PDL->sequence(10,10,3,4); my $a1 = PDL->sequence(10,10,3,4);
($x, $y, $z, my $w) = whichND($a1 == 203)->mv(0,-1)->dog; ($x, $y, $z, my $w) = whichND($a1 == 203)->mv(0,-1)->dog;
ok($a1->at($x->list,$y->list,$z->list,$w->list) == 203, "whichND" ); ok($a1->at($x->list,$y->list,$z->list,$w->list) == 203, "whichND" );
$a1 = pdl(1,2,3,4); $a1 = pdl(1,2,3,4);
skipping to change at line 438 skipping to change at line 449
# indadd Test: # indadd Test:
$a1 = pdl( 1,2,3); $a1 = pdl( 1,2,3);
my $ind = pdl( 1,4,6); my $ind = pdl( 1,4,6);
my $sum = zeroes(10); my $sum = zeroes(10);
indadd($a1,$ind, $sum); indadd($a1,$ind, $sum);
ok(tapprox($sum->sum,6), "indadd" ); ok(tapprox($sum->sum,6), "indadd" );
#one2nd test #one2nd test
$a1 = zeroes(3,4,5); $a1 = zeroes(3,4,5);
my $indicies = pdl(0,1,4,6,23,58,59); my $indices = pdl(0,1,4,6,23,58,59);
($x,$y,$z)=$a1->one2nd($indicies); ($x,$y,$z)=$a1->one2nd($indices);
ok(all( $x==pdl(0,1,1,0,2,1,2) ), "one2nd x"); ok tapprox($x, pdl(0,1,1,0,2,1,2)), "one2nd x";
ok(all( $y==pdl(0,0,1,2,3,3,3) ), "one2nd y"); ok tapprox($y, pdl(0,0,1,2,3,3,3)), "one2nd y";
ok(all( $z==pdl(0,0,0,0,1,4,4) ), "one2nd z"); ok tapprox($z, pdl(0,0,0,0,1,4,4)), "one2nd z";
{ {
my $yvalues = (new PDL( 0..5)) - 20; my $yvalues = PDL->new(0..5) - 20;
my $xvalues = -(new PDL (0..5))*.5; my $xvalues = -PDL->new(0..5)*.5;
my $x = new PDL(-2); my $x = PDL->new(-2);
is( $x->interpol($xvalues,$yvalues), -16, "interpolate: real-valued" ); is( $x->interpol($xvalues,$yvalues), -16, "interpolate: real-valued" );
} }
{ {
my $yvalues = ((new PDL( 0..5)) - 20) * (1+i()) ; my $yvalues = (PDL->new(0..5) - 20) * (1+i()) ;
my $xvalues = -(new PDL (0..5))*.5; my $xvalues = -PDL->new(0..5)*.5;
my $x = new PDL(-2); my $x = PDL->new(-2);
is( $x->interpol($xvalues,$yvalues), -16 - 16*i, "interpolate: complex-valued" ) ; is( $x->interpol($xvalues,$yvalues), -16 - 16*i, "interpolate: complex-valued" ) ;
ok( !eval { $x->interpol($xvalues*i(),$yvalues) } , "interpolate: x must be real " ); ok( !eval { $x->interpol($xvalues*i(),$yvalues) } , "interpolate: x must be real " );
} }
# Some of these tests are based upon those in Chapter 5 of Programming # Some of these tests are based upon those in Chapter 5 of Programming
# Pearls, by J. Bentley # Pearls, by J. Bentley
{ {
# choose a non-factor of two odd number for the length # choose a non-factor of two odd number for the length
my $N = 723; my $N = 723;
skipping to change at line 838 skipping to change at line 849
subtest $mode => sub { subtest $mode => sub {
my ( $got, $exp ); my ( $got, $exp );
for my $sort_direction ( qw[ forward reverse ] ) { for my $sort_direction ( qw[ forward reverse ] ) {
subtest $sort_direction => sub { subtest $sort_direction => sub {
my $so = $data->{$sort_direction} my $so = $data->{$sort_direction}
or plan( skip_all => "not testing $sort_direction!\n" ); or plan( skip_all => "not testing $sort_direction!\n" );
ok( ok tapprox(
all( vsearch( $so->{x}, $so->{x}, { mode => $mode } ),
( $got = vsearch( $so->{x}, $so->{x}, { mode => $mode } $so->{equal}
) ) ),
== 'equal elements';
( $exp = $so->{equal} )
), ok tapprox(
'equal elements' vsearch( $so->{x} - 5, $so->{x}, { mode => $mode } ),
) or diag "got : $got\nexpected: $exp\n"; $so->{nequal_m}
),
ok( 'non-equal elements x[i] < xs[i] (check lower bound)';
all(
( $got = vsearch( $so->{x} - 5, $so->{x}, { mode => $mod ok tapprox(
e } ) ) vsearch( $so->{x} + 5, $so->{x}, { mode => $mode } ),
== $so->{nequal_p}
( $exp = $so->{nequal_m} ) ),
), 'non-equal elements x[i] > xs[i] (check upper bound)';
'non-equal elements x[i] < xs[i] (check lower bound)'
) or diag "got : $got\nexpected: $exp\n";
ok(
all(
( $got = vsearch( $so->{x} + 5, $so->{x}, { mode => $mod
e } ) )
==
( $exp = $so->{nequal_p} )
),
'non-equal elements x[i] > xs[i] (check upper bound)'
) or diag "got : $got\nexpected: $exp\n";
# duplicate testing. # duplicate testing.
# check for values. note that the rightmost routine returns # check for values. note that the rightmost routine returns
# the index of the element *after* the last duplicate # the index of the element *after* the last duplicate
# value, so we need an offset # value, so we need an offset
ok( ok tapprox(
all( $so->{xdup}{set}->index( vsearch( $so->{xdup}{values}, $so->
( $got = $so->{xdup}{set}->index( vsearch( $so->{xdup}{va {xdup}{set}, { mode => $mode } )
lues}, $so->{xdup}{set}, { mode => $mode } ) + ($so->{xd
+ ($so-> up}{idx_offset} || 0) ),
{xdup}{idx_offset} || 0) ) ) $so->{xdup}{values}
== ),
( $exp = $so->{xdup}{values} ) 'duplicates values';
),
'duplicates values'
) or diag "got : $got\nexpected: $exp\n";
# if there are guarantees about which duplicates are returned, te st it # if there are guarantees about which duplicates are returned, te st it
if ( exists $so->{xdup}{idx} ) { if ( exists $so->{xdup}{idx} ) {
ok tapprox(
ok( vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode =
all( > $mode } ),
( $got = vsearch( $so->{xdup}{values}, $so->{xdup}{se $so->{xdup}{idx}
t}, { mode => $mode } ) ) ),
== 'duplicate indices';
( $exp = $so->{xdup}{idx} )
),
'duplicate indices'
) or diag "got : $got\nexpected: $exp\n";
} }
if ( exists $so->{docs} ) { if ( exists $so->{docs} ) {
while( my ($label, $inputs ) = splice( @{$so->{docs}}, 0, 2 ) ) { while( my ($label, $inputs ) = splice( @{$so->{docs}}, 0, 2 ) ) {
while( @$inputs ) { while( @$inputs ) {
my ( $idx, $offset, $exp ) = splice( @$inputs, 0, 3 ) ; my ( $idx, $offset, $exp ) = splice( @$inputs, 0, 3 ) ;
my $value = $so->{x}->at($idx) + $offset; my $value = $so->{x}->at($idx) + $offset;
is vsearch( $value, $so->{x}, { mode => $mode } )->sc
is ( $got = ( vsearch( $value, $so->{x}, { mode => $m lr, $exp, "$label: ($idx, $offset)";
ode } )->sclr), $exp, "$label: ($idx, $offset)" );
} }
} }
} }
}; };
} }
ok( ok tapprox(
all( vsearch( $ones, $ones, { mode => $mode } )->uniq->squeeze,
( $got = vsearch( $ones, $ones, { mode => $mode } ) ) $data->{all_the_same_element}
== ),
( $exp = $data->{all_the_same_element} ) 'all the same element';
),
'all the same element'
) or diag "got : $got\nexpected: $exp\n";
}; };
} }
# test vsearch API to ensure backwards compatibility # test vsearch API to ensure backwards compatibility
{ {
my $vals = random( 100 ); my $vals = random( 100 );
my $xs = sequence(100) / 99; my $xs = sequence(100) / 99;
# implicit output ndarray # implicit output ndarray
my $indx0 = vsearch( $vals, $xs ); my $indx0 = vsearch( $vals, $xs );
my $ret = vsearch( $vals, $xs, my $indx1 = PDL->null() ); my $ret = vsearch( $vals, $xs, my $indx1 = PDL->null() );
is( $ret, undef, "no return from explicit output ndarray" ); is( $ret, undef, "no return from explicit output ndarray" );
ok tapprox($indx0, $indx1), 'explicit ndarray == implicit ndarray';
ok ( all ( $indx0 == $indx1 ),
'explicit ndarray == implicit ndarray' );
} }
} }
my $vdim = 4; my $vdim = 4;
my $v1 = zeroes($vdim); my $v1 = zeroes($vdim);
my $v2 = pdl($v1); my $v2 = pdl($v1);
$v2->set(-1,1); $v2->set(-1,1);
ok $v1->cmpvec($v2)<0, "cmpvec:1d:<"; ok $v1->cmpvec($v2)<0, "cmpvec:1d:<";
ok $v2->cmpvec($v1)>0, "cmpvec:1d:>"; ok $v2->cmpvec($v1)>0, "cmpvec:1d:>";
is $v1->cmpvec($v1)->sclr, 0, "cmpvec:1d:=="; is $v1->cmpvec($v1)->sclr, 0, "cmpvec:1d:==";
##-- 4..5: qsortvec, qsortveci ##-- 4..5: qsortvec, qsortveci
my $p2d = pdl([[1,2],[3,4],[1,3],[1,2],[3,3]]); my $p2d = pdl([[1,2],[3,4],[1,3],[1,2],[3,3]]);
ok all(approx($p2d->qsortvec, pdl(long,[[1,2],[1,2],[1,3],[3,3],[3,4]]))), "qsor ok tapprox($p2d->qsortvec, pdl(long,[[1,2],[1,2],[1,3],[3,3],[3,4]])), "qsortvec
tvec"; ";
ok all(approx($p2d->dice_axis(1,$p2d->qsortveci), $p2d->qsortvec)), "qsortveci"; ok tapprox($p2d->dice_axis(1,$p2d->qsortveci), $p2d->qsortvec), "qsortveci";
my $which = pdl(long,[[0,0],[0,0],[0,1],[0,1],[1,0],[1,0],[1,1],[1,1]]); my $which = pdl(long,[[0,0],[0,0],[0,1],[0,1],[1,0],[1,0],[1,1],[1,1]]);
my $find = $which->slice(",0:-1:2"); my $find = $which->slice(",0:-1:2");
ok all(approx($find->vsearchvec($which), pdl(long,[0,2,4,6]))), "vsearchvec():ma ok tapprox($find->vsearchvec($which), pdl(long,[0,2,4,6])), "vsearchvec():match"
tch"; ;
ok all(pdl([-1,-1])->vsearchvec($which)==0), "vsearchvec():<<"; ok tapprox(pdl([-1,-1])->vsearchvec($which), 0), "vsearchvec():<<";
ok all(pdl([2,2])->vsearchvec($which)==$which->dim(1)-1), "vsearchvec():>>"; ok tapprox(pdl([2,2])->vsearchvec($which), $which->dim(1)-1), "vsearchvec():>>";
my $vtype = long; my $vtype = long;
my $universe = pdl($vtype,[ [0,0],[0,1],[1,0],[1,1] ]); my $universe = pdl($vtype,[ [0,0],[0,1],[1,0],[1,1] ]);
$v1 = $universe->dice_axis(1,pdl([0,1,2])); $v1 = $universe->dice_axis(1,pdl([0,1,2]));
$v2 = $universe->dice_axis(1,pdl([1,2,3])); $v2 = $universe->dice_axis(1,pdl([1,2,3]));
($c,my $nc) = $v1->unionvec($v2); ($c,my $nc) = $v1->unionvec($v2);
ok all(approx($c, pdl($vtype, [ [0,0],[0,1],[1,0],[1,1],[0,0],[0,0] ]))), "union vec:list:c"; ok tapprox($c, pdl($vtype, [ [0,0],[0,1],[1,0],[1,1],[0,0],[0,0] ])), "unionvec: list:c";
is $nc, $universe->dim(1), "unionvec:list:nc"; is $nc, $universe->dim(1), "unionvec:list:nc";
my $cc = $v1->unionvec($v2); my $cc = $v1->unionvec($v2);
ok all(approx($cc, $universe)), "unionvec:scalar"; ok tapprox($cc, $universe), "unionvec:scalar";
($c,$nc) = $v1->intersectvec($v2); ($c,$nc) = $v1->intersectvec($v2);
ok all(approx($c, pdl($vtype, [ [0,1],[1,0],[0,0] ]))), "intersectvec:list:c"; ok tapprox($c, pdl($vtype, [ [0,1],[1,0],[0,0] ])), "intersectvec:list:c";
is $nc->sclr, 2, "intersectvec:list:nc"; is $nc->sclr, 2, "intersectvec:list:nc";
$cc = $v1->intersectvec($v2); $cc = $v1->intersectvec($v2);
ok all(approx($cc, $universe->slice(",1:2"))), "intersectvec:scalar"; ok tapprox($cc, $universe->slice(",1:2")), "intersectvec:scalar";
($c,$nc) = $v1->setdiffvec($v2); ($c,$nc) = $v1->setdiffvec($v2);
ok all(approx($c, pdl($vtype, [ [0,0], [0,0],[0,0] ]))), "setdiffvec:list:c"; ok tapprox($c, pdl($vtype, [ [0,0], [0,0],[0,0] ])), "setdiffvec:list:c";
is $nc, 1, "setdiffvec:list:nc"; is $nc, 1, "setdiffvec:list:nc";
$cc = $v1->setdiffvec($v2); $cc = $v1->setdiffvec($v2);
ok all(approx($cc, pdl($vtype, [[0,0]]))), "setdiffvec:scalar"; ok tapprox($cc, pdl($vtype, [[0,0]])), "setdiffvec:scalar";
my $all = sequence(20); my $all = sequence(20);
my $amask = ($all % 2)==0; my $amask = ($all % 2)==0;
my $bmask = ($all % 3)==0; my $bmask = ($all % 3)==0;
my $a = $all->where($amask); my $a = $all->where($amask);
my $b = $all->where($bmask); my $b = $all->where($bmask);
ok all(approx(scalar($a->union_sorted($b)), $all->where($amask | $bmask))), "uni ok tapprox(scalar($a->union_sorted($b)), $all->where($amask | $bmask)), "union_s
on_sorted"; orted";
ok all(approx(scalar($a->intersect_sorted($b)), $all->where($amask & $bmask))), ok tapprox(scalar($a->intersect_sorted($b)), $all->where($amask & $bmask)), "in
"intersect_sorted"; tersect_sorted";
ok all(approx(scalar($a->setdiff_sorted($b)), $all->where($amask & $bmask->not)) ok tapprox(scalar($a->setdiff_sorted($b)), $all->where($amask & $bmask->not)), "
), "setdiff_sorted"; setdiff_sorted";
##-------------------------------------------------------------- ##--------------------------------------------------------------
## dim-checks and implicit broadcast dimensions ## dim-checks and implicit broadcast dimensions
## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4
sub test_broadcast_dimensions { sub test_broadcast_dimensions {
##-- unionvec ##-- unionvec
my $empty = zeroes(3,0); my $empty = zeroes(3,0);
my $uw = pdl([[-3,-2,-1],[1,2,3]]); my $uw = pdl([[-3,-2,-1],[1,2,3]]);
my $wx = pdl([[1,2,3],[4,5,6]]); my $wx = pdl([[1,2,3],[4,5,6]]);
my $xy = pdl([[4,5,6],[7,8,9]]); my $xy = pdl([[4,5,6],[7,8,9]]);
# unionvec: basic # unionvec: basic
ok all(approx(scalar($uw->unionvec($wx)), pdl([[-3,-2,-1],[1,2,3],[4,5,6]]))), ok tapprox(scalar($uw->unionvec($wx)), pdl([[-3,-2,-1],[1,2,3],[4,5,6]])), "un
"unionvec - broadcast dims - uw+wx"; ionvec - broadcast dims - uw+wx";
ok all(approx(scalar($uw->unionvec($xy)), pdl([[-3,-2,-1],[1,2,3],[4,5,6],[7,8 ok tapprox(scalar($uw->unionvec($xy)), pdl([[-3,-2,-1],[1,2,3],[4,5,6],[7,8,9]
,9]]))), "unionvec - broadcast dims - uw+xy"; ])), "unionvec - broadcast dims - uw+xy";
ok all(approx(scalar($empty->unionvec($wx)), $wx)), "unionvec - broadcast dims ok tapprox(scalar($empty->unionvec($wx)), $wx), "unionvec - broadcast dims - 0
- 0+wx"; +wx";
ok all(approx(scalar($wx->unionvec($empty)), $wx)), "unionvec - broadcast dims ok tapprox(scalar($wx->unionvec($empty)), $wx), "unionvec - broadcast dims - w
- wx+0"; x+0";
ok all(approx(scalar($empty->unionvec($empty)), $empty)), "unionvec - broadcas ok tapprox(scalar($empty->unionvec($empty)), $empty), "unionvec - broadcast di
t dims - 0+0"; ms - 0+0";
# unionvec: broadcasting # unionvec: broadcasting
my $k = 2; my $k = 2;
my $kempty = $empty->slice(",,*$k"); my $kempty = $empty->slice(",,*$k");
my $kuw = $uw->slice(",,*$k"); my $kuw = $uw->slice(",,*$k");
my $kwx = $wx->slice(",,*$k"); my $kwx = $wx->slice(",,*$k");
my $kxy = $xy->slice(",,*$k"); my $kxy = $xy->slice(",,*$k");
ok all(approx(scalar($kuw->unionvec($wx)), pdl([[-3,-2,-1],[1,2,3],[4,5,6]])-> ok tapprox(scalar($kuw->unionvec($wx)), pdl([[-3,-2,-1],[1,2,3],[4,5,6]])->sli
slice(",,*$k"))), "unionvec - broadcast dims - uw(*k)+wx"; ce(",,*$k")), "unionvec - broadcast dims - uw(*k)+wx";
ok all(approx(scalar($kuw->unionvec($xy)), pdl([[-3,-2,-1],[1,2,3],[4,5,6],[7, ok tapprox(scalar($kuw->unionvec($xy)), pdl([[-3,-2,-1],[1,2,3],[4,5,6],[7,8,9
8,9]])->slice(",,*$k"))), "unionvec - broadcast dims - uw(*k)+xy"; ]])->slice(",,*$k")), "unionvec - broadcast dims - uw(*k)+xy";
ok all(approx(scalar($kempty->unionvec($wx)), $kwx)), "unionvec - broadcast di ok tapprox(scalar($kempty->unionvec($wx)), $kwx), "unionvec - broadcast dims -
ms - 0(*k)+wx"; 0(*k)+wx";
ok all(approx(scalar($kwx->unionvec($empty)), $kwx)), "unionvec - broadcast di ok tapprox(scalar($kwx->unionvec($empty)), $kwx), "unionvec - broadcast dims -
ms - wx(*k)+0"; wx(*k)+0";
ok all(approx(scalar($kempty->unionvec($empty)), $kempty)), "unionvec - broadc ok tapprox(scalar($kempty->unionvec($empty)), $kempty), "unionvec - broadcast
ast dims - 0(*k)+0"; dims - 0(*k)+0";
##-- intersectvec ##-- intersectvec
my $needle0 = pdl([[-3,-2,-1]]); my $needle0 = pdl([[-3,-2,-1]]);
my $needle1 = pdl([[1,2,3]]); my $needle1 = pdl([[1,2,3]]);
my $needles = pdl([[-3,-2,-1],[1,2,3]]); my $needles = pdl([[-3,-2,-1],[1,2,3]]);
my $haystack = pdl([[1,2,3],[4,5,6],[7,8,9],[10,11,12]]); my $haystack = pdl([[1,2,3],[4,5,6],[7,8,9],[10,11,12]]);
# intersectvec: basic # intersectvec: basic
ok all(approx(scalar($needle0->intersectvec($haystack)), $empty)), "intersectv ok tapprox(scalar($needle0->intersectvec($haystack)), $empty), "intersectvec -
ec - broadcast dims - needle0&haystack"; broadcast dims - needle0&haystack";
ok all(approx(scalar($needle1->intersectvec($haystack)), $needle1)), "intersec ok tapprox(scalar($needle1->intersectvec($haystack)), $needle1), "intersectvec
tvec - broadcast dims - needle1&haystack"; - broadcast dims - needle1&haystack";
ok all(approx(scalar($needles->intersectvec($haystack)), $needle1)), "intersec ok tapprox(scalar($needles->intersectvec($haystack)), $needle1), "intersectvec
tvec - broadcast dims - needles&haystack"; - broadcast dims - needles&haystack";
ok all(approx(scalar($haystack->intersectvec($haystack)), $haystack)), "inters ok tapprox(scalar($haystack->intersectvec($haystack)), $haystack), "intersectv
ectvec - broadcast dims - haystack&haystack"; ec - broadcast dims - haystack&haystack";
ok all(approx(scalar($haystack->intersectvec($empty)), $empty)), "intersectvec ok tapprox(scalar($haystack->intersectvec($empty)), $empty), "intersectvec - b
- broadcast dims - haystack&empty"; roadcast dims - haystack&empty";
ok all(approx(scalar($empty->intersectvec($haystack)), $empty)), "intersectvec ok tapprox(scalar($empty->intersectvec($haystack)), $empty), "intersectvec - b
- broadcast dims - empty&haystack"; roadcast dims - empty&haystack";
# intersectvec: broadcasting # intersectvec: broadcasting
my $kneedle0 = $needle0->slice(",,*$k"); my $kneedle0 = $needle0->slice(",,*$k");
my $kneedle1 = $needle1->slice(",,*$k"); my $kneedle1 = $needle1->slice(",,*$k");
my $kneedles = pdl([[[-3,-2,-1]],[[1,2,3]]]); my $kneedles = pdl([[[-3,-2,-1]],[[1,2,3]]]);
my $khaystack = $haystack->slice(",,*$k"); my $khaystack = $haystack->slice(",,*$k");
ok all(approx(scalar($kneedle0->intersectvec($haystack)), $kempty)), "intersec ok tapprox(scalar($kneedle0->intersectvec($haystack)), $kempty), "intersectvec
tvec - broadcast dims - needle0(*k)&haystack"; - broadcast dims - needle0(*k)&haystack";
ok all(approx(scalar($kneedle1->intersectvec($haystack)), $kneedle1)), "inters ok tapprox(scalar($kneedle1->intersectvec($haystack)), $kneedle1), "intersectv
ectvec - broadcast dims - needle1(*k)&haystack"; ec - broadcast dims - needle1(*k)&haystack";
ok all(approx( ok tapprox(
scalar($kneedles->intersectvec($haystack)), scalar($kneedles->intersectvec($haystack)),
pdl([[[0,0,0]],[[1,2,3]]]))), "intersectvec - broadcast dims - needles(*k pdl([[[0,0,0]],[[1,2,3]]])), "intersectvec - broadcast dims - needles(*k)
)&haystack"; &haystack";
ok all(approx(scalar($khaystack->intersectvec($haystack)), $khaystack)), "inte ok tapprox(scalar($khaystack->intersectvec($haystack)), $khaystack), "intersec
rsectvec - broadcast dims - haystack(*k)&haystack"; tvec - broadcast dims - haystack(*k)&haystack";
ok all(approx(scalar($khaystack->intersectvec($empty)), $kempty)), "intersectv ok tapprox(scalar($khaystack->intersectvec($empty)), $kempty), "intersectvec -
ec - broadcast dims - haystack(*k)&empty"; broadcast dims - haystack(*k)&empty";
ok all(approx(scalar($kempty->intersectvec($haystack)), $kempty)), "intersectv ok tapprox(scalar($kempty->intersectvec($haystack)), $kempty), "intersectvec -
ec - broadcast dims - empty(*k)&haystack"; broadcast dims - empty(*k)&haystack";
##-- setdiffvec ##-- setdiffvec
# setdiffvec: basic # setdiffvec: basic
ok all(approx(scalar($haystack->setdiffvec($needle0)), $haystack)), "setdiffve ok tapprox(scalar($haystack->setdiffvec($needle0)), $haystack), "setdiffvec -
c - broadcast dims - haystack-needle0"; broadcast dims - haystack-needle0";
ok all(approx(scalar($haystack->setdiffvec($needle1)), $haystack->slice(",1:-1 ok tapprox(scalar($haystack->setdiffvec($needle1)), $haystack->slice(",1:-1"))
"))), "setdiffvec - broadcast dims - haystack-needle1"; , "setdiffvec - broadcast dims - haystack-needle1";
ok all(approx(scalar($haystack->setdiffvec($needles)), $haystack->slice(",1:-1 ok tapprox(scalar($haystack->setdiffvec($needles)), $haystack->slice(",1:-1"))
"))), "setdiffvec - broadcast dims - haystack-needles"; , "setdiffvec - broadcast dims - haystack-needles";
ok all(approx(scalar($haystack->setdiffvec($haystack)), $empty)), "setdiffvec ok tapprox(scalar($haystack->setdiffvec($haystack)), $empty), "setdiffvec - br
- broadcast dims - haystack-haystack"; oadcast dims - haystack-haystack";
ok all(approx(scalar($haystack->setdiffvec($empty)), $haystack)), "setdiffvec ok tapprox(scalar($haystack->setdiffvec($empty)), $haystack), "setdiffvec - br
- broadcast dims - haystack-empty"; oadcast dims - haystack-empty";
ok all(approx(scalar($empty->setdiffvec($haystack)), $empty)), "setdiffvec - b ok tapprox(scalar($empty->setdiffvec($haystack)), $empty), "setdiffvec - broad
roadcast dims - empty-haystack"; cast dims - empty-haystack";
# setdiffvec: broadcasting # setdiffvec: broadcasting
ok all(approx(scalar($khaystack->setdiffvec($needle0)), $khaystack)), "setdiff ok tapprox(scalar($khaystack->setdiffvec($needle0)), $khaystack), "setdiffvec
vec - broadcast dims - haystack(*k)-needle0"; - broadcast dims - haystack(*k)-needle0";
ok all(approx(scalar($khaystack->setdiffvec($needle1)), $khaystack->slice(",1: ok tapprox(scalar($khaystack->setdiffvec($needle1)), $khaystack->slice(",1:-1,
-1,"))), "setdiffvec - broadcast dims - haystack(*k)-needle1"; ")), "setdiffvec - broadcast dims - haystack(*k)-needle1";
ok all(approx(scalar($khaystack->setdiffvec($needles)), $khaystack->slice(",1: ok tapprox(scalar($khaystack->setdiffvec($needles)), $khaystack->slice(",1:-1,
-1,"))), "setdiffvec - broadcast dims - haystack(*k)-needles"; ")), "setdiffvec - broadcast dims - haystack(*k)-needles";
ok all(approx(scalar($khaystack->setdiffvec($haystack)), $kempty)), "setdiffve ok tapprox(scalar($khaystack->setdiffvec($haystack)), $kempty), "setdiffvec -
c - broadcast dims - haystack(*k)-haystack"; broadcast dims - haystack(*k)-haystack";
ok all(approx(scalar($khaystack->setdiffvec($empty)), $khaystack)), "setdiffve ok tapprox(scalar($khaystack->setdiffvec($empty)), $khaystack), "setdiffvec -
c - broadcast dims - haystack(*k)-empty"; broadcast dims - haystack(*k)-empty";
ok all(approx(scalar($kempty->setdiffvec($haystack)), $kempty)), "setdiffvec - ok tapprox(scalar($kempty->setdiffvec($haystack)), $kempty), "setdiffvec - bro
broadcast dims - empty(*k)-haystack"; adcast dims - empty(*k)-haystack";
} }
test_broadcast_dimensions(); test_broadcast_dimensions();
## intersectvec tests as suggested by ETJ/mowhawk2 ## intersectvec tests as suggested by ETJ/mowhawk2
## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4
sub test_intersect_implicit_dims { sub test_intersect_implicit_dims {
# intersectvec: from ETJ/mowhawk2 a la https://stackoverflow.com/a/71446817/38 57002 # intersectvec: from ETJ/mowhawk2 a la https://stackoverflow.com/a/71446817/38 57002
my $toto = pdl([1,2,3], [4,5,6]); my $toto = pdl([1,2,3], [4,5,6]);
my $titi = pdl(1,2,3); my $titi = pdl(1,2,3);
my $notin = pdl(7,8,9); my $notin = pdl(7,8,9);
my ($c); my ($c);
ok all(approx($c=intersectvec($titi,$toto), [[1,2,3]])), 'intersectvec - impli ok tapprox($c=intersectvec($titi,$toto), [[1,2,3]]), 'intersectvec - implicit
cit dims - titi&toto'; dims - titi&toto';
ok all(approx($c=intersectvec($notin,$toto), zeroes(3,0))), 'intersectvec - im ok tapprox($c=intersectvec($notin,$toto), zeroes(3,0)), 'intersectvec - implic
plicit dims - notin&toto'; it dims - notin&toto';
ok all(approx($c=intersectvec($titi->dummy(1), $toto), [[1,2,3]])), 'intersect ok tapprox($c=intersectvec($titi->dummy(1), $toto), [[1,2,3]]), 'intersectvec
vec - implicit dims - titi(*1)&toto'; - implicit dims - titi(*1)&toto';
ok all(approx($c=intersectvec($notin->dummy(1), $toto), zeroes(3,0))), 'inters ok tapprox($c=intersectvec($notin->dummy(1), $toto), zeroes(3,0)), 'intersectv
ectvec - implicit dims - notin(*1)&toto'; ec - implicit dims - notin(*1)&toto';
my $needle0_in = pdl([1,2,3]); # 3 my $needle0_in = pdl([1,2,3]); # 3
my $needle0_notin = pdl([9,9,9]); # 3 my $needle0_notin = pdl([9,9,9]); # 3
my $needle_in = $needle0_in->dummy(1); # 3x1: [[1 2 3]] my $needle_in = $needle0_in->dummy(1); # 3x1: [[1 2 3]]
my $needle_notin = $needle0_notin->dummy(1); # 3x1: [[-3 -2 -1]] my $needle_notin = $needle0_notin->dummy(1); # 3x1: [[-3 -2 -1]]
my $needles = pdl([[1,2,3],[9,9,9]]); # 3x2: $needle0_in->cat($needle0_notin) my $needles = pdl([[1,2,3],[9,9,9]]); # 3x2: $needle0_in->cat($needle0_notin)
my $haystack = pdl([[1,2,3],[4,5,6]]); # 3x2 my $haystack = pdl([[1,2,3],[4,5,6]]); # 3x2
sub intersect_ok { sub intersect_ok {
my ($label, $a,$b, $c_want,$nc_want,$c_sclr_want) = @_; my ($label, $a,$b, $c_want,$nc_want,$c_sclr_want) = @_;
my ($c, $nc) = intersectvec($a,$b); my ($c, $nc) = intersectvec($a,$b);
my $c_sclr = intersectvec($a,$b); my $c_sclr = intersectvec($a,$b);
ok all(approx($c, $c_want)), "$label - result"; ok tapprox($c, $c_want), "$label - result";
ok all(approx($nc, $nc_want)), "$label - counts"; ok tapprox($nc, $nc_want), "$label - counts";
ok all(approx($c_sclr, $c_sclr_want)), "$label - scalar"; ok tapprox($c_sclr, $c_sclr_want), "$label - scalar";
} }
intersect_ok('intersectvec - implicit dims - needle0_in&haystack', intersect_ok('intersectvec - implicit dims - needle0_in&haystack',
$needle0_in, $haystack, $needle0_in, $haystack,
[[1,2,3]], 1, [[1,2,3]] [[1,2,3]], 1, [[1,2,3]]
); );
intersect_ok('intersectvec - implicit dims - needle_in&haystack', intersect_ok('intersectvec - implicit dims - needle_in&haystack',
$needle_in, $haystack, $needle_in, $haystack,
[[1,2,3]], 1, [[1,2,3]] [[1,2,3]], 1, [[1,2,3]]
); );
skipping to change at line 1171 skipping to change at line 1149
my $v1_4 = $v1_2->cat($v3_4)->flat; my $v1_4 = $v1_2->cat($v3_4)->flat;
# data: broadcasting # data: broadcasting
my $k = 2; my $k = 2;
my $kempty = $empty->slice(",*$k"); my $kempty = $empty->slice(",*$k");
my $kv1_2 = $v1_2->slice(",*$k"); my $kv1_2 = $v1_2->slice(",*$k");
my $kv3_4 = $v3_4->slice(",*$k"); my $kv3_4 = $v3_4->slice(",*$k");
my $kv1_4 = $v1_4->slice(",*$k"); my $kv1_4 = $v1_4->slice(",*$k");
#-- union_sorted #-- union_sorted
ok all(approx(scalar($v1_2->union_sorted($v3_4)), $v1_4)), "union_sorted - bro ok tapprox(scalar($v1_2->union_sorted($v3_4)), $v1_4), "union_sorted - broadca
adcast dims - 12+34"; st dims - 12+34";
ok all(approx(scalar($v3_4->union_sorted($v1_4)), $v1_4)), "union_sorted - bro ok tapprox(scalar($v3_4->union_sorted($v1_4)), $v1_4), "union_sorted - broadca
adcast dims - 34+1234"; st dims - 34+1234";
ok all(approx(scalar($empty->union_sorted($v1_4)), $v1_4)), "union_sorted - br ok tapprox(scalar($empty->union_sorted($v1_4)), $v1_4), "union_sorted - broadc
oadcast dims - 0+1234"; ast dims - 0+1234";
ok all(approx(scalar($v1_4->union_sorted($empty)), $v1_4)), "union_sorted - br ok tapprox(scalar($v1_4->union_sorted($empty)), $v1_4), "union_sorted - broadc
oadcast dims - 1234+0"; ast dims - 1234+0";
ok all(approx(scalar($empty->union_sorted($empty)), $empty)), "union_sorted - ok tapprox(scalar($empty->union_sorted($empty)), $empty), "union_sorted - broa
broadcast dims - 0+0"; dcast dims - 0+0";
# #
ok all(approx(scalar($kv1_2->union_sorted($v3_4)), $kv1_4)), "union_sorted - b ok tapprox(scalar($kv1_2->union_sorted($v3_4)), $kv1_4), "union_sorted - broad
roadcast dims - 12(*k)+34"; cast dims - 12(*k)+34";
ok all(approx(scalar($kv3_4->union_sorted($v1_4)), $kv1_4)), "union_sorted - b ok tapprox(scalar($kv3_4->union_sorted($v1_4)), $kv1_4), "union_sorted - broad
roadcast dims - 34(*k)+1234"; cast dims - 34(*k)+1234";
ok all(approx(scalar($kempty->union_sorted($v1_4)), $kv1_4)), "union_sorted - ok tapprox(scalar($kempty->union_sorted($v1_4)), $kv1_4), "union_sorted - broa
broadcast dims - 0(*k)+1234"; dcast dims - 0(*k)+1234";
ok all(approx(scalar($kv1_4->union_sorted($empty)), $kv1_4)), "union_sorted - ok tapprox(scalar($kv1_4->union_sorted($empty)), $kv1_4), "union_sorted - broa
broadcast dims - 1234(*k)+0"; dcast dims - 1234(*k)+0";
ok all(approx(scalar($kempty->union_sorted($empty)), $kempty)), "union_sorted ok tapprox(scalar($kempty->union_sorted($empty)), $kempty), "union_sorted - br
- broadcast dims - 0(*k)+0"; oadcast dims - 0(*k)+0";
#-- intersect_sorted #-- intersect_sorted
ok all(approx(scalar($v1_2->intersect_sorted($v3_4)), $empty)), "intersect_sor ok tapprox(scalar($v1_2->intersect_sorted($v3_4)), $empty), "intersect_sorted
ted - broadcast dims - 12&34"; - broadcast dims - 12&34";
ok all(approx(scalar($v3_4->intersect_sorted($v1_4)), $v3_4)), "intersect_sort ok tapprox(scalar($v3_4->intersect_sorted($v1_4)), $v3_4), "intersect_sorted -
ed - broadcast dims - 34&1234"; broadcast dims - 34&1234";
ok all(approx(scalar($empty->intersect_sorted($v1_4)), $empty)), "intersect_so ok tapprox(scalar($empty->intersect_sorted($v1_4)), $empty), "intersect_sorted
rted - broadcast dims - 0&1234"; - broadcast dims - 0&1234";
ok all(approx(scalar($v1_4->intersect_sorted($empty)), $empty)), "intersect_so ok tapprox(scalar($v1_4->intersect_sorted($empty)), $empty), "intersect_sorted
rted - broadcast dims - 1234&0"; - broadcast dims - 1234&0";
ok all(approx(scalar($empty->intersect_sorted($empty)), $empty)), "intersect_s ok tapprox(scalar($empty->intersect_sorted($empty)), $empty), "intersect_sorte
orted - broadcast dims - 0&0"; d - broadcast dims - 0&0";
# #
ok all(approx(scalar($kv1_2->intersect_sorted($v3_4)), $kempty)), "intersect_s ok tapprox(scalar($kv1_2->intersect_sorted($v3_4)), $kempty), "intersect_sorte
orted - broadcast dims - 12(*k)&34"; d - broadcast dims - 12(*k)&34";
ok all(approx(scalar($kv3_4->intersect_sorted($v1_4)), $kv3_4)), "intersect_so ok tapprox(scalar($kv3_4->intersect_sorted($v1_4)), $kv3_4), "intersect_sorted
rted - broadcast dims - 34(*k)&1234"; - broadcast dims - 34(*k)&1234";
ok all(approx(scalar($kempty->intersect_sorted($v1_4)), $kempty)), "intersect_ ok tapprox(scalar($kempty->intersect_sorted($v1_4)), $kempty), "intersect_sort
sorted - broadcast dims - 0(*k)&1234"; ed - broadcast dims - 0(*k)&1234";
ok all(approx(scalar($kv1_4->intersect_sorted($empty)), $kempty)), "intersect_ ok tapprox(scalar($kv1_4->intersect_sorted($empty)), $kempty), "intersect_sort
sorted - broadcast dims - 1234(*k)&0"; ed - broadcast dims - 1234(*k)&0";
ok all(approx(scalar($kempty->intersect_sorted($empty)), $kempty)), "intersect ok tapprox(scalar($kempty->intersect_sorted($empty)), $kempty), "intersect_sor
_sorted - broadcast dims - 0(*k)&0"; ted - broadcast dims - 0(*k)&0";
#-- setdiff_sorted #-- setdiff_sorted
ok all(approx(scalar($v1_2->setdiff_sorted($v3_4)), $v1_2)), "setdiff_sorted - ok tapprox(scalar($v1_2->setdiff_sorted($v3_4)), $v1_2), "setdiff_sorted - bro
broadcast dims - 12-34"; adcast dims - 12-34";
ok all(approx(scalar($v3_4->setdiff_sorted($v1_4)), $empty)), "setdiff_sorted ok tapprox(scalar($v3_4->setdiff_sorted($v1_4)), $empty), "setdiff_sorted - br
- broadcast dims - 34-1234"; oadcast dims - 34-1234";
ok all(approx(scalar($v1_4->setdiff_sorted($empty)), $v1_4)), "setdiff_sorted ok tapprox(scalar($v1_4->setdiff_sorted($empty)), $v1_4), "setdiff_sorted - br
- broadcast dims - 1234-0"; oadcast dims - 1234-0";
ok all(approx(scalar($empty->setdiff_sorted($v1_4)), $empty)), "setdiff_sorted ok tapprox(scalar($empty->setdiff_sorted($v1_4)), $empty), "setdiff_sorted - b
- broadcast dims - 0-1234"; roadcast dims - 0-1234";
ok all(approx(scalar($empty->setdiff_sorted($empty)), $empty)), "setdiff_sorte ok tapprox(scalar($empty->setdiff_sorted($empty)), $empty), "setdiff_sorted -
d - broadcast dims - 0-0"; broadcast dims - 0-0";
# #
ok all(approx(scalar($kv1_2->setdiff_sorted($v3_4)), $kv1_2)), "setdiff_sorted ok tapprox(scalar($kv1_2->setdiff_sorted($v3_4)), $kv1_2), "setdiff_sorted - b
- broadcast dims - 12(*k)-34"; roadcast dims - 12(*k)-34";
ok all(approx(scalar($kv3_4->setdiff_sorted($v1_4)), $kempty)), "setdiff_sorte ok tapprox(scalar($kv3_4->setdiff_sorted($v1_4)), $kempty), "setdiff_sorted -
d - broadcast dims - 34(*k)-1234"; broadcast dims - 34(*k)-1234";
ok all(approx(scalar($kv1_4->setdiff_sorted($empty)), $kv1_4)), "setdiff_sorte ok tapprox(scalar($kv1_4->setdiff_sorted($empty)), $kv1_4), "setdiff_sorted -
d - broadcast dims - 1234(*k)-0"; broadcast dims - 1234(*k)-0";
ok all(approx(scalar($kempty->setdiff_sorted($v1_4)), $kempty)), "setdiff_sort ok tapprox(scalar($kempty->setdiff_sorted($v1_4)), $kempty), "setdiff_sorted -
ed - broadcast dims - 0(*k)-1234"; broadcast dims - 0(*k)-1234";
ok all(approx(scalar($kempty->setdiff_sorted($empty)), $kempty)), "setdiff_sor ok tapprox(scalar($kempty->setdiff_sorted($empty)), $kempty), "setdiff_sorted
ted - broadcast dims - 0(*k)-0"; - broadcast dims - 0(*k)-0";
} }
broadcast dims - 0(*k)-0";
test_v_broadcast_dimensions(); test_v_broadcast_dimensions();
done_testing; done_testing;
 End of changes. 63 change blocks. 
275 lines changed or deleted 252 lines changed or added
To the Perl Test Programs section of the PDL source changes report or the top of this page
Mainly generated by pkgdiff using rfcdiff
Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)