Skip to content

Commit

Permalink
Basic/Lib* tests replace approx with is_pdl - #34
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed Nov 1, 2024
1 parent 157f740 commit fcb3cb0
Show file tree
Hide file tree
Showing 4 changed files with 95 additions and 210 deletions.
7 changes: 4 additions & 3 deletions Basic/Lib-Compression/t/basic.t
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
use strict;
use warnings;
use Test::More;
use Test::PDL;
use PDL::LiteF;
use PDL::Compression;
use PDL::IO::FITS;
Expand All @@ -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;
59 changes: 17 additions & 42 deletions Basic/Lib-ImageND/t/imagend.t
View file
Original file line number Diff line number Diff line change
@@ -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);
Expand All @@ -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;
}

{
Expand All @@ -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],
Expand All @@ -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
Expand All @@ -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;
Expand All @@ -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 (
Expand All @@ -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;
61 changes: 9 additions & 52 deletions Basic/Lib-ImageRGB/t/imagergb.t
View file
Original file line number Diff line number Diff line change
@@ -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;
Loading

0 comments on commit fcb3cb0

Please sign in to comment.