File Coverage

lib/Data/CloudWeights.pm

Criterion	Covered	Total	%
statement	132	133	99.2
branch	45	68	66.1
condition	10	20	50.0
subroutine	16	16	100.0
pod	2	2	100.0
total	205	239	85.7

package Data::CloudWeights;

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

use Moo;
use POSIX;
use Type::Utils     qw( as enum message subtype where );
use Types::Standard qw( ArrayRef HashRef Int Maybe Num Str );

my $COLOUR     = subtype 'Colour', as Str,
   where { not $_ or $_ =~ m{ \A \# [0-9A-Fa-f]+ \z }mx };
my $SORT_ORDER = enum 'Sort_Order' => [ qw( asc desc      ) ];
my $SORT_TYPE  = enum 'Sort_Type'  => [ qw( alpha numeric ) ];

# Public attributes
has 'cold_colour'    => is => 'ro',   isa => Maybe[$COLOUR],
   documentation     => 'Blue', default => '#0000FF';

has 'hot_colour'     => is => 'ro',   isa => Maybe[$COLOUR],
   documentation     => 'Red', default => '#FF0000';

has 'colour_pallet'  => is => 'lazy', isa => ArrayRef[$COLOUR],
   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 => $SORT_ORDER,
   documentation     => 'Sort order - asc or desc', default => 'asc';

has 'sort_type'      => is => 'rw',   isa => $SORT_TYPE,
   documentation     => 'Sort type - alpha or numeric',
   default           => 'alpha';

has 'total_count'    => is => 'rw',   isa => Int, default => 0,
   documentation     => 'Current total for all tags in the cloud';

# Private attributes
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 { [] };

# Public methods
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 );

   if (not 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 '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
sub _build_colour_pallet {
   my $self = shift;

   # Unsetting hot or cold colour strings in the constructor will cause
   # the default pallet to be used instead
   $self->cold_colour and $self->hot_colour
      and return [ _generate( 12, $self->cold_colour, $self->hot_colour ) ];

   return [ '#CC33FF', '#663399', '#3300CC', '#99CCFF',
            '#00FFFF', '#66FFCC', '#66CC99', '#006600',
            '#CCFF66', '#FFFF33', '#FF6600', '#FF0000' ];
}

sub _generate { # Robbed from Color::Spectrum since it's abandoned
   my ($cnt, $col1, $col2) = @_; $col2 ||= $col1; my @murtceps;

   push @murtceps, uc $col1; my $pound = $col1 =~ /^\#/ ? '#' : q();

   $col1 =~s/^\#//; $col2 =~s/^\#//;

   my $clockwise = 0; $cnt < 0 and $clockwise++; $cnt = int( abs( $cnt ) );

   $cnt <= 1 and return ( wantarray() ? @murtceps : \@murtceps );
   $cnt == 2 and return ( wantarray()
                          ? ( "${pound}${col1}", "${pound}${col2}" )
                          : [ "${pound}${col1}", "${pound}${col2}" ] );

   # The RGB values need to be on the decimal scale,
   # so we divide em by 255 enpassant.
   my ( $h1, $s1, $i1 )
      = _rgb2hsi( map { hex() / 255 } unpack( 'a2a2a2', $col1 ) );
   my ( $h2, $s2, $i2 )
      = _rgb2hsi( map { hex() / 255 } unpack( 'a2a2a2', $col2 ) );

   $cnt--; my $sd = ( $s2 - $s1 ) / $cnt; my $id = ( $i2 - $i1 ) / $cnt;

   my $hd = $h2 - $h1;

   $hd = ( uc( $col1 ) eq uc( $col2 ) )
       ? ( $clockwise ? -1 : 1 ) / $cnt
       : ( ( $hd < 0 ? 1 : 0 ) + $hd - $clockwise) / $cnt;

   while (--$cnt) {
      $s1 += $sd; $i1 += $id; $h1 += $hd;
      $h1 > 1 and $h1 -= 1; $h1 < 0 and $h1 += 1;
      push @murtceps, sprintf "${pound}%02X%02X%02X",
         map { int( $_ * 255 + 0.5 ) } _hsi2rgb( $h1, $s1, $i1 );
   }

   push @murtceps, uc "${pound}${col2}";

   return wantarray() ? @murtceps : \@murtceps;
}

sub _get_sort_method { # Add called multiple times, 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 'tag'
        ? sub { return $orderby->( @_ ) || $_[ 0 ]->{tag} cmp $_[ 1 ]->{tag} }
        : $orderby;
}

sub _rgb2hsi {
   my ( $r, $g, $b ) = @_; my ( $h, $s, $i ) = ( 0, 0, 0 );

   $i = ( $r + $g + $b ) / 3; $i == 0 and return ( $h, $s, $i );

   my $x = $r - 0.5 * ( $g + $b ); my $y = 0.866025403 * ( $g - $b );

   $s = ( $x ** 2 + $y ** 2 ) ** 0.5; $s == 0 and return ( $h, $s, $i );

   $h = POSIX::atan2( $y , $x ) / ( 2 * 3.1415926535 );

   return ( $h, $s, $i );
}

sub _hsi2rgb {
   my ( $h, $s, $i ) =  @_; my ( $r, $g, $b ) = ( 0, 0, 0 );

   # Degenerate cases. If !intensity it's black, if !saturation it's grey
   $i == 0 and return ( $r, $g, $b ); $s == 0 and return ( $i, $i, $i );

   $h = $h * 2 * 3.1415926535;

   my $x = $s * cos( $h ); my $y = $s * sin( $h );

   $r = $i + ( 2 / 3 * $x );
   $g = $i - ( $x / 3 ) + ( $y / 2 / 0.866025403 );
   $b = $i - ( $x / 3 ) - ( $y / 2 / 0.866025403 );
   # Limit 0<=x<=1  ## YUCK but we go outta range without it.
   ( $r, $b, $g ) = map { $_ < 0 ? 0 : $_ > 1 ? 1 : $_ } ( $r, $b, $g );

   return ( $r, $g, $b );
}

1;

__END__