File Coverage

blib/lib/Test/Approximate.pm

Criterion	Covered	Total	%
statement	46	46	100.0
branch	18	18	100.0
condition	8	9	88.8
subroutine	12	12	100.0
pod	3	3	100.0
total	87	88	98.8

package Test::Approximate;

=head1 NAME

Test::Approximate - test for approximate numeric equality

=cut

use 5.008;

use strict;
use warnings;

use Carp 'croak';

=head1 VERSION

version 0.102

=cut

our $VERSION = '0.102';

=head1 SYNOPSIS

    use Test::Approximate;

    set_dop(3); # this is the default value
    is_approx 3, 3.001, 'close enough';

    set_dop(1);
    is_approx 3.0, 3.4, 'also close enough';

    set_dop(2);
    isnt_approx 3.0, 3.4, 'different';

=head1 DESCRIPTION

Test::Approximate provides tests that can be used to compare
floating-point numbers for approximate equality (C) and
inequality (C). This is achieved using the concept of
I, or DOP. The DOP of a number are a fixed number
of significant digits of that number. For example, with 3 DOP
1,234,000 would be 1,230,000 and 0.000 1234 would be 0.000 123.

By default, 3 DOP are used.

=head2 METHOD

To compare the two numbers C<$actual> and C<$expected>, a
(power-of-ten) scaling factor for C<$expected> is determined, such
that, when multiplied by it, there will be DOP digits before the
decimal point. The absolute value of the difference between C<$actual>
and C<$expected> is multiplied by the scaling factor and rounded to
the nearest integer. If this value is zero, the two values are deemed
to be approximately the same (or non-zero in the case of
C).

=head2 DIAGNOSTICS

C and C will emit diagnostics whenever a
test fails.

For example,

    set_dop(2);
    is_approx 1000,1100; # fails

produces the following output:

    not ok 1
    # Failed test at ... line 13.
    #     Original: 1000, 1100
    #     DOP: 2
    #     Delta: 100
    #     Multiplier: 0.01 (1e-2)
    #     Diff: round(1)
    #     Comparison: 1 == 0

B: the untouched values of C<$actual> and C<$expected> as
passed in to the test.

B: the I used.

B: the absolute difference between C<$actual> and C<$expected>.

B: factor used to make all DOP occur before the decimal
point.

B: delta after scaling.

B: the comparison used for the test.

=cut

use parent 'Exporter';
our @EXPORT = qw( is_approx isnt_approx set_dop );

use Test2::API qw'context';

use constant {
    K_EQUAL    => 'EQ',
    K_NOTEQUAL => 'NE'
};

my $MAXDOP = 14;
my $_DOP   = 3;

=head1 FUNCTIONS

=head2 is_approx

    is_approx $actual, $expected, $name;

Compares C<$actual> to C<$expected> as described L
and generates an appropriate standard pass/fail test result. As is
usual with Perl testing modules, C<$name> is optional.

=cut

sub is_approx($$;$) {
    return _compare(K_EQUAL, @_);
}

=head2 isnt_approx

    isnt_approx $actual, $expected, $name;

The opposite of C. The test will pass if C<$actual> and
C<$expected> are sufficiently different.

=cut

sub isnt_approx($$;$) {
    return _compare(K_NOTEQUAL, @_);
}

=head2 set_dop($new_dop)

    set_dop(4);      # set precision to 4 DOP
    print set_dop(); # 4

C is used to set the precision of C and
C. It takes a single, optional, argument that
represents the DOP to use in the comparisons. C<$new_dop> must be an
integer between 1 and 14 inclusive and will be shoehorned into that
range if necessary. C<$new_dop> is returned as the value of the
function.

If C<$new_dop> is absent, C just returns the current value of
DOP.

See L above for more about DOP.

=cut

sub set_dop {
    if (@_) {
        my $dop = shift;

        croak "Positive integer expected"
          if ! defined $dop || $dop eq '' || $dop =~ /\D/;

        $dop = 1       if $dop < 1;
        $dop = $MAXDOP if $dop > $MAXDOP;

        $_DOP = $dop
    }
    return $_DOP;
}

sub _compare {
    my ($eq_noteq, $actual, $expected, $name) = @_;

    my $scale = $expected == 0
      ? 0
      : _floor(log(abs $expected) / log 10) + 1;

    my $delta    = abs $actual - $expected;
    my $mult     = 10**($_DOP-$scale);
    my $to_round = $delta * $mult;
    my $diff     = int $to_round + 0.5;

    my $diag = join '', map { "    $_\n" } (
        "Original values: $actual, $expected",
        "DOP: $_DOP",
        "Delta: $delta",
        "Multiplier: $mult (1e" . ($_DOP-$scale) . ")",
        "Diff: round($to_round)",
        "Comparison: $diff " . ($eq_noteq eq K_EQUAL ? '==' : '!=') . " 0",
    );

    my $ctx = context( level => 1 );
    my $ok = $eq_noteq eq K_EQUAL ? $diff == 0 : $diff != 0;
    $ctx->ok( $ok, $name );
    $ctx->diag($diag) unless $ok;
    $ctx->release;

    return $ok;
}

sub _floor { # https://stackoverflow.com/questions/37020135
    my $x   = shift;
    my $int = int $x;
    return $x < 0 && $int != $x ? $int - 1 : $int;
}

=head1 AUTHOR & COPYRIGHT

Copyright 2020 by Brian Greenfield E briang @ cpan dot org E.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;