File Coverage

blib/lib/Test2/Tools/PDL.pm

Criterion	Covered	Total	%
statement	99	112	88.3
branch	19	24	79.1
condition	5	12	41.6
subroutine	17	17	100.0
pod	2	2	100.0
total	142	167	85.0

package Test2::Tools::PDL;

# ABSTRACT: Test2 tools for verifying Perl Data Language piddles

use 5.010;
use strict;
use warnings;

our $VERSION = '0.0004'; # VERSION

use PDL::Lite ();
use PDL::Primitive qw(which);
use PDL::Types;

use Safe::Isa;
use Scalar::Util qw(blessed);
use Test2::API qw(context);
use Test2::Compare qw(compare strict_convert);
use Test2::Util::Table qw(table);
use Test2::Util::Ref qw(render_ref);

use parent qw/Exporter/;
our @EXPORT = qw(pdl_ok pdl_is);

our $TOLERANCE = $Test2::Compare::Float::DEFAULT_TOLERANCE;
our $TOLERANCE_REL = 0;


sub pdl_ok {
    my ( $thing, $name ) = @_;
    my $ctx = context();

    unless ( $thing->$_isa('PDL') ) {
        my $thingname = render_ref($thing);
        $ctx->ok( 0, $name, ["'$thingname' is not a piddle."] );
        $ctx->release;
        return 0;
    }

    $ctx->ok( 1, $name );
    $ctx->release;
    return 1;
}


sub pdl_is {
    my ( $got, $exp, $name, @diag ) = @_;
    my $ctx = context();

    my $gotname = render_ref($got);
    unless ( $got->$_isa('PDL') ) {
        $ctx->ok( 0, $name, ["First argument '$gotname' is not a piddle."] );
        $ctx->release;
        return 0;
    }
    unless ( $exp->$_isa('PDL') ) {
        my $expname = render_ref($exp);
        $ctx->ok( 0, $name, ["Second argument '$expname' is not a piddle."] );
        $ctx->release;
        return 0;
    }

    my $exp_class = ref($exp);
    if ( ref($got) ne $exp_class ) {
        $ctx->ok( 0, $name,
            ["'$gotname' does not match the expected type '$exp_class'."] );
        $ctx->release;
        return 0;
    }

    # compare dimensions
    my @exp_dims   = $exp->dims;
    my @got_dims   = $got->dims;
    my $delta_dims = compare( \@got_dims, \@exp_dims, \&strict_convert );

    if ($delta_dims) {
        $ctx->ok( 0, $name,
            [ $delta_dims->table, 'Dimensions do not match', @diag ] );
        $ctx->release;
        return 0;
    }

    # compare isbad
    my $both_bad;
    if ( $got->badflag or $exp->badflag ) {
        my $delta_isbad =
          compare( $got->isbad->unpdl, $exp->isbad->unpdl, \&strict_convert );

        if ($delta_isbad) {
            $ctx->ok(
                0, $name,
                [
                    $delta_isbad->table, 'Bad value patterns do not match',
                    @diag
                ]
            );
            $ctx->release;
            return 0;
        }

        $both_bad = ( $got->isbad & $exp->isbad );
    }

    # Compare data values.
    my $diff;
    my $is_numeric = !(
        List::Util::any { $exp->$_isa($_) }
        qw(PDL::SV PDL::Factor PDL::DateTime) or $exp->type eq 'byte'
    );
    eval {
        if ( $is_numeric
            and ( $exp->type >= PDL::float or $got->type >= PDL::float ) )
        {
            $diff = ( ( $got - $exp )->abs >
                  $TOLERANCE + ( $TOLERANCE_REL * $exp )->abs );
        }
        else {
            $diff = ( $got != $exp );
        }
        if ( $exp->badflag ) {
            $diff->where( $exp->isbad ) .= 0;
        }
    };
    if ($@) {
        my $gotname = render_ref($got);
        $ctx->ok( 0, $name, [ "Error occurred during values comparison.", $@ ],
            @diag );
        $ctx->release;
        return 0;
    }
    my $diff_which = which($diff);
    unless ( $diff_which->isempty ) {
        state $at = sub {
            my ( $p, @position ) = @_;
            if ( $p->isa('PDL::DateTime') ) {
                return $p->dt_at(@position);
            }
            else {
                return $p->at(@position);
            }
        };

        my $gotname = render_ref($got);
        my @table   = table(
            sanitize  => 1,
            max_width => 80,
            collapse  => 1,
            header    => [qw(POSITION GOT CHECK)],
            rows      => [
                map {
                    my @position = $exp->one2nd($_);
                    [
                        join( ',', @position ),
                        $at->( $got, @position ),
                        $at->( $exp, @position )
                    ]
                } @{ $diff_which->unpdl }
            ]
        );
        $ctx->ok( 0, $name, [ "Values do not match.", @table ], @diag );
        $ctx->release;
        return 0;
    }

    $ctx->ok( 1, $name );
    $ctx->release;
    return 1;
}

1;

__END__