File Coverage

blib/lib/HTML/TagCloud/Sortable.pm
Criterion Covered Total %
statement 70 74 94.5
branch 26 28 92.8
condition n/a
subroutine 8 8 100.0
pod 3 3 100.0
total 107 113 94.6


line stmt bran cond sub pod time code
1             package HTML::TagCloud::Sortable;
2              
3 3     3   27203 use strict;
  3         6  
  3         130  
4 3     3   16 use warnings;
  3         4  
  3         102  
5              
6 3     3   16 use base qw( HTML::TagCloud );
  3         8  
  3         4274  
7              
8             our $VERSION = '0.04';
9              
10             =head1 NAME
11              
12             HTML::TagCloud::Sortable - A sortable HTML tag cloud
13              
14             =head1 SYNOPSIS
15              
16             my $cloud = HTML::TagCloud::Sortable->new;
17            
18             # old HTML::TagCloud style
19             $cloud->add( 'foo', $url, 10 );
20            
21             # new HTML::TagCloud::Sortable style
22             $cloud->add( { name => 'foo', url => $url, count => 10, bar => 'baz' } );
23            
24             # old style
25             print $cloud->html( 4 );
26            
27             # new style
28             print $cloud->html( { limit => 4, sort_field => 'count', sort_type => 'numeric' } );
29              
30             =head1 DESCRIPTION
31              
32             HTML::TagCloud::Sortable is an API-compatible subclass of L.
33             However, by using a different API, you can gain two features:
34              
35             =over 4
36              
37             =item * Store arbitrary data with your tags
38              
39             =item * Sort the tags by any stored field
40              
41             =back
42              
43             =head1 METHODS
44              
45             =head2 new( %options )
46              
47             An overridden construtor. Takes the same arguments as L.
48              
49             =cut
50              
51             sub new {
52 2     2 1 1230 my $self = shift->SUPER::new( @_ );
53 2         37 $self->{ tags } = [];
54 2         6 delete $self->{ urls };
55 2         7 return $self;
56             }
57              
58             =head2 add( \%tagdata )
59              
60             Adds the hashref of data to the list of tags. NB: Insertion order is
61             maintained. At the minimum, you will need to supply C, C and
62             C key-value pairs.
63              
64             =cut
65              
66             sub add {
67 354     354 1 3968 my ( $self, @args ) = @_;
68              
69 354         430 my ( $tag, $count );
70 354 50       524 if ( ref $args[ 0 ] ) {
71 0         0 push @{ $self->{ tags } }, $args[ 0 ];
  0         0  
72 0         0 $tag = $args[ 0 ]->{ name };
73 0         0 $count = $args[ 0 ]->{ count };
74             }
75             else {
76 354         328 my $url;
77 354         461 ( $tag, $url, $count ) = @args;
78 354         340 push @{ $self->{ tags } },
  354         1391  
79             { name => $tag, count => $count, url => $url };
80             }
81              
82 354         1117 $self->{ counts }->{ $tag } = $count;
83             }
84              
85             =head2 tags( \%options )
86              
87             This method is used by C to get the relevant list of tags for display.
88             Options include:
89              
90             =over 4
91              
92             =item * limit - uses the N most popular tags
93              
94             =item * sort_field - sort by this field
95              
96             =item * sort_order - 'asc' or 'desc'
97              
98             =item * sort_type - 'alpha' or 'numeric'
99              
100             =back
101              
102             The default sort order is alphabetically by tag name. You can pass a sub reference
103             to C to do custom sorting. Example:
104              
105             $cloud->html( { sort_field =>
106             sub { $_[ 1 ]->{ count } <=> $_[ 0 ]->{ count }; }
107             } );
108              
109             Passing undef to sort_field will maintain insertion order.
110              
111             =cut
112              
113             my %sorts = (
114             alpha => {
115             asc => sub {
116             my $f = shift;
117             return sub { $_[ 0 ]->{ $f } cmp $_[ 1 ]->{ $f } }
118             },
119             desc => sub {
120             my $f = shift;
121             return sub { $_[ 1 ]->{ $f } cmp $_[ 0 ]->{ $f } }
122             },
123             },
124             numeric => {
125             asc => sub {
126             my $f = shift;
127             return sub { $_[ 0 ]->{ $f } <=> $_[ 1 ]->{ $f } }
128             },
129             desc => sub {
130             my $f = shift;
131             return sub { $_[ 1 ]->{ $f } <=> $_[ 0 ]->{ $f } }
132             },
133             },
134             );
135              
136             sub tags {
137 10     10 1 9079 my ( $self, @args ) = @_;
138              
139 10         13 my %options;
140 10 100       31 if ( defined $args[ 0 ] ) {
141 9 100       24 if ( !ref $args[ 0 ] ) {
142 6         14 $options{ limit } = shift @args;
143             }
144             else {
145 3         6 %options = %{ $args[ 0 ] };
  3         11  
146             }
147             }
148              
149 10 100       36 $options{ sort_field } = 'name' if !exists $options{ sort_field };
150 10 100       43 $options{ sort_type } = 'alpha' if !$options{ sort_type };
151 10 100       26 $options{ sort_order } = 'asc' if !$options{ sort_order };
152              
153 10         13 my ( @tags, @counts );
154              
155 10 100       25 if ( defined( my $limit = $options{ limit } ) ) {
156 13887         17442 my @sorted = ( sort { $b->{ count } <=> $a->{ count } }
157 9         11 @{ $self->{ tags } } );
  9         88  
158 9         35 my %top = map { $_->{ name } => $_->{ count } }
  42         118  
159             splice( @sorted, 0, $limit );
160 9         39 @counts = ( sort { $b <=> $a } values %top );
  87         95  
161 9         16 @tags = grep { exists $top{ $_->{ name } } } @{ $self->{ tags } };
  2109         4618  
  9         27  
162             }
163             else {
164 1         2 @tags = @{ $self->{ tags } };
  1         30  
165 2312         3162 @counts = ( sort { $b->{ count } <=> $a->{ count } }
166 1         3 @{ $self->{ tags } } );
  1         7  
167             }
168              
169 10 100       48 return unless scalar @tags;
170              
171 9         49 my $min = log( $counts[ -1 ] );
172 9         15 my $max = log( $counts[ 0 ] );
173 9         15 my $factor;
174              
175             # special case all tags having the same count
176 9 100       33 if ( $max - $min == 0 ) {
177 1         3 $min = $min - $self->{ levels };
178 1         2 $factor = 1;
179             }
180             else {
181 8         25 $factor = $self->{ levels } / ( $max - $min );
182             }
183              
184 9 100       29 if ( scalar @tags < $self->{ levels } ) {
185 8         24 $factor *= ( scalar @tags / $self->{ levels } );
186             }
187              
188 9 50       30 if ( my $sort = $options{ sort_field } ) {
189              
190 9 100       24 if ( !ref $sort ) {
191             my $newsort = $sorts{ lc $options{ sort_type } }
192 8         141 { lc $options{ sort_order } }->( $sort );
193             $sort = $sort ne 'name'
194             ? sub {
195 5 100   5   7 $newsort->( @_ ) || $_[ 0 ]->{ name } cmp $_[ 1 ]->{ name };
196             }
197 8 100       49 : $newsort;
198             }
199              
200 9         34 my $oldsort = $sort;
201 9     391   33 $sort = sub { $oldsort->( $a, $b ); };
  391         562  
202 9         31 @tags = sort $sort @tags;
203             }
204              
205 9         20 for my $tag ( @tags ) {
206 391         772 $tag->{ level } = int( ( log( $tag->{ count } ) - $min ) * $factor );
207             }
208              
209 9         188 return @tags;
210             }
211              
212             =head1 AUTHOR
213              
214             Brian Cassidy Ebricas@cpan.orgE
215              
216             =head1 COPYRIGHT AND LICENSE
217              
218             Copyright 2007-2009 by Brian Cassidy
219              
220             This library is free software; you can redistribute it and/or modify
221             it under the same terms as Perl itself.
222              
223             =head1 SEE ALSO
224              
225             =over 4
226              
227             =item * L
228              
229             =back
230              
231             =cut
232              
233             1;