File Coverage

blib/lib/Statistics/Test/Sequence.pm

Criterion	Covered	Total	%
statement	94	97	96.9
branch	15	18	83.3
condition	7	14	50.0
subroutine	10	10	100.0
pod	3	3	100.0
total	129	142	90.8

package Statistics::Test::Sequence;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.01';

use Carp qw/croak/;
use Params::Util qw/_POSINT _ARRAY _CODE/;
use Math::BigFloat;
use Memoize;

=head1 NAME

Statistics::Test::Sequence - Sequence correlation test for random numbers

=head1 SYNOPSIS

  use Statistics::Test::Sequence;
  my $tester = Statistics::Test::Sequence->new();
  $tester->set_data( [map {rand()} 1..1000000] );

  my ($metric, $actual_freq, $expected_freq) = $tester->test();
  use Data::Dumper;
  print "$metric\n";
  print "Frequencies:\n";
  print Dumper $actual_freq;
  print "Expected frequencies:\n";
  print Dumper $expected_freq;

=head1 DESCRIPTION

This module implements a sequence correlation test for random number
generators. It shows pairwise correlation between subsequent
random numbers.

The algorithm is as follows: (Following Blobel. Citation in SEE ALSO section.)

=over 2

=item *

Given C random numbers C.

=item *

For all C, compare C with C. If C is greater
then C, assign a 0-Bit to the number. Otherwise, assign a
1-Bit.

=item *

Find all sequences of equal Bits. For every sequence, increment
a counter for the length C of that sequence. (Regardless of whether it's
a sequence of 1's or 0's.)

=item *

For uncorrelated random numbers, the number of sequences C
of length C in the set of C random numbers is expected to be:

  N(k) = 2*((k^2+3*k+1)*N - (k^3+3*k^2-k-4)) / (k+3)!

=back

=head1 METHODS

=cut

=head2 new

Creates a new random number tester.

=cut

sub new {
    my $proto = shift;
    my $class = ref($proto)||$proto;

    my $self = {
        data => undef,
    };

    bless $self => $class;

    return $self;
}

=head2 set_data

Sets the random numbers to operate on. First argument
must be either an array reference to an array of random
numbers or a code reference.

If the first argument is a code reference, the second
argument must be an integer C. The code reference is
called C-times and its return values are used as
random numbers.

The code reference semantics are particularily useful if
you do not want to store all random numbers in memory at
the same time. You can write a subroutine that, for example,
generates and returns batches of 100 random numbers so no
more than 101 of these numbers will be in memory at the
same time. Note that if you return 100 numbers at once and
pass in C, you will have a sequence of 5000 random
numbers.

=cut

sub set_data {
    my $self = shift;
    my $data = shift;
    if (_ARRAY($data)) {
        $self->{data} = $data;
        return 1;
    }
    elsif (_CODE($data)) {
        $self->{data} = $data;
        my $n = shift;
        if (not _POSINT($n)) {
            croak("'set_data' needs an integer as second argument if the first argument is a code reference.");
        }
        $self->{n} = $n;
        return 1;
    }
    else {
        croak("Invalid arguments to 'set_data'.");
    }
}

=head2 test

Runs the sequence test on the data that was previously set using
C.

Returns three items: The first is the root mean square of the bin
residuals divided by the number of random numbers. It I be
used as a measure for the quality of the random number generator
and should be as close to zero as possible. A better metric is to
compare the following two return values.

The second return value is a reference to the array of frequencies.
An example is in order here. Generating one million random numbers,
I get:

  [0, 416765, 181078, 56318, 11486, 1056, 150]

This means there were no sequences of length 0 (obvious), 416765
sequences of length 1, etc. There were no sequences of length 7 or
greater. This example is a bad random number generator! (It's a
linear congruent generator with C<(a*x_i+c)%m> and C,
C, C, and C).

The third return value is similar in nature to the second in that it
is a reference to an array containing sequence length frequencies.
This one, however, contains the frequencies that would be expected for
the given number of random numbers, were they uncorrelated.
The number of bins has the maximum
length of an occurring sequence as an upper limit. In the given example,
you would get: (Dumped with Data::Dumper)

  $VAR1 = [
            '0',
            '416666.75',
            '183333.1',
            '52777.64722222222222222222222222222222222',
            '11507.89523809523809523809523809523809524',
            '2033.72068452380952380952380952380952381',
            '303.1287808641975308641975308641975308642',
            # ...
          ];

Note that where I put in a C<# ...>, you would really see a couple
more lines of numbers until the numbers go below an expected
frequency of C<0.1>.
For C and C, you get about
39 sequences, C is expected to be found 4-5 times, etc.

=cut

sub test {
    my $self = shift;
    my $data = $self->{data};

    if (not defined $data) {
        croak("Set data using 'set_data' first.");
    }

    # bin counters
    my @bins;
    # current sequence type (> or <)
    my $current = undef;
    # current sequence length
    my $length = 0;
    # total number of random numbers
    my $numbers;

    if (_ARRAY($data)) {
        $current = ($data->[0] <=> $data->[1]) || 1;
        $length++;
        $numbers = @$data;

        foreach my $i (1 .. $#$data-1) {
            my $cmp = ($data->[$i] <=> $data->[$i+1]) || 1;
            if ($current == $cmp) {
                $length++;
            }
            else {
                $current = $cmp;
                $bins[$length]++;
                $length = 1;
            }
        }
        $bins[$length]++;
    }
    else { # CODE
        my @cache;
        my $calls = $self->{n};
        my $first_run = 1;
        foreach (1..$calls) {
            # get new data
            push @cache, $data->();
            # first run => initialize with first comparison
            if ($first_run and @cache > 1) {
                $current = ($cache[0] <=> $cache[1]) || 1;
                shift @cache;
                $length++;  # == 1
                $numbers++; # == 1
                $first_run = 0;
            }
            while (@cache > 1) {
                $numbers++;
                my $this = shift @cache;
                my $cmp = ($this <=> $cache[0]) || 1;
                if ($current == $cmp) {
                    $length++;
                }
                else {
                    $current = $cmp;
                    $bins[$length]++;
                    $length = 1;
                }
            }
        }
        $bins[$length]++;
    }

    my @expected = (0); # 0-bin is empty
    foreach my $bin (1..$#bins) {
        $expected[$bin] = expected_frequency($bin, $numbers-1);
    }
    my $last_bin = $#bins;
    while ($expected[$last_bin] > 0.1) {
        $last_bin++;
        $expected[$last_bin] = expected_frequency($last_bin, $numbers-1);
    }

    foreach my $bin (0..$last_bin) {
        $bins[$bin] = 0 if not defined $bins[$bin];
    }


    my @diff = map { abs($bins[$_] - $expected[$_]) } 0..$#bins;

    my $residual = 0;
    $residual += $_**2 for @diff;
    $residual = sqrt($residual);
    $residual = "$residual"; # de-bigfloatize

    @expected = map {"$_"} @expected; # de-bigfloatize

    return(
        $residual / ($numbers-1),
        \@bins,
        \@expected,
    );
}

=head1 SUBROUTINES

=head2 expected_frequency

Returns the expected frequency of the sequence length C
in a set of C random numbers assuming uncorrelated random
numbers.

Returns this as a L.

Expects C and C as arguments.

This subroutine is memoized. (See L.)

=cut

memoize('expected_frequency');
sub expected_frequency {
    my $k = Math::BigFloat->new(shift);
    my $n = Math::BigFloat->new(shift);
    return(
        2 * ( ($k**2 + 3*$k + 1)*$n - ($k**3 + 3*$k**2 - $k - 4) )
        / faculty($k+3)
    );
}

=head2 faculty

Computes the factulty of the first argument recursively as a
L. This subroutine is memoized. (See L.)

=cut

memoize('faculty');
sub faculty {
    my $n = shift;
    return Math::BigFloat->bone() if $n <= 1;
    return $n * faculty($n-1);
}

1;
__END__