File Coverage

blib/lib/Tickit/Widget/SparkLine.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             package Tickit::Widget::SparkLine;
2             # ABSTRACT: Simple 'sparkline' widget implementation
3 1     1   14443 use strict;
  1         2  
  1         31  
4 1     1   3 use warnings;
  1         1  
  1         22  
5 1     1   370 use parent qw(Tickit::Widget);
  1         214  
  1         4  
6              
7             our $VERSION = '0.105';
8              
9             =head1 NAME
10              
11             Tickit::Widget::SparkLine - minimal graph implementation for L
12              
13             =head1 VERSION
14              
15             version 0.105
16              
17             =head1 SYNOPSIS
18              
19             my $vbox = Tickit::Widget::VBox->new;
20             my $widget = Tickit::Widget::SparkLine->new(
21             data => [ 0, 3, 2, 5, 1, 6, 0, 7 ]
22             );
23             $vbox->add($widget, expand => 1);
24              
25             =head1 DESCRIPTION
26              
27             Generates a mini ("sparkline") graph.
28              
29             =begin HTML
30              
31            

Sparkline widget in action

32              
33             =end HTML
34              
35             =head1 STYLE
36              
37             Set the base style background/foreground to determine the graph colours.
38             Note that reverse video and bold don't work very well on some terminals,
39             since the background+foreground colours won't match.
40              
41             =cut
42              
43             use POSIX qw(floor);
44             use Scalar::Util qw(reftype);
45             use List::Util qw(max sum min);
46             use Tickit::Utils qw(textwidth);
47             use Tickit::Style;
48             use constant WIDGET_PEN_FROM_STYLE => 1;
49              
50             BEGIN {
51             style_definition base =>
52             fg => 'white';
53             }
54              
55             =head1 METHODS
56              
57             =cut
58              
59             sub lines { 1 }
60              
61             sub cols {
62             my $self = shift;
63             scalar @{$self->{data}}
64             }
65              
66             =head2 new
67              
68             Instantiate the widget. Takes the following named parameters:
69              
70             =over 4
71              
72             =item * data - graph data
73              
74             =back
75              
76             =cut
77              
78             sub new {
79             my $class = shift;
80             my %args = @_;
81             my $data = delete $args{data};
82             my $self = $class->SUPER::new(%args);
83             $self->{data} = $data || [];
84             $self->resized if $data;
85             return $self;
86             }
87              
88             =head2 data
89              
90             Accessor for stored data.
91              
92             With no parameters, returns the stored data as a list.
93              
94             Pass either an array or an arrayref to set the data values and request display refresh.
95              
96             =cut
97              
98             sub data {
99             my $self = shift;
100             if(@_) {
101             $self->{data} = [ (ref($_[0]) && reftype($_[0]) eq 'ARRAY') ? @{$_[0]} : @_ ];
102             delete $self->{max_value};
103             $self->resized;
104             }
105             return @{ $self->{data} };
106             }
107              
108             =head2 data_chars
109              
110             Returns the set of characters corresponding to the current data values. Each value
111             is assigned a single character, so the string length is equal to the number of data
112             items and represents the minimal string capable of representing all current data
113             items.
114              
115             =cut
116              
117             sub data_chars {
118             my $self = shift;
119             return join '', map { $self->char_for_value($_) } $self->data;
120             }
121              
122             =head2 push
123              
124             Helper method to add one or more items to the end of the list.
125              
126             $widget->push(3,4,2);
127              
128             =cut
129              
130             sub push : method {
131             my $self = shift;
132             push @{$self->{data}}, @_;
133             delete $self->{max_value};
134             $self->resized;
135             }
136              
137             =head2 pop
138              
139             Helper method to remove one item from the end of the list, returns the item.
140              
141             my $item = $widget->pop;
142              
143             =cut
144              
145             sub pop : method {
146             my $self = shift;
147             my $item = pop @{$self->{data}};
148             delete $self->{max_value};
149             $self->resized;
150             return $item;
151             }
152              
153             =head2 shift
154              
155             Helper method to remove one item from the start of the list, returns the item.
156              
157             my $item = $widget->shift;
158              
159             =cut
160              
161             sub shift : method {
162             my $self = shift;
163             my $item = shift @{$self->{data}};
164             delete $self->{max_value};
165             $self->resized;
166             return $item;
167             }
168              
169             =head2 unshift
170              
171             Helper method to add items to the start of the list. Takes a list.
172              
173             $widget->unshift(0, 1, 3);
174              
175             =cut
176              
177             sub unshift : method {
178             my $self = shift;
179             unshift @{$self->{data}}, @_;
180             delete $self->{max_value};
181             $self->resized;
182             }
183              
184             =head2 splice
185              
186             Equivalent to the standard Perl L function.
187              
188             # Insert 3,4,5 at position 2
189             $widget->splice(2, 0, 3, 4, 5);
190              
191             =cut
192              
193             sub splice : method {
194             my $self = shift;
195             my ($offset, $length, @values) = @_;
196              
197             # Specify parameters directly since splice applies a @$$@-ish prototype here
198             my @items = splice @{$self->{data}}, $offset, $length, @values;
199             delete $self->{max_value};
200             $self->resized;
201             return @items;
202             }
203              
204             =head2 graph_steps
205              
206             Returns an arrayref of characters in order of magnitude.
207              
208             For example:
209              
210             [ ' ', qw(_ x X) ]
211              
212             would yield a granularity of 4 steps.
213              
214             Override this in subclasses to provide different visualisations - there's no limit to the number of
215             characters you provide in this arrayref.
216              
217             =cut
218              
219             sub graph_steps { [
220             ord " ",
221             0x2581,
222             0x2582,
223             0x2583,
224             0x2584,
225             0x2585,
226             0x2586,
227             0x2587,
228             0x2588
229             ] }
230              
231             =head2 resample
232              
233             Given a width $w, resamples the data (remaining list of
234             parameters) to fit, using the current L.
235              
236             Used internally.
237              
238             =cut
239              
240             sub resample {
241             my $self = shift;
242             my ($total_width, @data) = @_;
243             my $xdelta = $total_width / @data;
244             my $x = 0;
245             my @v;
246             my @out;
247             my $mode = {
248             average => sub { sum(@_) / @_ },
249             mean => sub { sum(@_) / @_ },
250             median => sub {
251             my @sorted = sort { $a <=> $b } @_;
252             (@sorted % 2) ? $sorted[@_ / 2] : (sum(@sorted[@_ / 2, 1 + @_ / 2]) / 2) },
253             peak => sub { max @_ },
254             min => sub { min @_ },
255             max => sub { max @_ },
256             }->{$self->resample_mode} or die 'bad resample mode: ' . $self->resample_mode;
257              
258             for (@data) {
259             my $last_x = $x;
260             $x += $xdelta;
261             push @v, $_;
262             if(floor($x) - floor($last_x)) {
263             push @out, $mode->(@v);
264             @v = ();
265             }
266             }
267             @out;
268             }
269              
270             =head2 render_to_rb
271              
272             Rendering implementation. Uses L as the base character set.
273              
274             =cut
275              
276             sub render_to_rb {
277             my ($self, $rb) = @_;
278             my $win = $self->window or return;
279             $rb->clear;
280              
281             my @data = @{$self->{data}};
282             my $total_width = $win->cols;
283             my $w = $total_width / (@data || 1);
284             my $floored_w = floor $w;
285              
286             # Apply minimum per-cell width of 1 char, and resample data to fit
287             unless($floored_w) {
288             $w = 1;
289             $floored_w = 1;
290             @data = $self->resample($total_width => @data);
291             }
292              
293             my $win_height = $win->lines;
294             my $x = 0;
295             my $range = $#{$self->graph_steps};
296             my $fg_pen = $self->get_style_pen;
297             my $bg_pen = Tickit::Pen->new(
298             bg => $fg_pen->getattr('fg'),
299             map {; $_ => $fg_pen->getattr($_) } qw(rv b)
300             );
301             foreach my $item (@data) {
302             my $v = $item * $win_height / $self->max_value;
303             my $top = $win_height - floor( $v);
304             my $left = floor(0.5 + $x);
305             my $bar_width = (floor(0.5 + $x + $w) - $left);
306             for my $y ($top .. $win_height) {
307             $rb->erase_at($y, $left, $bar_width, $bg_pen);
308             }
309             my $ch = $self->graph_steps->[floor(0.5 + $range * ($v - floor($v)))];
310             $rb->char_at($top - 1, $left + $_, $ch, $fg_pen) for 0..$bar_width-1;
311             $x += $w;
312             }
313             }
314              
315             =head2 char_for_value
316              
317             Returns the character code corresponding to the given data value.
318              
319             =cut
320              
321             sub char_for_value {
322             my $self = shift;
323             my $item = shift;
324             my $range = $#{$self->graph_steps};
325             return $self->graph_steps->[$item * $range / $self->max_value];
326             }
327              
328             =head2 max_value
329              
330             Returns the maximum value seen so far, used for autoscaling.
331              
332             =cut
333              
334             sub max_value {
335             my $self = shift;
336             return $self->{max_value} if exists $self->{max_value};
337             return $self->{max_value} = max($self->data);
338             }
339              
340             =head2 resample_mode
341              
342             Change method for resampling when we have more data than will fit on the graph.
343              
344             Current values include:
345              
346             =over 4
347              
348             =item * average - takes the average of combined values for this bucket
349              
350             =item * min - lowest value for this bucket
351              
352             =item * median - highest value for this bucket
353              
354             =item * max - largest value for this bucket
355              
356             =item * peak - alias for 'max'
357              
358             =back
359              
360             The default is 'average'.
361              
362             Returns $self if setting a value, or the current value.
363              
364             =cut
365              
366             sub resample_mode {
367             my $self = shift;
368             if(@_) {
369             $self->{resample_mode} = shift;
370             return $self;
371             }
372             return $self->{resample_mode} // 'average';
373             }
374              
375             1;
376              
377             __END__