use PDL;
print "1..21\n";
my $got = 0;
eval{require PDL::Slatec;};
if(!$@) {$got = 1}
if($got) {
eval{require PDL::Graphics::Limits;};
if($@) {$got = 0}
}
unless($got) {
for(1..21){print "ok $_ - skipped\n"}
exit;
}
*normalize_dsets = \&PDL::Graphics::Limits::normalize_dsets;
*parse_vecspecs = \&PDL::Graphics::Limits::parse_vecspecs;
# temporarily disable warnings to turn off Perl's
# redefinition warning
my $oldw;
BEGIN {
$oldw = $^W;
$^W=0;
}
# so can use _eq_array w/ piddles.
{
package PDL;
use overload 'eq' => \&PDL::eq,
'bool' => sub { $_[0]->and } ;
}
BEGIN {
$^W=$oldw;
}
$x1 = pdl( 1, 2 );
$y1 = pdl( 1, 2 );
$xn = pdl( 0.5, 0.5 );
$xp = pdl( 0.25, 0.25 );
$x2 = pdl( 2, 3 );
$y2 = pdl( 2, 4 );
my %errs = ( en => undef, ep => undef );
%attr = ( KeyCroak => 1 );
@rdsets = (
{ MinMax => [ [ '', ''],
[ '', '']
],
Vectors => [ { data => $x1 },
{
data => $y1 }
]
},
{ MinMax => [ [ '', ''],
[ '', '']
],
Vectors => [ { data => $x2 },
{
data => $y2 }
]
},
);
@udsets = ( [ $x1, $y1 ],
[ $x2, $y2 ] );
@dsets = normalize_dsets( { %attr }, @udsets );
%d1 = %{$dsets[0]};
for (keys(%d1)) {
print "1: $_: $d1{$_}\n";
my @d1 = @{$d1{$_}};
print " @d1\n";
}
%d2 = %{$dsets[1]};
for (keys(%d2)) {
print "2: $_: $d2{$_}\n";
my @d2 = @{$d2{$_}};
print " @d2\n";
}
_ok( _eq_array( \@dsets, \@rdsets ), 1, "array" );
my $args = { %attr, KeySpec => [ { data => 'x' }, { data => 'y' }, ] };
@udsets = ( [ { x => $x1, y => $y1 },
{ x => $x2, y => $y2 } ] );
@dsets = normalize_dsets( $args, @udsets );
_ok( _eq_array( \@dsets, \@rdsets ), 2, "hash" );
@udsets = ( [ { x => $x1, y => $y1 },
{ x => $x2, y => $y2, z => 0 } ] );
@dsets = normalize_dsets( $args, @udsets );
_ok( _eq_array( \@dsets, \@rdsets ), 3, "hash, extra data" );
@udsets = ( [ $x1, $y1 ],
[ { x => $x2, y => $y2 } ] );
@dsets = normalize_dsets( $args, @udsets );
_ok( _eq_array( \@dsets, \@rdsets ), 4, "array and hash" );
#############################################################
@udsets = ( $x1, $y1, [ { x => $x2, y => $y2 } ] );
eval {
@dsets = normalize_dsets( $args,, @udsets );
};
_ok( $@ =~ /same dimensionality/, 5, "dimensions not equal" );
@udsets = ( [ $x1, $y1 ], [ $x1, { x => $x2, y => $y2 } ] );
eval {@dsets = normalize_dsets( $args, @udsets ); };
_ok( $@ =~ /unexpected data type/, 6, "bad arg mix" );
@udsets = ( [ $x1, $y1 ], [ { x => $x2, y => $y2 } ] );
eval {
@dsets = normalize_dsets( $args, @udsets );
};
_ok( !$@, 7, "array hash combo" );
#############################################################
@udsets = ( [ $x1, $y1 ] );
@dsets = normalize_dsets( { %attr, Trans => [ \&log ] }, @udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 8, "array: global x trans" );
@udsets = ( [ [ $x1, \&log ], $y1 ] );
@dsets = normalize_dsets( { %attr }, @udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 9, "array: local x trans" );
@udsets = ( [ [ $x1, \&log ], $y1 ] );
@dsets = normalize_dsets( { %attr, Trans => [ \&sin ]}, @udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 10, "array: local override x trans" );
@udsets = ( [ [ $x1, undef, undef, undef ], $y1 ] );
@dsets = normalize_dsets( { %attr, Trans => [ \&sin ]}, @udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1 },
{ data => $y1 },
]
), 11, "array: local undef x trans" );
#############################################################
$keys = [ qw( x y ) ];
%keys = ( KeySpec => parse_vecspecs( $keys ) );
$udsets = [ { x => $x1, y => $y1 } ];
@dsets = normalize_dsets( { %attr, %keys, Trans => [ \&log ] }, $udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 12, "hash: global x trans" );
$udsets = [ { x => $x1, trans => \&log , y => $y1 } => ( '&trans' ) ];
@dsets = normalize_dsets( { %attr, %keys }, $udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 13, "hash: local x trans 1" );
$udsets = [ { x => $x1, trans => \&log , y => $y1 } => qw( x&trans y ) ];
@dsets = normalize_dsets( { %attr, KeySpec => [] }, $udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 14, "hash: local x trans 2" );
$udsets = [ { x => $x1, trans => \&log , y => $y1 } => qw( x&trans y ) ];
@dsets = normalize_dsets( { %attr, KeySpec => [], Trans => [\&sin] }, $udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1, trans => \&log },
{ data => $y1 },
]
), 15, "hash: local override x trans" );
$udsets = [ { x => $x1, trans => undef , y => $y1 } => qw( x&trans y ) ];
@dsets = normalize_dsets( { %attr, KeySpec => [], Trans => [\&sin] }, $udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1 },
{ data => $y1 },
]
), 16, "hash: local undef x trans 1" );
$udsets = [ { x => $x1, y => $y1 } => qw( x& y ) ];
@dsets = normalize_dsets( { %attr, KeySpec => [], Trans => [\&sin] }, $udsets );
_ok( _eq_array( $dsets[0]{Vectors}, [
{ data => $x1 },
{ data => $y1 },
]
), 17, "hash: local undef x trans 2" );
#############################################################
@udsets = ( [ [ $x1, $xn ], $y2 ] );
@dsets = normalize_dsets( { %attr }, @udsets );
$exp = [ { data => $x1, errn => $xn, errp => $xn }, { data => $y2, } ];
_ok( _eq_array( $dsets[0]{Vectors}, $exp), 18, "array: symmetric errors" );
@udsets = ( [ [ $x1, $xn, $xp ], $y2 ] );
@dsets = normalize_dsets( { %attr }, @udsets );
$exp = [ { data => $x1, errn => $xn, errp => $xp }, { data => $y2, } ];
_ok( _eq_array( $dsets[0]{Vectors}, $exp), 19, "array: asymmetric errors 1" );
@udsets = ( [ [ $x1, undef, $xp ], $y2 ] );
@dsets = normalize_dsets( { %attr }, @udsets );
$exp = [ { data => $x1, errp => $xp }, { data => $y2, } ];
_ok( _eq_array( $dsets[0]{Vectors}, $exp), 20, "array: asymmetric errors 2" );
@udsets = ( [ [ $x1, $xn, undef ], $y2 ] );
@dsets = normalize_dsets( { %attr }, @udsets );
$exp = [ { data => $x1, errn => $xn }, { data => $y2, } ];
_ok( _eq_array( $dsets[0]{Vectors}, $exp), 21, "array: asymmetric errors 3" );
##############################################
##############################################
sub _ok {
if($_[0]) {print "ok $_[1] - $_[2]\n"}
else {print "not ok $_[1] - $_[2]\n"}
}
############################################
sub __deep_check {
my($e1, $e2) = @_;
my $ok = 0;
my $eq;
{
# Quiet uninitialized value warnings when comparing undefs.
no warnings;
if( $e1 eq $e2 ) {
$ok = 1;
}
else {
if( UNIVERSAL::isa($e1, 'ARRAY') and
UNIVERSAL::isa($e2, 'ARRAY') )
{
$ok = _eq_array($e1, $e2);
}
elsif( UNIVERSAL::isa($e1, 'HASH') and
UNIVERSAL::isa($e2, 'HASH') )
{
$ok = _eq_hash($e1, $e2);
}
elsif( UNIVERSAL::isa($e1, 'REF') and
UNIVERSAL::isa($e2, 'REF') )
{
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = __deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
elsif( UNIVERSAL::isa($e1, 'SCALAR') and
UNIVERSAL::isa($e2, 'SCALAR') )
{
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = __deep_check($$e1, $$e2);
}
else {
push @Data_Stack, { vals => [$e1, $e2] };
$ok = 0;
}
}
}
return $ok;
}
############################################
sub _eq_array {
my($a1, $a2) = @_;
return 1 if $a1 eq $a2;
my $ok = 1;
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
for (0..$max) {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
$ok = __deep_check($e1,$e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
#############################################
sub _eq_hash {
my($a1, $a2) = @_;
return 1 if $a1 eq $a2;
my $ok = 1;
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
foreach my $k (keys %$bigger) {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
$ok = __deep_check($e1, $e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}