File Coverage

blib/lib/SVG/Sparkline/Whisker.pm
Criterion Covered Total %
statement 103 103 100.0
branch 32 34 94.1
condition 5 8 62.5
subroutine 14 14 100.0
pod 2 2 100.0
total 156 161 96.8


line stmt bran cond sub pod time code
1             package SVG::Sparkline::Whisker;
2              
3 13     13   17197 use warnings;
  13         21  
  13         464  
4 13     13   59 use strict;
  13         14  
  13         418  
5 13     13   56 use Carp;
  13         21  
  13         836  
6 13     13   660 use SVG;
  13         13036  
  13         86  
7 13     13   12499 use SVG::Sparkline::Utils;
  13         46  
  13         354  
8              
9 13     13   514 use 5.008000;
  13         42  
  13         15338  
10             our $VERSION = 1.11;
11              
12             # alias to make calling shorter.
13             *_f = *SVG::Sparkline::Utils::format_f;
14              
15             sub valid_param {
16 5     5 1 6 return scalar grep { $_[1] eq $_ } qw/gap thick/;
  10         41  
17             }
18              
19             sub make
20             {
21 36     36 1 44 my ($class, $args) = @_;
22             # validate parameters
23 36         35 my @values;
24 36 100       135 croak "Missing required 'values'\n" unless exists $args->{values};
25 35 100       118 if( 'ARRAY' eq ref $args->{values} )
    100          
26             {
27 11         8 @values = @{$args->{values}};
  11         27  
28             }
29             elsif( !ref $args->{values} )
30             {
31 23         27 my $valstr = $args->{values};
32             # Convert 1/0 string to a +/- string.
33 23 100       59 $valstr =~ tr/10/+-/ if $valstr =~ /1/;
34              
35 23         96 @values = split //, $valstr;
36             }
37             else
38             {
39 1         10 croak "Unrecognized type of 'values' data.\n";
40             }
41 34         67 @values = map { _val( $_ ) } @values;
  213         247  
42 33 100       91 croak "No values specified for 'values'.\n" unless @values;
43              
44             # Figure out the width I want and define the viewBox
45 31   100     123 my $thick = $args->{thick} || 1;
46 31   66     117 my $gap = $args->{gap} || 2 * $thick;
47 31         41 my $space = $thick + $gap;
48 31         30 my $dwidth;
49 31 100       55 if($args->{width})
50             {
51 4         6 $dwidth = $args->{width} - 2*$args->{padx};
52 4         13 $thick = _f( $dwidth / (3*@values) );
53 4         12 $gap = _f( 2* $thick );
54 4         29 $space = 3*$thick;
55             }
56             else
57             {
58 27         31 $dwidth = @values * $space;
59 27         53 $args->{width} = $dwidth + 2*$args->{padx};
60             }
61 31 50       74 ++$space if $space =~s/\.9\d$//;
62 31         55 my $height = $args->{height} - 2*$args->{pady};
63 31         54 my $wheight = $args->{height}/2;
64 31         46 $args->{yoff} = -$wheight;
65 31         50 $wheight -= $args->{pady};
66 31         78 my $svg = SVG::Sparkline::Utils::make_svg( $args );
67              
68 31         88 my $off = _f( $gap/2 );
69 31         66 my $path = "M$off,0";
70 31         97 foreach my $v (@values[0..$#values-1])
71             {
72 179 100       194 if( $v )
73             {
74 122         135 my ($u,$d) = ( -$v*$wheight, $v*$wheight );
75 122         212 $path .= "v${u}m$space,${d}";
76             }
77             else
78             {
79 57         84 $path .= "m$space,0";
80             }
81             }
82 31         63 $path .= 'v' . (-$values[-1]*$wheight);
83 31         61 $path = _clean_path( $path );
84 31         161 $svg->path( 'stroke-width'=>$thick, stroke=>$args->{color}, d=>$path );
85              
86 31 100       1555 if( exists $args->{mark} )
87             {
88 9         23 _make_marks( $svg,
89             thick=>$thick, off=>$off, space=>$space, wheight=>-$wheight,
90             values=>\@values, mark=>$args->{mark}
91             );
92             }
93 29         97 return $svg;
94             }
95              
96             sub _make_marks
97             {
98 9     9   33 my ($svg, %args) = @_;
99            
100 9         38 my @marks = @{$args{mark}};
  9         20  
101 9         21 while(@marks)
102             {
103 11         18 my ($index,$color) = splice( @marks, 0, 2 );
104 11         20 $index = _check_index( $index, $args{values} );
105 9         28 _make_mark( $svg, %args, index=>$index, color=>$color );
106             }
107 7         14 return;
108             }
109              
110             sub _make_mark
111             {
112 9     9   54 my ($svg, %args) = @_;
113 9         35 my $index = $args{index};
114 9 100       26 return unless $args{values}->[$index];
115 8         19 my $x = $index * $args{space}+$args{off};
116 8         44 $svg->line( x1=>$x, x2=>$x, y1=>0, y2=>$args{wheight} * $args{values}->[$index],
117             'stroke-width'=>$args{thick}, stroke=>$args{color}
118             );
119 8         455 return;
120             }
121              
122             sub _check_index
123             {
124 11     11   11 my ($index, $values) = @_;
125 11 100       27 return 0 if $index eq 'first';
126 10 100       14 return $#{$values} if $index eq 'last';
  1         3  
127 9 100       38 return $index unless $index =~ /\D/;
128              
129 2         46 die "'$index' is not a valid mark for Whisker sparkline";
130             }
131              
132             sub _val
133             {
134 213     213   186 my $val = shift;
135              
136 213 100       503 return $val <=> 0 if $val =~ /\d/;
137 114 100       284 return $val eq '+' ? 1 : ( $val eq '-' ? -1 : die "Unrecognized character '$val'\n" );
    100          
138             }
139              
140             sub _clean_path
141             {
142 37     37   52 my ($path) = @_;
143 37         268 $path =~ s/((?:m[-.\d]+,[-.\d+]+){2,})/_consolidate_moves( $1 )/eg;
  47         73  
144             # Consolidate initial M with m
145 37         117 $path =~ s/^M([-.\d]+),([-.\d]+)m([-.\d]+),([-.\d]+)/'M'. _f($1+$3) .','. _f($2+$4)/e;
  8         31  
146 37         113 $path =~ s/m[-.\d]+,[-.\d]+$//; # remove trailing move.
147 37         44 $path =~ s/m0,0(?![.\d])//;
148 37         83 return $path;
149             }
150              
151             sub _consolidate_moves
152             {
153 47     47   81 my ($moves) = @_;
154 47         222 my @coords = split /[m,]/, $moves;
155 47         65 shift @coords; # dump empty initial string.
156 47         41 my ($x,$y);
157 47         90 while(@coords)
158             {
159 100         138 my ($lx, $ly) = splice @coords, 0, 2;
160 100         112 $x += $lx;
161 100         163 $y += $ly;
162             }
163              
164 47 50 33     169 return ($x||$y) ? 'm' . _f($x).',' . _f($y) : '';
165             }
166              
167             1;
168              
169             __END__