File Coverage

lib/HTML/TagCloud/Centred.pm

Criterion	Covered	Total	%
statement	169	183	92.3
branch	40	64	62.5
condition	15	23	65.2
subroutine	26	26	100.0
pod	0	5	0.0
total	250	301	83.0

line	stmt	bran	cond	sub	pod	time	code
1	1			1		22477	use strict;
	1					3
	1					43
2	1			1		5	use warnings;
	1					2
	1					205
3
4							=head1 NAME
5
6							HTML::TagCloud::Centred - Biggest tags in the centre
7
8							=head1 SYNOPSIS
9
10							use HTML::TagCloud::Centred;
11							my $cloud = HTML::TagCloud::Centred->new(
12							# size_min_pc => 50,
13							# size_max_pc => 200,
14							# scale_code => sub { ... },
15							# html_esc_code => sub { ... },
16							# clr_max => '#FF0000',
17							# clr_min => '#550000',
18							);
19							$cloud->add( 'FirstWord', 'http://www.google.co.uk' );
20							foreach my $w (
21							('Biggest')x7, ('Medium')x5, ('Small')x5, ('Smallest')x10
22							){
23							$cloud->add( $w );
24							}
25							open my $OUT, '>cloud.html';
26							# print $OUT $cloud->css;
27							# print $OUT $cloud->html;
28							print $OUT $cloud->html_and_css;
29							close $OUT;
30							warn 'Tags: ',Dumper $cloud->tags;
31							exit;
32
33							=head1 DESCRIPTION
34
35							This modules produces a tag cloud with the heaviest words in the centre,
36							and the lightest on the outside, to make it appear a bit like the clouds
37							seen in the sky.
38
39							Words are accepted through L in a sorted order - that is,
40							add the heaviest word first, the lightest last. When the C or C
41							methods are called, the words are added to a grid in a simple spiral: this may
42							change to produce a prettier cloud, but it works well enough as it is.
43
44							Otherwise, it is API-compatible with L, though
45							that module is not required. For further details of this modules methods,
46							please see L.
47
48							=head2 OUTPUT
49
50							Output is HTML and/or CSS. The HTML contains a C of class C,
51							that contains one or more C of class C. Each row contains
52							C elements for each linked word. If words were supplied without links,
53							they are contained in C elements.
54
55							Colouring and font-sizing is contained in the C and C C\n";
170							}
171
172							sub html {
173	3			3	0	376	my $self = shift;
174	3	50				8	$self->{limit} = $_[0] if $_[0];
175
176	3					3	my $out = "\n ";
177	3					5	my $blank = quotemeta BLANK;
178	3					38	my $re = qr/^\s$blank+\s$/;
179
180	3					10	$self->_build;
181
182	3					6	for my $y (1..$self->{size_y} ){
183	18					20	my $row = '';
184	18					26	for my $x (1..$self->{size_x} ){
185	108	100	66			563	next if not defined $self->{grid}->[$x-1]->[$y-1]
186							or $self->{grid}->[$x-1]->[$y-1] eq BLANK;
187	90					176	$row .= "\t" . $self->{grid}->[$x-1]->[$y-1]->html ."\n";
188							}
189	18	100	66			126	$out .= "\n \n" . $row . " \n"
190							unless $row eq '' or $row =~ /$re/s;
191							}
192
193	3					4	$out .= "\n";
194	3					33	return $out;
195							}
196
197							# Move into sub html
198							sub tags {
199	1			1	0	1	my $self = shift;
200	1	50				5	$self->{limit} = $_[0] if $_[0];
201	1	50				3	$self->_build unless $self->{inputs};
202	1					4	my $c = 0;
203
204	1					3	my $t = scalar( @{ $self->{words} } );
	1					2
205	1					2	my @rv;
206	1					2	my $blank = quotemeta BLANK;
207	1					19	my $re = qr/^$blank+$/;
208	1					3	for my $y (1..$self->{size_y} ){
209	6					11	for my $x (1..$self->{size_x} ){
210	36	100	66			162	next if not defined $self->{grid}->[$x-1]->[$y-1]
211							or $self->{grid}->[$x-1]->[$y-1] eq BLANK;
212	30					43	my $w = $self->{grid}->[$x-1]->[$y-1];
213	30					175	push @rv, {
214							%$w,
215							count => $t - $c,
216							level => $c,
217							};
218	30					55	$c ++;
219							}
220							}
221
222	1					9	return @rv;
223							}
224
225
226							sub _prepare {
227	3			3		5	my $self = shift;
228	3					8	die "No words from which to create a cloud - see add(...)."
229	3	50	50			10	unless $self->{words} and scalar @{ $self->{words} };
230
231							# Custom size does not work yet
232							#if (not $self->{size_x} and not $self->{size_y}){
233	3					3	$self->{size_y} = $self->{size_x} = int( sqrt(scalar @{$self->{words}})) +1;
	3					17
234							#}
235
236	3					3	$self->{inputs} = [@{ $self->{words} }];
	3					34
237	3					7	$self->{grid} = [];
238	3					10	$self->{tags} = []; # HTML::TagCloud API
239
240	3		100			12	$self->{size_max_pc} \|\|= 120;
241	3		66			11	$self->{size_min_pc} \|\|= $self->{size_max_pc} / 2;
242
243							$self->{scale_code} \|\|= sub {
244	3			3		5	($self->{size_max_pc} - $self->{size_min_pc}) / scalar @{$self->{words}};
	3					8
245	3		100			12	};
246
247	3					6	$self->{scale_f} = $self->{scale_code}->($self);
248
249	3					7	for my $y (1..$self->{size_y}){
250	18					23	$self->{grid}->[$y-1] = [];
251	18					21	for my $x (1..$self->{size_x}){
252	108					148	$self->{grid}->[$y-1]->[$x-1] = BLANK;
253							}
254							}
255
256							# If inputs supplied as words:
257	3					3	foreach my $w (@{ $self->{inputs} } ){
	3					6
258	90	50				145	if (not ref $w){
259	0					0	$w = new HTML::TagCloud::Centred::Word( %$w );
260	0	0				0	$w->{html_esc_code} = $self->{html_esc_code} if $self->{html_esc_code};
261							}
262							}
263
264							# For API of HTML::TagCloud
265	3	50				8	if (exists $self->{limit}){
266	0					0	$self->{inputs} = [
267	0					0	@{ $self->{inputs} } [ 0 .. $self->{limit} -1 ]
268							];
269							}
270
271	3					5	return $self;
272							}
273
274
275							# Naive spiral - 1,1,2,2,3,3,..N,N. Replace!
276							sub _build {
277	3			3		4	my $self = shift;
278	3					7	$self->_prepare;
279	3					5	my $x = int ($self->{size_x} / 2); # Centre starting position
280	3					5	my $y = int ($self->{size_y} / 2); # Centre starting position
281	3					14	my @d = ( # Direction of turns
282							[1, 0],
283							[0, 1],
284							[-1, 0],
285							[0, -1]
286							);
287	3					4	my $tside = 0; # Total sides so far
288	3					4	my $cside = 0; # Current side, index to @d
289	3					5	my $length = 1; # Length of current side
290
291	3					3	my @clrs; # Color palette if requested
292	3	50				6	if ($Color::Spectrum::VERSION){
293	0					0	@clrs = Color::Spectrum::generate(
294	0					0	scalar( @{ $self->{inputs} } ),
295							$self->{clr_max},
296							$self->{clr_min}
297							);
298							}
299
300	3					9	while (@{ $self->{inputs} } ){
	33					81
301	30					41	my $add_x = ($length * $d[ $cside ]->[0] );
302	30					33	my $add_y = ($length * $d[ $cside ]->[1] );
303
304	30	50				83	$self->_create_side(
305							from_x => $x,
306							from_y => $y,
307							to_x => $x + $add_x,
308							to_y => $y + $add_y,
309							(@clrs? (clrs => \@clrs) : ()),
310							);
311
312	30					41	$x += $add_x;
313	30					26	$y += $add_y;
314
315	30					83	DEBUG "For $tside $cside, X $x, Y $y \n\tadd to x $add_x; add to y $add_y \n";
316
317							# Increase length every second side
318	30	100				74	$length += 1 if $cside % 2;
319
320							# Next side
321	30	100				48	if (++$cside == 4){
322	6					9	$cside = 0;
323							}
324
325	30					30	$tside++;
326							}
327							}
328
329							sub _create_side {
330	30	50		30		108	my ($self, $args) = (shift, ref($_[0])? shift : {@_});
331	30					42	my ($from_x, $from_y, $to_x, $to_y);
332
333	30	100				52	if ($args->{from_x} > $args->{to_x}){
334	6					7	$from_x = $args->{to_x};
335	6					7	$to_x = $args->{from_x};
336							} else {
337	24					27	$from_x = $args->{from_x};
338	24					28	$to_x = $args->{to_x};
339							}
340
341	30	100				45	if ($args->{from_y} > $args->{to_y}){
342	6					6	$from_y = $args->{to_y};
343	6					7	$to_y = $args->{from_y};
344							} else {
345	24					26	$from_y = $args->{from_y};
346	24					27	$to_y = $args->{to_y};
347							}
348
349	30					78	DEBUG "From X $from_x -> $to_x;From Y $from_y -> $to_y";
350							WORDS:
351	30					50	for my $x ($from_x .. $to_x){
352	75					87	for my $y ($from_y .. $to_y){
353							# TRACE $x-1, ', ', $y-1;
354	120	50				234	next if not $self->{grid}->[ $x-1 ]->[ $y-1 ];
355	120	100				280	next if $self->{grid}->[ $x-1 ]->[ $y-1 ] ne BLANK;
356	93	100				82	last WORDS if not @{ $self->{inputs} };
	93					186
357	90					78	my $word = shift @{ $self->{inputs} };
	90					116
358	90					237	DEBUG " set $x $y = $word->{name}";
359	90	50				169	$word->{clr} = $args->{clr} if $args->{clr};
360	90					102	$word->{x} = $x-1;
361	90					101	$word->{y} = $y-1;
362	90					100	$word->{size} = int $self->{size_min_pc} + ( $self->{scale_f} * (1 + scalar @{ $self->{inputs} }));
	90					152
363	90	50				155	$word->{clr} = shift( @{$args->{clrs}}) if $args->{clrs};
	0					0
364	90					219	$self->{grid}->[ $x-1 ]->[ $y-1 ] = $word;
365							}
366							}
367							}
368
369
370							package HTML::TagCloud::Centred::Word;
371	1			1		6	use base 'HTML::TagCloud::Centred::Base';
	1					2
	1					624
372
373							sub _init {
374	30			30		29	my $self = shift;
375							$self->{html_esc_code} \|\|= sub {
376	90	50		90		1220	if (require CGI::Util){ return CGI::Util::escape(shift)}
	90					4608
377	0					0	return shift;
378	30		50			148	};
379	30	50				74	die "No 'name'?" if not defined $self->{name};
380							}
381
382							sub html {
383	90			90		83	my $self = shift;
384	90					86	my $ctag = 'span';
385	90					77	my $otag = $ctag;
386	90					234	my $name = $self->{html_esc_code}->( $self->{name} );
387	90	100				703	if (defined $self->{url}){
388	6					6	$ctag = 'a';
389	6					14	$otag = "a href='$self->{url}' title='$name'";
390							}
391	90	50				142	my $clr = defined($self->{clr})? 'color:'.$self->{clr} : '';
392	90					332	return "<$otag style='$clr; font-size:$self->{size}%'>$name";
393							}
394
395							1;
396
397							=head1 SEE ALSO
398
399							L.
400
401							=head1 AUTHOR AND COPYRIGHT
402
403							Copyright (C) Lee Goddard, 2010-2011. All Rights Reserved.
404
405							This distribution is made available under the same terms as Perl.
406
407