File Coverage

blib/lib/HTML/BarGraph.pm
Criterion Covered Total %
statement 9 269 3.3
branch 0 184 0.0
condition 0 79 0.0
subroutine 3 24 12.5
pod 2 21 9.5
total 14 577 2.4


line stmt bran cond sub pod time code
1             package HTML::BarGraph;
2              
3 1     1   655 use strict;
  1         2  
  1         27  
4              
5 1     1   3 use Exporter;
  1         2  
  1         31  
6              
7 1     1   4 use vars qw($VERSION @ISA @EXPORT);
  1         3  
  1         3306  
8              
9             $VERSION = 0.5;
10              
11             @ISA = qw(Exporter);
12             @EXPORT = qw(graph);
13              
14             ### general characteristics of the graphic, used by some subroutines
15             my ($maxidx, $maxval, $hlttype, $hlttab);
16              
17             sub graph {
18 0     0 0   my %args;
19 0 0         if (scalar(@_) % 2 == 0) {
    0          
20 0           %args = @_;
21             }
22             elsif (ref $_[0] eq 'HASH') {
23 0           %args = %{$_[0]};
  0            
24             }
25             else {
26 0           warn "odd number of arguments\n";
27 0           return;
28             }
29              
30 0 0         check_args(\%args) or return;
31              
32 0           ($hlttype, $hlttab) = highlight(\%args);
33              
34 0           set_colors(\%args);
35              
36             #use Data::Dumper;
37             #print Dumper(\%args);
38              
39              
40             ### output the HTML
41 0           my $html;
42 0           $html .= table_header(\%args);
43              
44 0           $html .= title_layer(\%args);
45              
46 0 0         $html .= spacing_layer(\%args) if $args{direction} eq 'h';
47              
48              
49              
50 0 0         $html .= ylabel(\%args) if $args{ylabel};
51              
52             ### the graph layer
53 0 0         if ($args{direction} eq 'v') {
    0          
54 0           $html .= graph_v(\%args);
55             }
56             elsif ($args{direction} eq 'h') {
57 0           $html .= graph_h_first(\%args);
58             }
59              
60              
61 0 0         if ($args{direction} eq 'v') {
    0          
62 0 0         $html .= axis_values_y(\%args) if $args{showaxistags};
63             }
64             elsif ($args{direction} eq 'h') {
65 0           $html .= graph_h_rest(\%args);
66             }
67              
68              
69              
70 0 0         $html .= spacing_layer(\%args) if $args{direction} eq 'h';
71              
72 0 0         $html .= xlabel(\%args) if $args{xlabel};
73              
74 0           $html .= table_footer(\%args);
75              
76 0           return $html;
77             }
78              
79              
80              
81              
82              
83              
84             sub check_args {
85 0     0 0   my $args = shift;
86              
87             ### required params
88 0 0         unless (ref($args->{data}) eq 'ARRAY') {
89 0           warn "value of 'data' has to be an arrayref\n";
90 0           return;
91             }
92 0 0 0       if (exists($args->{tags}) and ref($args->{tags}) ne 'ARRAY') {
93 0           warn "value of 'tags' has to be an arrayref\n";
94 0           return;
95             }
96              
97              
98             ### put the data in a format that can be used in the same way for
99             ### single and multiple data sets (ie a list of arrayrefs)
100 0 0         if (ref($args->{data}->[0]) eq '') {
101 0           my $tmp = $args->{data};
102 0           $args->{data} = [ $tmp ];
103             }
104              
105 0           my $datasets = scalar(@{$args->{data}});
  0            
106              
107             ### get the max value for graf size
108 0           foreach my $set (@{$args->{data}}) {
  0            
109 0           foreach (@$set) {
110 0 0         $maxval = $_ if $maxval < $_;
111             }
112 0           my $t = scalar(@$set);
113 0 0         $maxidx = $t if $maxidx < $t;
114             }
115 0 0         unless ($maxidx) {
116 0           warn "no non-null values in the data sets?\n";
117 0           return;
118             }
119 0   0       $maxval ||= 1; ### to avoid division by zero below
120              
121             ### check to have tags at least as longest data set
122 0 0 0       if ($args->{tags} and scalar(@{$args->{tags}}) < $maxidx) {
  0            
123 0           warn "the 'data' set has more elements than the 'tags' set\n";
124 0           return;
125             }
126              
127             ### defaults
128             # if ($args->{graphminsize} and $args->{barlength}) {
129             # my $factor;
130             # $factor = 1.5 if $args->{showaxistags} or $args->{showvalues};
131             # $factor = 2.0 if $args->{showaxistags} and $args->{showvalues};
132             #
133             # $args->{graphminsize} = int($args->{barlength} * $factor)
134             # if $args->{graphminsize} < int($args->{barlength} * $factor);
135             # }
136 0 0         $args->{graphminsize} = undef if $args->{barlength};
137              
138 0   0       $args->{direction} ||= 'h';
139 0   0       $args->{bartype} ||= 'html';
140 0   0       $args->{baraspect} ||= .05;
141 0   0       $args->{barlength} ||= 100;
142 0   0       $args->{barwidth} ||= int($args->{barlength} * $args->{baraspect}) || 1;
      0        
143 0   0       $args->{fontface} ||= 'TimesRoman';
144 0   0       $args->{color} ||= 'blue';
145 0   0       $args->{highlightcolor} ||= 'red';
146 0   0       $args->{pixelfmt} ||= 'PNG';
147 0 0         $args->{addalt} = 1 unless exists($args->{addalt});
148 0 0         $args->{showaxistags} = 1 unless exists($args->{showaxistags});
149 0 0         $args->{showvalues} = 1 unless exists($args->{showvalues});
150 0 0         $args->{setspacer} = 1 unless exists($args->{setspacer});
151              
152              
153 0 0         $args->{direction} = 'h' if $args->{direction} eq '-';
154 0 0         $args->{direction} = 'v' if $args->{direction} eq '|';
155 0 0         if ($args->{bordertype}) {
156 0 0         if ($args->{bordertype} eq 'flat') {
    0          
157 0   0       $args->{bordercolor} ||= 'black';
158 0   0       $args->{borderwidth} ||= 3;
159             }
160             elsif ($args->{bordertype} eq 'reised') {
161 0   0       $args->{borderwidth} ||= 1;
162             }
163             }
164              
165              
166 0   0       $args->{titlealign} ||= 'center';
167 0   0       $args->{xlabelalign} ||= 'center';
168 0   0       $args->{ylabelalign} ||= 'middle';
169              
170 0   0       $args->{bgcolor} ||= 'white';
171 0   0       $args->{textcolor} ||= 'black';
172 0   0       $args->{titlecolor} ||= $args->{textcolor};
173 0   0       $args->{labelbgcolor} ||= $args->{bgcolor};
174              
175              
176              
177             ### set some values that make sense only in some conditions
178 0 0         $args->{showaxistags} = undef unless $args->{tags};
179 0 0 0       $args->{highlighttag} = undef unless $datasets == 1 and $args->{tags};
180 0 0         $args->{highlightpos} = undef unless $datasets == 1;
181 0 0         $args->{setspacer} = undef if $datasets == 1;
182 0 0 0       $args->{colors} = undef if exists($args->{colors}) and
183             ref($args->{colors}) ne 'ARRAY';
184 0 0         $args->{valuesuffix} = undef unless $args->{showvalues};
185 0 0         $args->{valueprefix} = undef unless $args->{showvalues};
186 0 0         $args->{pixelfmt} = undef if $args->{bartype} eq 'html';
187 0 0         $args->{addalt} = undef if $args->{bartype} eq 'html';
188              
189 0           1;
190             }
191              
192              
193             sub highlight {
194 0 0   0 0   my $args = shift or return;
195              
196 0           $hlttype = 0; ### 0 - none, 1 - tag based, 2 - position based highlight
197 0           $hlttab = {}; ### lookup table for tag- or position-based highlighting
198              
199            
200 0 0 0       if ($args->{tags} and $args->{highlighttag}) {
201 0 0         if (ref($args->{highlighttag}) eq 'ARRAY') { ### multi value highlight
    0          
202 0           $hlttab = { map { ($_,1) } @{$args->{highlighttag}} };
  0            
  0            
203 0           $hlttype = 1;
204             }
205             elsif (ref($args->{highlighttag}) eq '') { ### single value highlight
206 0           $hlttab->{$args->{highlighttag}}++;
207 0           $hlttype = 1;
208             }
209             }
210            
211 0 0         unless (scalar keys %$hlttab) { ### check the other possibility
212 0 0         if (ref($args->{highlightpos}) eq 'ARRAY') { ### multi value highlight
    0          
213 0           $hlttab = { map { ($_,1) } @{$args->{highlightpos}} };
  0            
  0            
214 0           $hlttype = 2;
215             }
216             elsif (ref($args->{highlightpos}) eq '') { ### single value highlight
217 0           $hlttab->{$args->{highlightpos}}++;
218 0           $hlttype = 2;
219             }
220             }
221              
222 0           return ($hlttype, $hlttab);
223             }
224            
225              
226             sub is_highlighted {
227 0     0 0   my ($args, $index) = @_;
228 0 0         return unless defined $index;
229              
230 0 0         if ($hlttype == 1) { ### tag-based highlighting
    0          
231 0           return $hlttab->{$args->{tags}->[$index]};
232             }
233             elsif ($hlttype == 2) {
234 0           return $hlttab->{$index+1};
235             }
236             }
237              
238              
239              
240             sub set_colors {
241 0     0 0   my $args = shift;
242              
243 0           my $datasets = scalar(@{$args->{data}});
  0            
244 0 0         if ($datasets == 1) {
245 0 0         $args->{colors} = [ $args->{color} ] unless $args->{colors};
246             }
247             else {
248 0           my $colors = scalar(@{$args->{colors}});
  0            
249 0 0 0       if (exists($args->{colors}) and $colors) {
250 0 0         if ($colors < $datasets) { ### loop through the colors
251 0           for (1 .. int($datasets/$colors)) {
252 0           push(@{$args->{colors}}, @{$args->{colors}});
  0            
  0            
253             }
254             }
255             }
256             else {
257 0           $args->{colors} = [ ($args->{color}) x $datasets ];
258             }
259             }
260             }
261              
262              
263              
264              
265             sub table_header {
266 0 0   0 0   my $args = shift or return;
267              
268 0           my $html = "\n\n";
269 0 0         if ($args->{bordertype} eq 'flat') {
    0          
270 0           $html .= <<"ENDOFHTML";
271             {bgcolor}\">\n"; \n" if $args->{ylabel}; {bgcolor}\">\n"; \n" if $args->{ylabel}; \n" if $args->{showaxistags}; \n"; \n"; \n|; \n| if $args->{ylabel}; \n| if $args->{direction} eq 'v' or \n| if $args->{direction} eq 'v'; \n|; {bgcolor}\">\n"; \n" if $args->{ylabel}; \n"; \n"; \n"; \n|; \n|; {barwidth}>\n| {bgcolor}\">\n" unless $args->{ylabel}; \n"; \n";
272            
273            
274             ENDOFHTML
275             }
276             elsif ($args->{bordertype} eq 'reised') {
277 0           $html .= <<"ENDOFHTML";
278            
279            
280            
281             ENDOFHTML
282             }
283              
284 0 0 0       my $msz = "width=$args->{graphminsize} "
285             if $args->{direction} eq 'h' and $args->{graphminsize};
286              
287 0           $html .= "
288             "bgcolor=\"$args->{bgcolor}\">\n";
289              
290 0           return $html;
291             }
292              
293              
294              
295             sub table_footer {
296 0 0   0 0   my $args = shift or return;
297              
298 0           my $html = "
\n";
299              
300 0 0         if ($args->{bordertype}) {
301 0           $html .= <<"ENDOFHTML";
302            
303            
304            
305             ENDOFHTML
306             }
307              
308 0           $html .= "\n\n";
309              
310 0           return $html;
311             }
312              
313              
314             sub title_layer {
315 0 0   0 0   my $args = shift or return;
316              
317 0 0         return unless $args->{title};
318              
319 0           my $html = "
320 0 0         $html .= " {bgcolor}\">
321 0 0         my $colspan = $args->{direction} eq 'v' ? $maxidx+2 : 1;
322 0 0 0       $colspan++ if $args->{showaxistags} and $args->{direction} eq 'h';
323 0           $html .= <<"ENDOFHTML";
324            
325             $args->{title}
326            
327            
328             ENDOFHTML
329              
330 0           return $html;
331             }
332              
333              
334             sub spacing_layer {
335 0 0   0 0   my $args = shift or return;
336              
337 0           my $html .= "
338 0 0         $html .= "
339 0 0         $html .= "
340 0           $html .= "
341 0           $html .= "
342              
343 0           return $html;
344             }
345              
346              
347              
348             sub ylabel {
349 0 0   0 1   my $args = shift or return;
350              
351 0 0         my $rowspan = $args->{direction} eq 'h' ? $maxidx+1 : 1;
352 0           my $ylabelhtml = join(' 
 ', split(//, $args->{ylabel}));
353              
354 0           my $html =<<"ENDOFHTML";
355            
356            
357            
358              $ylabelhtml 
359            
360            
361             ENDOFHTML
362              
363 0           return $html;
364             }
365              
366              
367              
368             sub xlabel {
369 0 0   0 1   my $args = shift or return;
370              
371 0 0         my $colspan = $args->{direction} eq 'v' ? $maxidx+1 : 1;
372 0           my $xlabelhtml = join(' ', split(//, $args->{xlabel}));
373              
374 0           my $html = qq|
375 0 0         $html .= qq|
376 0 0 0       $html .= qq|
      0        
377             ($args->{direction} eq 'h' and
378             $args->{showaxistags});
379 0           $html .=<<"ENDOFHTML";
380            
381            
382             $xlabelhtml
383            
384            
385             ENDOFHTML
386 0 0         $html .= qq|
387 0           $html .= qq|
388              
389 0           return $html;
390             }
391              
392              
393              
394             sub axis_value_x {
395 0     0 0   my ($args, $i) = @_;
396 0 0         return unless defined $i;
397              
398 0           my $k = $args->{tags}->[$i];
399              
400 0           my $html =<<"ENDOFHTML";
401            
402            
403             $k
404            
405            
406             ENDOFHTML
407              
408 0           return $html;
409             }
410              
411              
412             sub axis_values_y {
413 0 0   0 0   my $args = shift or return;
414              
415 0           my $html;
416 0           $html .= "
417 0 0         $html .= "
418 0           $html .= "
419              
420 0           foreach my $i (0 .. $maxidx-1) {
421 0           my $k = $args->{tags}->[$i];
422 0           $html .=<<"ENDOFHTML";
423            
424             $k
425            
426             ENDOFHTML
427             }
428              
429 0           $html .= "
430              
431 0           return $html;
432             }
433              
434              
435              
436             sub draw_bar {
437 0     0 0   my ($x, $y, $color, $curval, $pixdir, $pixfmt, $addalt) = @_;
438              
439             # $color = 'transparent' unless $x and $y;
440             # ### draw a transparent bar of 1 pixel length
441 0   0       $x ||= 1; $y ||= 1;
  0   0        
442              
443              
444 0           my $html;
445 0 0         if ($pixfmt) { ### ie bartype is 'pixel'
446 0           $pixfmt = lc($pixfmt);
447            
448 0           $html .= qq| |;
449             # $html .= qq|| if $addalt;
450 0           $html .= qq|
451 0 0         $html .= qq| border=0 alt="$curval"| if $addalt;
452 0           $html .= qq|>|;
453             # $html .= qq|| if $addalt;
454 0           $html .= qq|\n|;
455             }
456             else { ### ie bartype is 'html'
457 0 0         my $align = $x <= $y ? 'center' : 'left';
458 0 0         my $tdalign = $x <= $y ? 'align="center" valign="bottom"'
459             : 'align="left" valign="middle"';
460 0           $html =<<"EOFHMTML";
461            
462            
463            
 
464             EOFHMTML
465             }
466              
467 0           return $html;
468             }
469              
470              
471              
472             sub field {
473 0     0 0   my ($args, $v, $i, $j, $dir) = @_;
474              
475 0 0         return unless defined $v;
476              
477 0           my $vshow = join('', $args->{valueprefix}, $v, $args->{valuesuffix});
478              
479 0 0         my $color = is_highlighted($args, $i) ? $args->{highlightcolor}
480             : $args->{colors}->[$j];
481              
482 0           my ($align, $barx, $bary, $html);
483 0 0         if ($dir eq 'v') {
484 0           $align = 'align="center"';
485 0           $barx = $args->{barwidth};
486 0           $bary = int($args->{barlength} * ($v/$maxval));
487              
488 0 0         $html .=<<"ENDOFHTML" if $args->{showvalues};
489            
490             $vshow
491            
492             ENDOFHTML
493 0           $html .= draw_bar($barx, $bary, $color, $v,
494             $args->{pixeldir}, $args->{pixelfmt}, $args->{addalt});
495             }
496             else {
497 0           $align = 'valign="middle"';
498 0           $barx = int($args->{barlength} * ($v/$maxval));
499 0           $bary = $args->{barwidth};
500              
501 0           $html .= draw_bar($barx, $bary, $color, $v,
502             $args->{pixeldir}, $args->{pixelfmt}, $args->{addalt});
503 0 0         $html .=<<"ENDOFHTML" if $args->{showvalues};
504            
505             $vshow
506            
507             ENDOFHTML
508             }
509              
510 0           return "$html\n";
511             }
512              
513              
514              
515             sub multiset_h {
516 0     0 0   my ($args, $i) = @_;
517              
518 0           my $html = " \n";
519              
520 0           my $j;
521 0           foreach my $set (@{$args->{data}}) {
  0            
522 0           $html .= field($args, $set->[$i], $i, $j++, 'h', $maxval) . "\n
\n";
523             }
524              
525 0           $html .= "
526              
527 0           return $html;
528             }
529              
530              
531             sub multiset_v {
532 0     0 0   my ($args, $i) = @_;
533              
534 0           my $html;
535             my $j;
536 0           foreach my $set (@{$args->{data}}) {
  0            
537 0           $html .=<<"ENDOFHTML";
538            
539             ENDOFHTML
540 0           $html .= field($args, $set->[$i], $i, $j, 'v', $maxval);
541              
542 0           $html .=<<"ENDOFHTML";
543            
544             ENDOFHTML
545 0           $j++;
546             }
547              
548 0           return $html;
549             }
550              
551              
552              
553             sub graph_h_first {
554 0 0   0 0   my $args = shift or return;
555              
556 0           return graph_h($args, [ 0 ]);
557             }
558              
559              
560             sub graph_h_rest {
561 0 0   0 0   my $args = shift or return;
562              
563 0           return graph_h($args, [ 1 .. $maxidx-1 ]);
564             }
565              
566              
567             sub graph_h {
568 0     0 0   my ($args, $range) = @_;
569              
570 0           my $html;
571 0           foreach my $i (@$range) {
572 0           $html .= qq|
573              
574 0 0         $html .= axis_value_x($args, $i) if $args->{showaxistags};
575              
576             ### the values from multiple sets are represented as columns,
577             ### included in a table
578 0           $html .= multiset_h($args, $i);
579              
580 0           $html .= qq|
581              
582 0 0         $html .= qq|
583             if $args->{setspacer};
584             }
585              
586 0           return $html;
587             }
588              
589              
590              
591             sub graph_v {
592 0 0   0 0   my $args = shift or return;
593              
594             ### the spacing column for v
595 0           my $html;
596 0 0         $html .= "
597 0           $html .= "
598              
599             ### the multiset graph v
600 0           foreach my $i (0 .. $maxidx-1) {
601 0           $html .=<<"ENDOFHTML";
602            
603             \n|
604            
605             ENDOFHTML
606              
607             ### the values from multiple sets are represented as columns,
608             ### included in a table
609 0           $html .= multiset_v($args, $i);
610              
611 0 0         $html .= qq| {barwidth}>
612             if $args->{setspacer};
613              
614 0           $html .=<<"ENDOFHTML";
615            
616            
617            
618             ENDOFHTML
619             }
620              
621             ### the spacing column for v
622 0           $html .= "
623              
624 0           return $html;
625             }
626              
627              
628              
629             1;
630              
631             __END__