File Coverage

blib/lib/Test/PDL.pm

Criterion	Covered	Total	%
statement	93	150	62.0
branch	41	48	85.4
condition	17	17	100.0
subroutine	30	31	96.7
pod	5	5	100.0
total	186	251	74.1

package Test::PDL;
$Test::PDL::VERSION = '0.12';
# ABSTRACT: Test Perl Data Language arrays (a.k.a. piddles) for equality


use strict;
use warnings;
use PDL::Lite;
use PDL::Types ();

use base qw( Exporter );
our @EXPORT = qw( is_pdl );
our @EXPORT_OK = qw( eq_pdl eq_pdl_diag is_pdl test_pdl );
our %EXPORT_TAGS = ( deep => [ qw( test_pdl ) ] );


our %OPTIONS = (
	TOLERANCE   => 1e-6,
	EQUAL_TYPES => 1,
);


sub import
{
	my $i = 0;
	while( $i < @_ ) {
		if( $_[ $i ] =~ /^-/ ) {
			my( $key, $val ) = splice @_, $i, 2;
			$key =~ s/^-(.*)/\U$1/;
			set_options( $key, $val );
		}
		else { $i++ }
	}
	__PACKAGE__->export_to_level( 1, @_ );
}


sub _approx
{
	my( $a, $b ) = @_;
	return abs( $a - $b ) < $OPTIONS{ TOLERANCE };
}


sub _comparison_fails
{
	my ( $got, $expected ) = @_;
	if( not eval { $got->isa('PDL') } ) {
		return 'received value is not a piddle';
	}
	if( not eval { $expected->isa('PDL') } ) {
		return 'expected value is not a piddle';
	}
	if( $OPTIONS{ EQUAL_TYPES } && $got->type != $expected->type ) {
		return 'types do not match (EQUAL_TYPES is true)';
	}
	if( $got->ndims != $expected->ndims ) {
		return 'dimensions do not match in number';
	}
	if( not _dimensions_match( [$got->dims], [$expected->dims] ) ) {
		return 'dimensions do not match in extent';
	}
	# evaluating these only makes sense for piddles that conform in shape
	if( ( $got->badflag == 1 || $expected->badflag == 1 ) &&
		not eval { PDL::all( PDL::isbad($got) == PDL::isbad($expected) ) } ) {
		return 'bad value patterns do not match';
	}
	# if we get here, bad value patterns are sure to match
	if( $got->type < PDL::float && $expected->type < PDL::float ) {
		if( not eval { PDL::all( $got == $expected ) } ) {
			return 'values do not match';
		}
	}
	else {
		# floating-point comparison must be approximate
		if( not eval { PDL::all( _approx $got, $expected ) } ) {
			return 'values do not match';
		}
	}
	# if we get here, we didn't fail
	return 0;
}


sub _dimensions_match
{
	my @A = @{ +shift };
	my @B = @{ +shift };
	while( my $a = shift @A and my $b = shift @B ) {
		if( $a != $b ) { return 0 }
	}
	return 1;
}


sub is_pdl
{
	require Test::Builder;
	my ( $got, $expected, $name ) = @_;
	my $tb = Test::Builder->new;
	if( eval { $name->isa('PDL') } ) {
		$tb->croak( 'error in arguments: test name is a piddle' );
	}
	$name ||= "piddles are equal";
	if( my $reason = _comparison_fails $got, $expected ) {
		my $rc = $tb->ok( 0, $name );
		my $fmt = '%-8T %-12D (%-5S) ';
		$tb->diag( "    $reason\n",
			   "         got: ", eval { $got->isa('PDL')      && !$got->isnull      } ? $got->info( $fmt )      : '', $got, "\n",
			   "    expected: ", eval { $expected->isa('PDL') && !$expected->isnull } ? $expected->info( $fmt ) : '', $expected );
		return $rc;
	}
	else {
		return $tb->ok( 1, $name );
	}
}


sub eq_pdl
{
	my ( $got, $expected ) = @_;
	return !_comparison_fails( $got, $expected );
}


sub eq_pdl_diag
{
	my ( $got, $expected ) = @_;
	my $reason = _comparison_fails( $got, $expected );
	if( $reason ) { return 0, $reason }
	else { return 1 }
}


sub test_pdl
{
	require Test::Deep::PDL;
	my $expected = pdl( @_ );
	return Test::Deep::PDL->new( $expected );
}


for my $type ( PDL::Types::types ) {
	my $sub = sub {
		require Test::Deep::PDL;
		my $expected = PDL::convert(
			PDL::Core::alltopdl( 'PDL', scalar(@_) > 1 ? [@_] : shift ),
			$type->numval
		);
		return Test::Deep::PDL->new( $expected );
	};
	my $sub_name = 'test_' . $type->convertfunc;
	{
		no strict 'refs';
		*$sub_name = $sub;
	}
	push @EXPORT_OK, $sub_name;
	push @{ $EXPORT_TAGS{deep} }, $sub_name;
}


sub set_options
{
	while( my( $key, $value ) = splice @_, 0, 2 ) {
		barf( "invalid option $key" ) unless grep { $key eq $_ } keys %OPTIONS;
		barf( "undefined value for $key" ) unless defined $value;
		$OPTIONS{ $key } = $value;
	}
}


1;

__END__