File Coverage

File:blib/lib/SVG/Sparkline/Whisker.pm
Coverage:96.9%

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