File Coverage

blib/lib/Random/Skew/Test.pm

Criterion	Covered	Total	%
statement	87	100	87.0
branch	30	42	71.4
condition	12	16	75.0
subroutine	7	7	100.0
pod	0	4	0.0
total	136	169	80.4

package Random::Skew::Test;

use strict;
use warnings;

our $VERSION = '0.02';

use Random::Skew;

sub sample {

    my $self = shift;
    my %params = @_;

    my @bad;

    my $iter = $params{iter} or push @bad,"Random::Skew::sample(iter=>?) parameter missing";
    my $skew = $params{skew} or push @bad,"Random::Skew::sample(skew=>{}) parameter missing";
    my $grain= $params{grain} // [ qw/25 250 1000/ ];
    my $round= $params{round} // [ qw/0 .5/ ];

    die @bad if @bad;

    my @output;

    my $rs;

    my @grain = @$grain;
    my @round = @$round;

    foreach $grain ( @grain ) {

        $Random::Skew::GRAIN = $grain;
        my @r = @round;

        while ( @r ) {
            $round = shift @r;

            $Random::Skew::ROUNDING = $round;

            $rs = Random::Skew->new( %$skew );
            my $pop = $rs->{_pop};

            if ( $rs->{_tot} < $rs->{_grain} ) {
                $round = '[moot at this grain]';
                @r = ();
            }

            push @output, "Grain=$Random::Skew::GRAIN (Rounding=+$round): -=-=-=-=-=-=-=-=-=-\n",
                &show( $rs ),
                &run( $rs, $iter );

        }

    }

    return @output,
        "Typically you want the Ratio column to be close to 1.0 (0.9ish to 1.1ish).\n",
        "However, more iterations (>$iter) might smooth out the results.\n\n";

}



# To see the structure of a Random::Skew object
sub show {
    my $set = shift;
    my $indent = shift || '';

    my @output;

    my %v;
    my $v;
    foreach $v ( @{ $set->{_set} } ) {
        $v{ $v }++ unless ref $v;
    }
    foreach $v ( sort {$v{$b} <=> $v{$a} or $a cmp $b} keys %v ) {
        push @output, "$indent$v\t$v{$v}\n"
             if $v; # no need to show empties, _fraction handles those anyway
    }

    if ( $set->{_fraction} ) {
        push @output,
            "$indent...and smaller (when rand(0..$set->{_pop}) < $set->{_fraction}):\n",
            &show( $set->{_set}[0], "$indent  " );
    }

    return @output;
}



sub run {
    my $rs = shift;
    my $ct = shift // 1_000_000;

    my @output;

    push @output, "--${ct}x:\n",
        "Bucket\tReturned(%)\tRequested(%)\tRatio\n",
        "======\t========\t=========\t=====\n";

    my %result;
    while ( $ct-- > 0 ) {

        # _/_/_/_/  _/_/_/_/    _/_/_/_/  _/_/_/_/
        #   _/     _/         _/            _/
        #  _/     _/_/_/      _/_/_/       _/
        # _/     _/               _/      _/
        #_/     _/_/_/_/  _/_/_/_/       _/

        $result{ $rs->item }++; # Here's where we iterate thru the tests

    }

    my $overall_prd = 1.0;
    my $is_zero = 0;
    my $overall_avg = 0.0;

    my $p = $rs->{_params};
    my $p_tot = 0;
    my $r_tot = 0;
    foreach my $item ( keys %$p ) {
        $p_tot += $p->{ $item }    // 0;
        $r_tot += $result{ $item } // 0;
    }
    foreach my $item ( sort {$p->{$b} <=> $p->{$a} or $a cmp $b } keys %$p ) {
        my $p_pct = 100 *     $p->{ $item }       / $p_tot;
        my $r_pct = 100 * ($result{ $item } // 0) / $r_tot;
        my $ratio = $r_pct / $p_pct;
        $is_zero ++ unless defined( $result{ $item } );

        my $ratio_alert = '';
           $ratio_alert = ' <-- low?'  if $ratio < 9/10;
           $ratio_alert = ' <-- LOW?'  if $ratio < 8/10;
           $ratio_alert = ' <-- high?' if $ratio > 10/9;
           $ratio_alert = ' <-- HIGH?' if $ratio > 10/8;
        push @output, sprintf "%s:\t%s (%3.3g)\t%s (%3.3g)\t%.4f%s\n",
            $item,
            &h( $result{$item} // 0 ), $r_pct,
            &h( $p->{$item} ),         $p_pct,
            $ratio, $ratio_alert,
            ;
        $overall_prd *= $ratio;
        $overall_avg += $ratio;
    }
    $overall_avg /= scalar keys %$p;
    if ( $is_zero > 1 ) {
        push @output, "Note: there are $is_zero buckets not represented (which causes zero product).\n";
    } elsif ( $is_zero > 0 ) {
        push @output, "Note: there is a bucket not represented (which causes zero product).\n";
    }
    push @output, sprintf "Overall ratio product: %5.5g\nOverall ratio average: %5.5g\n\n",
         $overall_prd,
         $overall_avg;

    return @output;
}



sub h {
    my $v = shift;
    my $unit = '';
    my $div = 1;
    my $fmt = '%.0f'; # %f rounds, %d truncates
    if ( $v > 2_000_000_000 ) {
        $div = 1000 * 1000 * 1000;
        $unit = 'g';
    } elsif ( $v > 9_999_999 ) {
        $div = 1000 * 1000;
        $unit = 'm';
    } elsif ( $v > 2_000_000 ) {
        $div = 1000 * 1000;
        $unit = 'm';
        $fmt = '%.1f';
    } elsif ( $v > 9_999 ) {
        $div = 1000;
        $unit = 'k';
    } elsif ( $v > 2_000 ) {
        $div = 1000;
        $unit = 'k';
        $fmt = '%.1f';
    }
    return sprintf "$fmt%s", $v/$div, $unit;
}



1;
__END__