File Coverage

blib/lib/Data/Grouper.pm

Criterion	Covered	Total	%
statement	106	140	75.7
branch	24	34	70.5
condition	12	18	66.6
subroutine	9	11	81.8
pod	7	8	87.5
total	158	211	74.8

package Data::Grouper;

use strict;
#use vars qw($VERSION);

$Data::Grouper::VERSION = '0.06';


#
# Options
#
#   COLNAMES => [ name, name, ... ]
#   SORTCOLS => [ name, ... ]
#   AGGREGATES => [ colidx, colidx, ... ]
#   DATA => array of hashrefs or arrayrefs
#
#
# Note: The lastvals array's indexes correspond to the
#       array indexes for SORTCOLS.
#
sub new
{
   my $proto = shift;
   my $class = ref($proto) || $proto;

   my $self = {};

   # set option defaults so they won't be undefined
   $self->{OUTER} = [];
   $self->{LASTVALS} = [];
   $self->{TOPLEVEL_AGGS} = {};
   $self->{OPTIONS} = {};

   #$self->{LASTADDED}  # we want this to be undefined at first

   # Set this to 0 to avoid extra work.  If somebody uses an
   # option that requires we compute aggregates, this will be
   # set to 1 later.
   #
   $self->{OPTIONS}->{USE_AGGREGATES} = 0;

   # load in options supplied to new()
   for (my $x = 0; $x <= $#_; $x += 2)
   {
      my $opt = uc($_[$x]);

      defined($_[($x + 1)]) or die "grouper->new() called with odd number of option parameters - should be of the form option => value";
      $self->{OPTIONS}->{$opt} = $_[($x + 1)];
   }

   # automatically set this if necessary
   if (defined($self->{OPTIONS}->{AGGREGATES}) )
   {
      $self->{OPTIONS}->{USE_AGGREGATES} = 1;
   }

   bless($self);

   if (defined($self->{OPTIONS}->{DATA}))
   {
      $self->add_array($self->{OPTIONS}->{DATA});
   }

   return $self;
}

# DBI can return entire arrays with selectall_arrayref.  This
# function lets you just pass an array ref in instead of doing
# a while loop and calling add_row for each row.
#
sub add_array
{
   my ($self,$aref) = @_;
   for my $r (@{$aref})
   {
      if (ref($r) eq 'HASH')
      {
         $self->add_hash($r);
      }
      else
      {
         $self->add_row(@{$r});
      }
   }
}

#
# This adds a row to our dataset.
# This is pretty much the most important function in this
# module.
#
# This really should take a reference!!!!
#
sub add_row
{
   my ($self,@row) = @_;
   my $options = $self->{OPTIONS};
   my (%h);

   warn "You must define COLNAMES when using add_row or DATA with arrayrefs.\n"
      if not defined $options->{COLNAMES};

   # Turn @row into a hash
   @h{ @{ $options->{COLNAMES} } } = @row;

   $self->add_hash(\%h);
}

sub add_hash
{
   my ($self,$href) = @_;

   my $options = $self->{OPTIONS};
   my $sortcols = 1 + $#{ $options->{SORTCOLS} };

   # Automatically populate COLNAMES if it hasn't been done before
   if ($#{$options->{COLNAMES}} == -1)
   {
      @{$options->{COLNAMES}} = keys ( %{$href} );
   }


   # Create our own copy.  We don't want to modify someone
   # elses hash.
   my %h2 = %{$href};

   # apply format functions
   for my $fkey (keys(%{$options->{FORMAT}}))
   {
      my $fref = $options->{FORMAT}->{$fkey};
      $h2{$fkey} = &$fref($h2{$fkey});
   }

   # describe aref here
   my $aref = $self->{OUTER};

   # Update top level aggregates
   if ($options->{USE_AGGREGATES} == 1)
   {
      for my $colname (@{$options->{AGGREGATES}})
      {
         my $val = $h2{$colname};
         $self->{TOPLEVEL_AGGS}->{"SUM_$colname"} += $val;
      }
   }

   #
   # This loop iterates through the sort items, descending through
   # the arrays of hashes until it gets to the leaf node where
   # this row belongs.  It then pushes the hash ref onto the
   # appropritate array.  Non-leaf arrays contain aggregate info.
   #
   # $i in this loop is an index into the SORTCOLS and LASTVALS arrays.
   #

   for (my $i=0;$i<$sortcols;$i++)
   {
      # Must figure out rowidx based on $i and COLNAMES
      my $colname = $options->{SORTCOLS}->[$i];

      warn "Item $colname in SORTCOLS does not correspond to COLNAMES.\n"
         if (!grep {$_ eq $colname} @{$options->{COLNAMES}});

      # If this is the first row, or it is a new value, create
      # new entries
      #
      # Comment from Sam Tregar-- use of 'ne' possibly inappropriate for
      # floating point data.  Provide an option here?
      #
      if (!defined($self->{LASTVALS}->[$i]) ||
          $self->{LASTVALS}->[$i] ne $h2{$colname}
         )
      {


         #
         # apply format functions to aggregates before moving on
         # to new array
         # This needs to work for all the grouping levels after this...
         # i.e., if $i=2 and $sortcols=4, we still have to format $i==3
         #
         if (defined($self->{LASTVALS}->[$i]))
         {
            $self->_format_tails($aref);
         }


         # Add a new hash to the current array of hash refs
         # I copy this from the hash for this row as a shortcut to
         # give access to $colname, which is generally needed.  Also
         # other variables may be in @row, like IDs or something, that
         # the author wants to use

         my %h3 = %h2;
         $h3{INNER} = [];
         push @{$aref}, \%h3;


         if ($options->{USE_AGGREGATES} == 1)
         {
            $self->_do_aggregates($aref,\%h2);
         }


         # Set aref, our array pointer, to the array of the
         # next inner element
         $aref = $h3{INNER};

         # undefine all vals after this in order to
         # force new arrays to be generated
         $#{$self->{LASTVALS}} = $i;

         $self->{LASTVALS}->[$i] = $h2{$colname};
      }
      else
      {
         # this is the place to do totals....
         if ($options->{USE_AGGREGATES} == 1)
         {
            $self->_do_aggregates($aref,\%h2);
         }

         #Move to inner array
         $aref = $aref->[-1]->{INNER};
      }

   }

   # We've found the right array, add the row
   push @{$aref},\%h2;
   $self->{LASTADDED} = $aref;
}

# Sometimes you will want to add some additional information
# to a row or a parent.  This function helps you do that.
#
# It takes these parameters:
#   *  Address (ar_loc)
#      This specifies which row you would like to add data to.  If you are
#      sorting on 3 columns, you would pass an array ref with between 1 and 3
#      values.  This would specify a non-innermost loop row.  This row would
#      then have the contents of the details parameter (below) added to its
#      hash.
#
#   *  Details (hr_dtls)
#      This is a reference to a hash that will be added to the indicated
#      row, if it is found.
#
sub add_details
{
   my ($self,$ar_loc,$hr_dtls) = @_;

   # ar_loc contains basically an address
   my $colidx = 0;
   my $aref = $self->{OUTER};
   my $the_href;
   my $options = $self->{OPTIONS};

   for my $loc (@{$ar_loc})
   {
      my $found = 0;

      # look through rows for match
      for my $href (@{$aref})
      {
         my $colname = $options->{SORTCOLS}->[$colidx];
#         print "test ($loc) ($colname)";
         if ($loc eq $href->{$colname})
         {
            $the_href = $href;
            $aref = $href->{INNER};
            $found = 1;
            last;
         }
      }

      # if it wasn't found return failure
      if (!$found)
      {
         #print "not found ($loc) !";
         return 0;
      }

      $colidx++;
   }

   for my $k (keys (%{$hr_dtls}) )
   {
      $the_href->{$k} = $hr_dtls->{$k};
   }

   1;
}

sub get_details
{
}

#
#
# Returns the array ref you will need to pass to HTML::Template
#
# Computes any top level aggregates first though
#
sub get_data
{
   my ($self) = @_;
   $self->_format_tails($self->{OUTER});
   $self->{OUTER};
}

sub get_top_aggregates
{
   my ($self) = @_;
   my $options = $self->{OPTIONS};

   # possibly defer computation until here?

   # apply format functions
   # Does this make any sense?
   for my $fkey (keys(%{$options->{FORMAT}}))
   {
      my $fref = $options->{FORMAT}->{$fkey};
      $self->{TOPLEVEL_AGGS}->{$fkey} = &$fref($self->{TOPLEVEL_AGGS}->{$fkey});
   }

   $self->{TOPLEVEL_AGGS};
}

#
# Private functions
#


# _do_aggregates
#
# This helper function computes aggregates:
#
# SUM
# AVG
# COUNT
# MIN
# MAX
#
# $aref is an array reference into the structure we are building.
# $hr_row is a hash reference of the hash of the row we are adding.
#
sub _do_aggregates
{
   my ($self,$aref,$hr_row) = @_;
   my $href = $aref->[$#{$aref}];

   #
   # For each colidx in our list of columns to be summed,
   # add to its total
   #

   for my $colname (@{$self->{OPTIONS}->{AGGREGATES}})
   {
      my $val = $hr_row->{$colname};

      $href->{"SUM_$colname"} += $val;

      $href->{"COUNT_$colname"} ++;

      my $x = $href->{"MIN_$colname"};
      if (!defined( $x) || $val < $x)
      {
         $href->{"MIN_$colname"} = $val;
      }

      $x = $href->{"MAX_$colname"};
      if (!defined( $x) || $val > $x)
      {
         $href->{"MAX_$colname"} = $val;
      }

   }

   # Do the averages

}

#
# This code isn't very elegant.  I need to find a better
# way.
#
sub _format_tails
{
   my ($self,$aref2) = @_;
   my $options = $self->{OPTIONS};

   while (defined($aref2) && defined($#{$aref2}>=0 && $aref2->[-1]->{INNER}))
   {
      for my $fkey (keys(%{$options->{FORMAT}}))
      {
         my $fref = $options->{FORMAT}->{$fkey};
         my $href = $aref2->[-1];
         $href->{$fkey} = &$fref($href->{$fkey});
      }

      if ( $#{$aref2} >=0)
      {
         $aref2 = $aref2->[-1]->{INNER};
      }
      else { undef $aref2; }
   }
}



1;
__END__