Data::CloudWeights - Calculate values for an HTML tag cloud

   use Data::CloudWeights;

   # Create a new cloud
   my $cloud = Data::CloudWeights->new( \%cfg );

   # Add one or more tags to the cloud
   $cloud->add( $tag, $count, $value );

   # Calculate the tag cloud values
   my $nimbus = $cloud->formation();

   $cloud = Data::CloudWeights->new( [{] attr => value, ... [}] )

   $cloud->add( $name, $count, $value );

   $cloud->formation();

# @(#)$Id: CloudWeights.pm 130 2011-04-12 19:55:01Z pjf $

package Data::CloudWeights;

use strict;
use namespace::autoclean;
use version; our $VERSION = qv( sprintf '0.6.%d', q$Rev: 130 $ =~ /\d+/gmx );

use Color::Spectrum;
use Moose;
use Moose::Util::TypeConstraints;

enum 'D_CW_Sort_Order' => qw(asc desc);
enum 'D_CW_Sort_Type'  => qw(alpha numeric);

subtype 'D_CW_Colour'  => as 'Str' =>
   where { not $_ or '#' eq substr $_, 0, 1 };

has 'cold_colour'    => is => 'ro', isa => 'Maybe[D_CW_Colour]',
   default           => '#0000FF', documentation => 'Blue';
has 'hot_colour'     => is => 'ro', isa => 'Maybe[D_CW_Colour]',
   default           => '#FF0000', documentation => 'Red';

has 'colour_pallet'  => is => 'rw', isa => 'ArrayRef[D_CW_Colour]',
   default           => sub { [ '#CC33FF', '#663399', '#3300CC', '#99CCFF',
                                '#00FFFF', '#66FFCC', '#66CC99', '#006600',
                                '#CCFF66', '#FFFF33', '#FF6600', '#FF0000' ] },
   documentation     => 'Alternative to colour calculation';
has 'decimal_places' => is => 'rw', isa => 'Int', default => 3,
   documentation     => 'Defaults for ems';
has 'limit'          => is => 'rw', isa => 'Int', default => 0,
   documentation     => 'Max size of returned list. Zero no limit';
has 'max_count'      => is => 'rw', isa => 'Int', default => 0,
   documentation     => 'Current max value across all tags cloud';
has 'max_size'       => is => 'rw', isa => 'Num', default => 3.0,
   documentation     => 'Output size no more than';
has 'min_count'      => is => 'rw', isa => 'Int', default => -1,
   documentation     => 'Current min';
has 'min_size'       => is => 'rw', isa => 'Num', default => 1.0,
   documentation     => 'Output size no less than';
has 'sort_field'     => is => 'rw', isa => 'Maybe[Str]', default => 'tag',
   documentation     => 'Output sorted by this field';
has 'sort_order'     => is => 'rw', isa => 'D_CW_Sort_Order', default => 'asc',
   documentation     => 'Sort order - asc   or desc';
has 'sort_type'      => is => 'rw', isa => 'D_CW_Sort_Type', default => 'alpha',
   documentation     => 'Sort type  - alpha or numeric';
has 'total_count'    => is => 'rw', isa => 'Int', default => 0,
   documentation     => 'Current total for all tags in the cloud';

has '_index' => is => 'ro', isa => 'HashRef',  default => sub { {} };
has '_sorts' => is => 'ro', isa => 'HashRef',  default => sub { {
   alpha   => {
      asc  => sub { my $x = shift; sub { $_[ 0 ]->{ $x } cmp $_[ 1 ]->{ $x } }
      },
      desc => sub { my $x = shift; sub { $_[ 1 ]->{ $x } cmp $_[ 0 ]->{ $x } }
      },
   },
   numeric => {
      asc  => sub { my $x = shift; sub { $_[ 0 ]->{ $x } <=> $_[ 1 ]->{ $x } }
      },
      desc => sub { my $x = shift; sub { $_[ 1 ]->{ $x } <=> $_[ 0 ]->{ $x } }
      },
   } } };
has '_tags'  => is => 'ro', isa => 'ArrayRef', default => sub { [] };

sub BUILD {
   my $self = shift;

   # Unsetting hot or cold colour strings in the constructor will cause
   # the default pallet to be used instead
   if ($self->cold_colour and $self->hot_colour) {
      my $cs = Color::Spectrum->new();

      $self->colour_pallet( [ $cs->generate( 12, $self->cold_colour,
                                             $self->hot_colour ) ] );
   }

   return;
}

sub add {
   # Include the passed args in this cloud's formation
   my ($self, $tag, $count, $value) = @_;

   $tag or return; # Mandatory arg used as a key in tag ref index

   # Mask out null strings and negative numbers from the passed count value
   $count = defined $count ? abs $count : 0;

   # Add this count to the total for this cloud
   $self->total_count( $self->total_count + $count );

   unless (exists $self->_index->{ $tag }) {
      # Create a new tag reference and add to both list and index
      my $tag_ref = { count => $count, tag => $tag, value => $value };

      push @{ $self->_tags }, $self->_index->{ $tag } = $tag_ref;
   }
   else {
      my $index = $self->_index->{ $tag };

      # Calls with the same tag are cumulative
      $count += $index->{count}; $index->{count} = $count;

      if (defined $value) {
         my $tag_value = $index->{value};

         # Make an array if there are two or more calls to add the same tag
         $tag_value and ref $tag_value ne q(ARRAY)
            and $index->{value} = [ $tag_value ];

         # Push passed value in each call onto the values array.
         if ($tag_value) { push @{ $index->{value} }, $value }
         else { $index->{value} = $value }
      }
   }

   # Update this cloud's max and min values
   $count > $self->max_count and $self->max_count( $count );
   $self->min_count == -1    and $self->min_count( $count );
   $count < $self->min_count and $self->min_count( $count );

   # Return the current cumulative count for this tag
   return $count;
}

sub formation {
   # Calculate the result set for this cloud
   my $self    = shift;
   my $prec    = 10**$self->decimal_places;
   my $bands   = scalar @{ $self->colour_pallet } - 1;
   my $range   = (abs $self->max_count - $self->min_count) || 1;
   my $step    = ($self->max_size - $self->min_size) / $range;
   my $compare = $self->_get_sort_method;
   my $ntags   = @{ $self->_tags };
   my $out     = [];

   $ntags == 0 and return []; # No calls to add were made

   if ($ntags == 1) {           # One call to add was made
      return [ { colour  => $self->hot_colour || pop @{ $self->colour_pallet },
                 count   => $self->_tags->[ 0 ]->{count},
                 percent => 100,
                 size    => $self->max_size,
                 tag     => $self->_tags->[ 0 ]->{tag},
                 value   => $self->_tags->[ 0 ]->{value} } ];
   }

   for (sort { $compare->( $a, $b ) } @{ $self->_tags }) {
      my $count   = $_->{count};
      my $base    = $count - $self->min_count;
      my $index   = int 0.5 + ($base * $bands / $range);
      my $percent = 100 * $count / $self->total_count;
      my $size    = $self->min_size + $step * $base;

      # Push the return array with a hash ref for each key value pair
      # passed to the add method
      push @{ $out }, { colour  => $self->colour_pallet->[ $index ],
                        count   => $count,
                        percent => (int 0.5 + $prec * $percent) / $prec,
                        size    => (int 0.5 + $prec * $size   ) / $prec,
                        tag     => $_->{tag},
                        value   => $_->{value} };

      $self->limit and @{ $out } == $self->limit and last;
   }

   return $out;
}

# Private methods begin with _

sub _get_sort_method {
   # Multiple calls to add were made, determine the sorting method
   my $self = shift;

   # No sorting if sort field is false
   my $field = $self->sort_field or return sub { return 0 };

   ref $field and return $field; # User supplied subroutine

   my $orderby = $self->_sorts->{ lc $self->sort_type  }
                              ->{ lc $self->sort_order }->( $field );

   # Protect against wrong sort type for the data
   return $field ne q(tag)
        ? sub { return $orderby->( @_ ) || $_[ 0 ]->{tag} cmp $_[ 1 ]->{tag} }
        : $orderby;
}

__PACKAGE__->meta->make_immutable;

no Moose::Util::TypeConstraints;
no Moose;

1;

__END__

# Local Variables:
# mode: perl
# tab-width: 3
# End: