File Coverage

blib/lib/Statistics/Descriptive/Sparse.pm

Criterion	Covered	Total	%
statement	62	110	56.3
branch	14	28	50.0
condition	1	3	33.3
subroutine	14	17	82.3
pod	5	5	100.0
total	96	163	58.9

package Statistics::Descriptive::Sparse;
$Statistics::Descriptive::Sparse::VERSION = '3.0702';
use strict;
use warnings;

use vars qw(%fields);
use Carp;
require Statistics::Descriptive;
use Statistics::Descriptive::Smoother;

sub _make_accessors
{
    my ($pkg, $methods) = @_;

    no strict 'refs';
    foreach my $method (@$methods)
    {
        *{$pkg."::".$method} =
            do {
                my $m = $method;
                sub {
                    my $self = shift;

                    if (@_)
                    {
                        $self->{$m} = shift;
                    }
                    return $self->{$m};
                };
            };
    }

    return;
}

sub _make_private_accessors
{
    my ($pkg, $methods) = @_;

    no strict 'refs';
    foreach my $method (@$methods)
    {
        *{$pkg."::_".$method} =
            do {
                my $m = $method;
                sub {
                    my $self = shift;

                    if (@_)
                    {
                        $self->{$m} = shift;
                    }
                    return $self->{$m};
                };
            };
    }

    return;
}

##Define the fields to be used as methods
%fields = (
  count                 => 0,
  mean                  => undef,
  sum                   => undef,
  sumsq                 => undef,
  min                   => undef,
  max                   => undef,
  mindex                => undef,
  maxdex                => undef,
  sample_range          => undef,
  variance              => undef,
  );

__PACKAGE__->_make_accessors( [ grep { $_ ne "variance" } keys(%fields) ] );
__PACKAGE__->_make_accessors( ["_permitted"] );
__PACKAGE__->_make_private_accessors(["variance"]);

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;
  my $self = {
    %fields,
  };
  bless ($self, $class);
  $self->_permitted(\%fields);
  return $self;
}

sub _is_permitted
{
    my $self = shift;
    my $key = shift;

    return exists($self->_permitted()->{$key});
}

sub add_data {
    my $self = shift;  ##Myself
    my $oldmean;
    my ($min,$mindex,$max,$maxdex,$sum,$sumsq,$count);
    my $aref;

    if (ref $_[0] eq 'ARRAY') {
        $aref = $_[0];
    }
    else {
        $aref = \@_;
    }

    ##If we were given no data, we do nothing.
    return 1 if (!@{ $aref });

    ##Take care of appending to an existing data set

    if (!defined($min = $self->min()))
    {
        $min = $aref->[$mindex = 0];
    }
    else
    {
        $mindex = $self->mindex();
    }

    if (!defined($max = $self->max()))
    {
        $max = $aref->[$maxdex = 0];
    }
    else
    {
        $maxdex = $self->maxdex();
    }

    $sum   = $self->sum();
    $sumsq = $self->sumsq();
    $count = $self->count();

    ##Calculate new mean, sumsq, min and max;
    foreach ( @{ $aref } ) {
        $sum += $_;
        $sumsq += $_**2;
        $count++;
        if ($_ >= $max) {
            $max = $_;
            $maxdex = $count-1;
        }
        if ($_ <= $min) {
            $min = $_;
            $mindex = $count-1;
        }
    }

    $self->min($min);
    $self->mindex($mindex);
    $self->max($max);
    $self->maxdex($maxdex);
    $self->sample_range($max - $min);
    $self->sum($sum);
    $self->sumsq($sumsq);
    $self->mean($sum / $count);
    $self->count($count);
    ##indicator the value is not cached.  Variance isn't commonly enough
    ##used to recompute every single data add.
    $self->_variance(undef);
    return 1;
}


sub standard_deviation {
  my $self = shift;  ##Myself
  return undef if (!$self->count());
  return sqrt($self->variance());
}

##Return variance; if needed, compute and cache it.
sub variance {
    my $self = shift;  ##Myself

    my $count = $self->count();

    return undef if !$count;

    return 0 if $count == 1;

    if (!defined($self->_variance())) {
        my $variance = ($self->sumsq()- $count * $self->mean()**2);

        # Sometimes due to rounding errors we get a number below 0.
        # This makes sure this is handled as gracefully as possible.
        #
        # See:
        #
        # https://rt.cpan.org/Public/Bug/Display.html?id=46026

        $variance = $variance < 0 ? 0 : $variance / ($count - 1);

        $self->_variance($variance);

        #  Return now to avoid re-entering this sub
        #  (and therefore save time when many objects are used).
        return $variance;
    }

    return $self->_variance();
}

##Clear a stat.  More efficient than destroying an object and calling
##new.
sub clear {
  my $self = shift;  ##Myself
  my $key;

  return if (!$self->count());
  while (my($field, $value) = each %fields) {  #  could use a slice assignment here
    $self->{$field} = $value;
  }
}

1;

__END__