diff --git a/Basic/Lib-Compression/t/basic.t b/Basic/Lib-Compression/t/basic.t index d908c02f2..df0e57df9 100755 --- a/Basic/Lib-Compression/t/basic.t +++ b/Basic/Lib-Compression/t/basic.t @@ -1,6 +1,7 @@ use strict; use warnings; use Test::More; +use Test::PDL; use PDL::LiteF; use PDL::Compression; use PDL::IO::FITS; @@ -11,17 +12,17 @@ my ($y, $xsize, undef, $len) = $m51->rice_compress; is $len->max->sclr, 373, 'right maximum length'; my $m51_2 = eval { $y->rice_expand($len, $xsize) }; if (is $@, '', 'no error') { -ok all(approx($m51, $m51_2)), 'decompress same as original'; +is_pdl $m51, $m51_2, 'decompress same as original'; } my $expected = pdl(byte, '[[126 122 122 128 128 124 124 128 128 128 127 126 126 127 127 128 124 124 123 123 122 122 121 121 120 120 119 119 118 118 117 117 118 118 117 116 115 114 113 113 116 115 115 114 114 113 112 112 111 111 110 110 110 110 110 110 109 109 110 110 110 111 111 111]]'); my $compressed_correct = pdl(byte, '[[126 48 24 0 96 48 14 179 32 54 219 109 147 85 96 91 91 126 206 112]]'); my $got = eval { $compressed_correct->rice_expand($compressed_correct->dim(0), 64) }; is $@, '', 'no error'; -ok all(approx($got, $expected)), 'decompress correct version gives right answer' or diag "got=${got}expected=$expected"; +is_pdl $got, $expected, 'decompress correct version gives right answer'; ($y, $xsize, undef, $len) = $expected->rice_compress(32); $got = eval { $y->rice_expand($len, $xsize) }; is $@, '', 'no error'; -ok all(approx($got, $expected)), 'decompress same as original (2)' or diag "got=${got}expected=$expected"; +is_pdl $got, $expected, 'decompress same as original (2)'; done_testing; diff --git a/Basic/Lib-ImageND/t/imagend.t b/Basic/Lib-ImageND/t/imagend.t index eea8b6652..af976500e 100644 --- a/Basic/Lib-ImageND/t/imagend.t +++ b/Basic/Lib-ImageND/t/imagend.t @@ -1,23 +1,20 @@ use strict; use warnings; use Test::More; +use Test::PDL; use PDL::LiteF; use PDL::ImageND; use PDL::NiceSlice; my $eps = 1e-15; -# Right answer { my $ans = pdl( [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27] ); - my $pa = xvals zeroes 10,3; - my $pb = pdl [1,2],[2,1]; - my $pc = convolve ($pa, $pb); - ok(all PDL::approx( $pc, $ans, $eps ) ); + is_pdl convolve(xvals(10,3), pdl([1,2],[2,1])), $ans; } my $pa = zeroes(6,6); @@ -37,10 +34,8 @@ my $pb = pdl( [-1,0],[0,1] ); [ 1, 0, 0, -1, 0, 0], [ 0, 0, 0, -1, 0, 0] ); - my $pc = convolveND($pa,$pb,{m=>'d',b=>'e'}); - ok( all PDL::approx($pc,$ans_e, $eps) ) or diag $pc; - $pc = convolveND($pa,$pb,{m=>'f',b=>'e'}); - ok( all PDL::approx($pc,$ans_e, $eps) ) or diag $pc; + is_pdl convolveND($pa,$pb,{m=>'d',b=>'e'}),$ans_e; + is_pdl convolveND($pa,$pb,{m=>'f',b=>'e'}),$ans_e; } { @@ -52,14 +47,11 @@ my $pb = pdl( [-1,0],[0,1] ); [ 1, 0, 0, -1, 0, 1], [ 0, -1, 0, -1, 0, 1] ); - my $pc = convolveND($pa,$pb,{m=>'d',b=>'p'}); - ok( all( PDL::approx($pc, $ans_p, $eps) ) ); - $pc = convolveND($pa,$pb,{m=>'f',b=>'p'}); - ok(all PDL::approx($pc, $ans_p, $eps) ); + is_pdl convolveND($pa,$pb,{m=>'d',b=>'p'}), $ans_p; + is_pdl convolveND($pa,$pb,{m=>'f',b=>'p'}), $ans_p; } { - my $pc; my $ans_t = pdl( [ 0, 0, 1, -1, 0, 1], [-1, 0, 0, -1, 0, 1], @@ -68,30 +60,17 @@ my $pb = pdl( [-1,0],[0,1] ); [ 1, 0, 0, -1, 0, 1], [ 0, 0, 0, 0, 1, 1] ); - $pc = convolveND($pa,$pb,{m=>'d',b=>'t'}); - ok(all PDL::approx($pc,$ans_t, $eps) ); - - $pc = convolveND($pa,$pb,{m=>'f',b=>'t'}); - ok( all( PDL::approx($pc, $ans_t, $eps) ) ); + is_pdl convolveND($pa,$pb,{m=>'d',b=>'t'}), $ans_t; + is_pdl convolveND($pa,$pb,{m=>'f',b=>'t'}), $ans_t; } { - my $pa = sequence(6,6); my $ans = pdl([14,22,30],[62,70,78],[110,118,126]); - ok( all( $ans==rebin($pa,3,3,{Norm=>1}) ) ); -} - -{ -my $got = circ_mean_p(sequence(8,8)); -my $expected = pdl('[36 36 36 36 23.14285 14.4]'); -ok all approx($got, $expected, 1e-3) or diag "got: $got\nexp: $expected"; + is_pdl rebin(sequence(6,6),3,3,{Norm=>1}), $ans; } -{ -my $got = circ_mean(sequence(2,2)); -my $expected = pdl('[[1 1][1 3]]'); -ok all approx($got, $expected, 1e-3) or diag "got: $got\nexp: $expected"; -} +is_pdl circ_mean_p(sequence(8,8)), pdl('[36 36 36 36 23.14285 14.4]'); +is_pdl circ_mean(sequence(2,2)), pdl('[[1 1][1 3]]'); { # cut down from demo 3d @@ -101,9 +80,8 @@ my $y = yvals($size+1,$size+1) / $size; my $z = 0.5 + 0.5 * (sin($x*6.3) * sin($y*6.3)) ** 3; my $cvals = pdl q[0.203 0.276]; my $points = cat($x,$y,$z)->mv(-1,0); -my ($segs, $cnt) = contour_segments($cvals, $z, $points); -$segs = $segs->slice(',0:'.$cnt->max); -ok all(approx $cnt, pdl(15,15), 2), 'contour_segments' or diag $segs, $cnt; +my (undef, $cnt) = contour_segments($cvals, $z, $points); +is_pdl $cnt, indx(15,15), {atol=>2, test_name=>'contour_segments'}; $z = pdl q[ 0 0 0 0 0; @@ -114,19 +92,18 @@ $z = pdl q[ ]; (my $got, $cnt) = contour_segments(0.5, $z, my $coords = $z->ndcoords); $got = $got->slice(',0:'.$cnt->max)->uniqvec; -my $exp = pdl q[ +my $exp = float q[ [0.5 2] [0.5 3] [ 1 1.5] [ 1 3.5] [1.5 1] [1.5 2] [ 2 0.5] [ 2 1.5] [ 2 2.5] [ 2 3.5] [2.5 1] [2.5 2] [ 3 1.5] [ 3 3.5] [3.5 2] [3.5 3] ]; -ok all(approx $got, $exp, 0.1), 'contour_segments' or diag $got, $exp; +is_pdl $got, $exp, {atol=>0.1, test_name=>'contour_segments'}; my ($pi, $p) = contour_polylines(0.5, $z, $coords); my $pi_max = $pi->max; $p = $p->slice(','.($pi_max < 0 ? '1:0:1' : "0:$pi_max"))->uniqvec; -is $p->dim(1), $exp->dim(1), 'same size' or diag "got=$p\nexp=$exp"; -ok all(approx $p, $exp, 0.1), 'contour_polylines' or diag "got=$p"; +is_pdl $p, $exp, {atol=>0.1, test_name=>'contour_polylines'}; } for ( @@ -144,9 +121,7 @@ for ( { my ($pi, $p) = map pdl($_), '[4 6 8 -1 -1 -1]', '[0 1 2 3 1 2 3 4 5 -1 -1 -1]'; - my @segs = path_segs($pi, $p); - $_ = "$_" for @segs; - is_deeply \@segs, ['[0 1 2 3 1]', '[2 3]', '[4 5]']; + is_deeply [map "$_", path_segs($pi, $p)], ['[0 1 2 3 1]', '[2 3]', '[4 5]']; } done_testing; diff --git a/Basic/Lib-ImageRGB/t/imagergb.t b/Basic/Lib-ImageRGB/t/imagergb.t index a756cae09..10f8a3701 100644 --- a/Basic/Lib-ImageRGB/t/imagergb.t +++ b/Basic/Lib-ImageRGB/t/imagergb.t @@ -1,64 +1,21 @@ use strict; use warnings; use Test::More; +use Test::PDL; use PDL::LiteF; use PDL::ImageRGB; use PDL::Dbg; -sub vars_ipv { - PDL::Dbg::vars() if $PDL::debug; -} - -sub p { - print @_ if $PDL::debug; -} - -$PDL::debug = 0; - -vars_ipv; - -{ - my $im = float [1,2,3,4,5]; - my $out = bytescl($im,100); - ok(all approx($im,$out)); - cmp_ok($out->get_datatype, '==', $PDL::Types::PDL_B); -} - -{ - my $im = float [1,2,3,4,5]; - my $out = bytescl($im,-100); - ok(all approx(pdl([0,25,50,75,100]),$out)); - p "$out\n"; -} - -{ - my $rgb = double [[1,1,1],[1,0.5,0.7],[0.1,0.2,0.1]]; - my $out = rgbtogr($rgb); - ok(all approx($out,pdl([1,0.67,0.16]), 0.01)); - cmp_ok($out->get_datatype, '==', $PDL::Types::PDL_D); - vars_ipv; - p $out; -} +is_pdl bytescl(float(1..5),100), byte(1..5); +is_pdl bytescl(float(1,2,3,4,5),-100), byte([0,25,50,75,100]); +is_pdl rgbtogr(pdl([1,1,1],[1,0.5,0.7],[0.1,0.2,0.1])), pdl([1,0.67,0.16]), {atol=>1e-2}; { - my $im = byte [[1,2,3],[0,3,0]]; - my $lut = byte [[0,0,0], - [10,1,10], - [2,20,20], - [30,30,3] - ]; - # do the interlacing the lengthy way - my $interl = zeroes(byte,3,$im->dims); - for my $i (0..($im->dims)[0]-1) { - for my $j (0..($im->dims)[1]-1) { - my $pos = $im->at($i,$j); - (my $tmp = $interl->slice(":,($i),($j)")) .= $lut->slice(":,($pos)"); - } - } - my $out = interlrgb($im,$lut); - vars_ipv; - p $out; - ok(all approx($out,$interl)); + my $im = byte('1 2 3;0 3 0'); + my $lut = byte('0 0 0;10 1 10;2 20 20;30 30 3'); + # also works: $lut->indexND(sequence(1,3)->append($im->slice('*1,*3'))) + my $interl = byte('[10 1 10;2 20 20;30 30 3] [0 0 0;30 30 3;0 0 0]'); + is_pdl interlrgb($im,$lut),$interl; } done_testing; diff --git a/Basic/Lib-Transform/t/transform.t b/Basic/Lib-Transform/t/transform.t index 502992a3e..6b91fb82f 100644 --- a/Basic/Lib-Transform/t/transform.t +++ b/Basic/Lib-Transform/t/transform.t @@ -4,6 +4,7 @@ use PDL::LiteF; use PDL::Transform; use PDL::Transform::Cartography; # raster2fits helps limit mem consumption use Test::More; +use Test::PDL; use Test::Exception; { @@ -11,33 +12,19 @@ use Test::Exception; ############################## # Test basic transformation my $t = t_linear(scale=>[2]); - ok( $t->{idim} == 1 && $t->{odim} == 1, "t_linear can make a 1-d transform" ); + is_deeply [@$t{qw(idim odim)}],[1,1], "t_linear can make a 1-d transform"; my $pa = sequence(2,2)+1; - my $pb = $pa->apply($t); - - ok( all( approx( $pb, pdl( [2, 2], [6, 4] ) )), "1-d apply on a collection of vectors ignors higher dim"); + is_pdl $pa->apply($t), pdl( [2, 2], [6, 4] ), "1-d apply on a collection of vectors ignors higher dim"; my $t2 = t_linear(scale=>[2,3]); - - ok( $t2->{idim} == 2 && $t2->{odim} == 2, "t_linear can make a 2-d transform" ); - - $pb = $pa->apply($t2); - - ok( all( approx( $pb, pdl( [2, 6], [6, 12] ) )), "2-d apply treats the higher dim"); - - $pb = pdl(2,3)->invert($t2); - ok( all( approx($pb, 1) ), "invert works"); + is_deeply [@$t2{qw(idim odim)}],[2,2], "t_linear can make a 2-d transform"; + is_pdl $pa->apply($t2), pdl( [2, 6], [6, 12] ), "2-d apply treats the higher dim"; + is_pdl pdl(2,3)->invert($t2), pdl(1,1), "invert works"; my $t3 = t_rot([45,45,45]); - $pa = PDL::MatrixOps::identity(3); - my $got = $pa->apply($t3); - ok all(approx $got, pdl(<<'EOF'), 1e-4), 't_rot works' or diag 'got=', $got; -[ -[ 0.5 -0.14644661 0.85355339] -[ 0.5 0.85355339 -0.14644661] -[-0.70710678 0.5 0.5] -] + is_pdl PDL::MatrixOps::identity(3)->apply($t3), pdl(<<'EOF'), 't_rot works'; +0.5 -0.14644661 0.85355339; 0.5 0.85355339 -0.14644661; -0.70710678 0.5 0.5 EOF my $t4 = t_linear(scale=>[2], idim=>2, odim=>2, iunit=>[('metres')x2], ounit=>[('radii')x2]); isnt $t4->{$_}, undef, "$_ in object" for qw(idim odim iunit ounit); @@ -49,80 +36,55 @@ EOF { ############################## # Simple testing of the map autoscaling - my $pa = sequence(5,5); - { - # Identity transformation should be an expensive no-op - # (autoscaled correctly) - my $pb = $pa->map(t_identity()); - ok( all($pa==$pb) ); - } + # Identity transformation should be an expensive no-op + # (autoscaled correctly) + is_pdl $pa->map(t_identity()), $pa; - { - # Identity transformation on pixels should be a slightly less expensive - # no-op (no autoscaling) - my $pb = $pa->map(t_identity,{pix=>1}); - ok( all($pa==$pb) ); - } + # Identity transformation on pixels should be a slightly less expensive + # no-op (no autoscaling) + is_pdl $pa->map(t_identity,{pix=>1}), $pa; - { - # Scaling by 2 and then autoscaling should be an expensive no-op - # (scaled, then autoscaled back down) - my $pb = $pa->map(t_scale(2)); - ok( all($pa==$pb) ); - } + # Scaling by 2 and then autoscaling should be an expensive no-op + # (scaled, then autoscaled back down) + is_pdl $pa->map(t_scale(2)), $pa; - { - # Scaling by 2 in pixel coordinates should actually scale the image - my $pb = $pa->map(t_scale(2),{pix=>1}); - ok(all($pb == $pa*0.5)); - } + # Scaling by 2 in pixel coordinates should actually scale the image + is_pdl $pa->map(t_scale(2),{pix=>1}), $pa*0.5; } -{ - ############################## - # diab jerius' t_scale crash - # (this is due to a problem with inplace flag handling in PDL <= 2.6; transform works around it) - - lives_ok { - my $pa = pdl(49,49); - my $t = t_linear({scale=>pdl([1,3]), offset=>pdl([12,8])}); - my $pb = pdl( double, 2.2, 9.3); - $pa->inplace->apply($t); - my $q = 0; - $pa += $q; - }; -} +############################## +# diab jerius' t_scale crash +# (this is due to a problem with inplace flag handling in PDL <= 2.6; transform works around it) +lives_ok { + my $pa = pdl(49,49); + my $t = t_linear({scale=>pdl([1,3]), offset=>pdl([12,8])}); + my $pb = pdl( double, 2.2, 9.3); + $pa->inplace->apply($t); + my $q = 0; + $pa += $q; +}; ############################## # bad value handling... { my $pa = sequence(5,5); - no warnings; my $t1 = t_linear(pre=>[1.5,2]); my $t2 = t_linear(pre=>[1,2]); - use warnings; $pa->badflag(1); - my $pb; - lives_ok { $pb = $pa->map($t1,{pix=>1,method=>'l'}) }; - ok(($pb->slice("0:1")->isbad->all and $pb->slice(":,0:1")->isbad->all and ($pb->isbad->sum==16)), "Bad values happen"); - eval { $pb = $pa->map($t1,{pix=>1,method=>'h'}) }; - ok(($pb->slice("0")->isbad->all and $pb->slice(":,0:1")->isbad->all and $pb->isbad->sum==13), "Bad values happen with 'h' method") or diag "got: $pb"; + my $exp = pdl 'BAD BAD BAD BAD BAD; BAD BAD BAD BAD BAD; BAD BAD 0.5 1.5 2.5; BAD BAD 5.5 6.5 7.5; BAD BAD 10.5 11.5 12.5'; + is_pdl $pa->map($t1,{pix=>1,method=>'l'}), $exp, "Bad values happen"; + my $exp2 = pdl 'BAD BAD BAD BAD BAD; BAD BAD BAD BAD BAD; BAD 0 0.5 1.5 2.5; BAD 5 5.5 6.5 7.5; BAD 10 10.5 11.5 12.5'; + is_pdl $pa->map($t1,{pix=>1,method=>'h'}), $exp2, "Bad values happen with 'h' method"; } { use PDL::IO::FITS; my $m51 = raster2fits(sequence(long, 10, 10), @PDL::Transform::Cartography::PLATE_CARREE); - my $m51map = $m51->map(t_identity,{method=>'s'}); #SHOULD be a no-op - ok(all($m51==$m51map)); - - $m51map = $m51->map(t_identity, $m51->hdr,{method=>'s'}); #SHOULD be a no-op - ok(all($m51==$m51map), 'map works with FITS hashref'); - - my $m51_coords = pdl(0,0)->apply(t_fits($m51)); - my $m51map_coords = pdl(0,0)->apply(t_fits($m51map)); - ok(all(approx($m51_coords, $m51map_coords,1e-8))); + is_pdl $m51->map(t_identity,{method=>'s'}), $m51; #SHOULD be a no-op + is_pdl my $m51map = $m51->map(t_identity, $m51->hdr,{method=>'s'}), $m51, 'map works with FITS hashref'; + is_pdl pdl(0,0)->apply(t_fits($m51)), pdl(0,0)->apply(t_fits($m51map)); } ######################################## @@ -136,61 +98,44 @@ EOF my $pa = rvals(7,7) == 0; - { - my $pb = $pa->match($pa,{method=>'s'}); - ok(all($pa==$pb),"self-match with 's' method is a no-op"); - } - - { - my $pb = $pa->match($pa,{method=>'l'}); - ok(all(approx($pa,$pb)),"self-match with 'l' method is an approximate no-op"); - } + is_pdl $pa->match($pa,{method=>'s'}), $pa, "self-match with 's' method is a no-op"; + is_pdl $pa->match($pa,{method=>'l'}), $pa, "self-match with 'l' method is an approximate no-op"; + is_pdl $pa->match($pa,{method=>'h'}), $pa, "self-match with hanning method is an approximate no-op"; { - my $pb = $pa->match($pa,{method=>'h'}); - ok(all(approx($pa,$pb)),"self-match with hanning method is an approximate no-op"); - } - - { - my $pb = $pa->match($pa,{method=>'h',blur=>2}); my $b0 = zeroes($pa); $b0->slice([2,4],[2,4]) .= pdl([[0.0625,0.125,0.0625],[0.125,0.25,0.125],[0.0625,0.125,0.0625]]); - ok(all(approx($pb,$b0)),"self-match with hanning method and blur of 2 blurs right"); + is_pdl $pa->match($pa,{method=>'h',blur=>2}), $b0, "self-match with hanning method and blur of 2 blurs right"; } { my $pb = $pa->match($pa,{method=>'g'}); my $b0 = zeroes($pa)-9; my $bc = pdl([-9,-3.3658615,-2.7638017],[-3.3658615,-1.5608028,-0.95874296],[-2.7638017,-0.95874296,-0.35668313]); - #$bc = pdl([-9,-9,-2.762678-4.4e-8],[-9,-1.5593078,-0.95724797],[-2.762678-4.4e-8,-0.95724797,-0.35518814]); - $b0->slice([1,3],[1,3]) .= $bc; $b0->slice([5,3],[1,3]) .= $bc; $b0->slice([1,5],[5,4]) .= $b0->slice([1,5],[1,2]); - ok(all(approx($pb->clip(1e-9)->log10,$b0,1e-7)),"self-match with Gaussian method gives understood blur"); + is_pdl $pb->clip(1e-9)->log10, $b0, "self-match with Gaussian method gives understood blur"; } { my $t = t_linear(pre=>[0.5,1]); { my $pb = $pa->map($t,{method=>'s',pix=>1}); - my $wndb = $pb->whichND; - ok(all($wndb==pdl([[3,4]])),'right boolean') or diag $wndb; - ok(approx($pb->slice(3,4),1),'offset with sample is a simple offset') or diag $pb; + is_pdl scalar $pb->whichND, indx([[3,4]]),'right boolean'; + is_pdl $pb->slice(3,4), pdl([[1]]), 'offset with sample is a simple offset'; } { my $pb = $pa->map($t,{method=>'l',pix=>1}); - my $wndb = $pb->whichND; - ok(all($wndb==pdl([[3,4],[4,4]])),'right boolean') or diag $wndb; - ok(all(approx($pb->slice([3,4],4),0.5)),'offset with linear interpolation does the right thing') or diag $pb; + is_pdl scalar $pb->whichND, indx([[3,4],[4,4]]),'right boolean'; + is_pdl $pb->slice([3,4],4), pdl([[0.5,0.5]]), 'offset with linear interpolation does the right thing'; } { my $pb = $pa->map($t,{method=>'h',pix=>1}); - my $wndb = $pb->whichND; - ok(all($wndb==pdl([[3,4],[4,4]])),'right boolean') or diag $wndb; - ok(all(approx($pb->slice([3,4],4),0.5)),'offset with hanning interpolation does the right thing') or diag $pb; + is_pdl scalar $pb->whichND, indx([[3,4],[4,4]]), 'right boolean'; + is_pdl $pb->slice([3,4],4), pdl([[0.5,0.5]]), 'offset with hanning interpolation does the right thing'; } } @@ -219,7 +164,6 @@ is earth_coast()->nbad, 0, 'earth_coast no BAD'; my $in = pdl '[178.5 63.1 NaN; NaN NaN 0; 178.5 63.1 1; 179 63.2 1; 179.6 63.3 1; -179.8 65 1; -179.5 65.1 0]'; my $exp = pdl '[178.5 63.1 0; 1000 1000 0; 178.5 63.1 1; 179 63.2 1; 179.6 63.3 0; -179.8 65 1; -179.5 65.1 0]'; -my $got; my @cl_tests = ( [sub {clean_lines($in,{fn=>0})}, 'l'], [sub {clean_lines((map $in->slice($_), qw(0:1 (2))),{fn=>0})}, 'l p'], @@ -231,17 +175,17 @@ for (['', sub {}], ["broadcast ", sub { }]) { my ($prefix, $mod) = @$_; $mod->(); - ok all(approx $got=$_->[0]()->setnantobad->setbadtoval(1000), $exp), "${prefix}scalar $_->[1]" or diag "got=$got\nexp=".$exp for @cl_tests; - ok all(approx $got=($_->[0]())[0]->setnantobad->setbadtoval(1000), $exp->slice('0:1')), "${prefix}listl $_->[1]" or diag "got=$got\nexp=".$exp->slice('0:1') for @cl_tests; - ok all(approx $got=($_->[0]())[1]->setnantobad->setbadtoval(1000), $exp->slice('(2)')), "${prefix}listp $_->[1]" or diag "got=$got\nexp=".$exp->slice('(2)') for @cl_tests; + is_pdl $_->[0]()->setnantobad->setbadtoval(1000), $exp, "${prefix}scalar $_->[1]" for @cl_tests; + is_pdl +($_->[0]())[0]->setnantobad->setbadtoval(1000), $exp->slice('0:1'), "${prefix}listl $_->[1]" for @cl_tests; + is_pdl +($_->[0]())[1]->setnantobad->setbadtoval(1000), $exp->slice('(2)'), "${prefix}listp $_->[1]" for @cl_tests; } $in = pdl '[178.5 63.1 1; 179 62 1; 178.8 63.1 1; 179 64.2 1; 179.2 63.7 1; 179.3 65 1; 179.4 63 1; 179.6 63.3 1; 179.8 65 1; 179.5 65.3 0]'; $exp = pdl '[179 64.2 1; 179.2 63.7 0; 179.4 63 1; 179.6 63.3 0]'; my $or = [[178.9,179.7], [62.8,64.5]]; -ok all(approx $got=$in->clean_lines(1.1,{or=>$or}), $exp), "scalar orange" or diag "got=$got\nexp=".$exp; +is_pdl scalar $in->clean_lines(1.1,{or=>$or}), $exp, "scalar orange"; $in = pdl '[178.5 63.1 1; NaN NaN 0; 178.5 63.1 1; 179 63.2 0]'; $exp = pdl '[178.5 63.1 0; 178.5 63.1 1; 179 63.2 0]'; -ok all(approx $got=$in->clean_lines(1.1), $exp), "with filter_nan (default)" or diag "got=$got\nexp=".$exp; +is_pdl scalar $in->clean_lines(1.1), $exp, "with filter_nan (default)"; } { @@ -251,22 +195,30 @@ my $pa = sequence(5,5); { my $pb = $pa->match([10,10],{pix=>1,method=>'s'}); -ok( all($pb->slice([0,4],[0,4])==$pa) && all($pb->slice([5,9])==0) && all($pb->slice('x',[5,9])==0), "truncation boundary condition works"); +is_pdl $pb->slice([0,4],[0,4]), $pa; +is_pdl $pb->slice([5,9]), zeroes(5,10); +is_pdl $pb->slice('x',[5,9]), zeroes(10,5), "truncation boundary condition works"; } { my $pb = $pa->match([10,10],{pix=>1,method=>'h'}); -ok( all($pb->slice([0,4],[0,4])==$pa) && all($pb->slice([5,9])==0) && all($pb->slice('x',[5,9])==0), "truncation boundary condition works for jacobian methods"); +is_pdl $pb->slice([0,4],[0,4]), $pa; +is_pdl $pb->slice([5,9]), zeroes(5,10); +is_pdl $pb->slice('x',[5,9]), zeroes(10,5), "truncation boundary condition works for jacobian methods"; } { my $pb = $pa->match([10,10],{pix=>1,method=>'s',bound=>'mp'}); -ok( all($pb->slice([0,4],[0,4])==$pa) && all($pb->slice([9,5])==$pb->slice([0,4])) && all($pb->slice('x',[5,9])==$pb->slice('x',[0,4])), "periodic and mirror boundary conditions work"); +is_pdl $pb->slice([0,4],[0,4]), $pa; +is_pdl $pb->slice([9,5]), $pb->slice([0,4]); +is_pdl $pb->slice('x',[5,9]), $pb->slice('x',[0,4]), "periodic and mirror boundary conditions work"; } { my $pb = $pa->match([10,10],{pix=>1,method=>'h',bound=>'mp'}); -ok( all($pb->slice([0,4],[0,4])==$pa) && all($pb->slice([9,5])==$pb->slice([0,4])) && all($pb->slice('x',[5,9])==$pb->slice('x',[0,4])), "periodic and mirror boundary conditions work for jacobian methods"); +is_pdl $pb->slice([0,4],[0,4]), $pa; +is_pdl $pb->slice([9,5]), $pb->slice([0,4]); +is_pdl $pb->slice('x',[5,9]), $pb->slice('x',[0,4]), "periodic and mirror boundary conditions work for jacobian methods"; } }