File Coverage

blib/lib/GD/Graph/Data.pm
Criterion Covered Total %
statement 145 191 75.9
branch 39 78 50.0
condition 37 92 40.2
subroutine 25 32 78.1
pod 22 23 95.6
total 268 416 64.4


line stmt bran cond sub pod time code
1             #==========================================================================
2             # Copyright (c) 1995-2000 Martien Verbruggen
3             #--------------------------------------------------------------------------
4             #
5             # Name:
6             # GD::Graph::Data.pm
7             #
8             # $Id: Data.pm,v 1.22 2007/04/26 03:16:09 ben Exp $
9             #
10             #==========================================================================
11              
12             package GD::Graph::Data;
13              
14             ($GD::Graph::Data::VERSION) = '$Revision: 1.22 $' =~ /\s([\d.]+)/;
15              
16 2     2   6293 use strict;
  2         4  
  2         66  
17 2     2   432 use GD::Graph::Error;
  2         2  
  2         125  
18              
19             @GD::Graph::Data::ISA = qw( GD::Graph::Error );
20              
21             =head1 NAME
22              
23             GD::Graph::Data - Data set encapsulation for GD::Graph
24              
25             =head1 SYNOPSIS
26              
27             use GD::Graph::Data;
28              
29             =head1 DESCRIPTION
30              
31             This module encapsulates the data structure that is needed for GD::Graph
32             and friends. An object of this class contains a list of X values, and a
33             number of lists of corresponding Y values. This only really makes sense
34             if the Y values are numerical, but you can basically store anything.
35             Undefined values have a special meaning to GD::Graph, so they are
36             treated with care when stored.
37              
38             Many of the methods of this module are intended for internal use by
39             GD::Graph and the module itself, and will most likely not be useful to
40             you. Many won't even I useful to you...
41              
42             =head1 EXAMPLES
43              
44             use GD::Graph::Data;
45             use GD::Graph::bars;
46              
47             my $data = GD::Graph::Data->new();
48              
49             $data->read(file => '/data/sales.dat', delimiter => ',');
50             $data = $data->copy(wanted => [2, 4, 5]);
51              
52             # Add the newer figures from the database
53             use DBI;
54             # do DBI things, like connecting to the database, statement
55             # preparation and execution
56              
57             while (@row = $sth->fetchrow_array)
58             {
59             $data->add_point(@row);
60             }
61              
62             my $chart = GD::Graph::bars->new();
63             my $gd = $chart->plot($data);
64              
65             or for quick changes to legacy code
66              
67             # Legacy code builds array like this
68             @data = ( [qw(Jan Feb Mar)], [1, 2, 3], [5, 4, 3], [6, 3, 7] );
69              
70             # And we quickly need to do some manipulations on that
71             my $data = GD::Graph::Data->new();
72             $data->copy_from(\@data);
73              
74             # And now do all the new stuff that's wanted.
75             while (@foo = bar_baz())
76             {
77             $data->add_point(@foo);
78             }
79              
80             =head1 METHODS
81              
82             =head2 $data = GD::Graph::Data->new()
83              
84             Create a new GD::Graph::Data object.
85              
86             =cut
87              
88             # Error constants
89 2     2   11 use constant ERR_ILL_DATASET => 'Illegal dataset number';
  2         2  
  2         237  
90 2     2   10 use constant ERR_ILL_POINT => 'Illegal point number';
  2         2  
  2         90  
91 2     2   27 use constant ERR_NO_DATASET => 'No data sets set';
  2         2  
  2         85  
92 2     2   9 use constant ERR_ARGS_NO_HASH => 'Arguments must be given as a hash list';
  2         2  
  2         3571  
93              
94             sub new
95             {
96 6     6 1 2213 my $proto = shift;
97 6   66     30 my $class = ref($proto) || $proto;
98 6         11 my $self = [];
99 6         8 bless $self => $class;
100 6 50 0     15 $self->copy_from(@_) or return $self->_move_errors if (@_);
101 6         13 return $self;
102             }
103              
104             sub DESTROY
105             {
106 6     6   197 my $self = shift;
107 6         14 $self->clear_errors();
108             }
109              
110             sub _set_value
111             {
112 54     54   39 my $self = shift;
113 54         57 my ($nd, $np, $val) = @_;
114              
115             # Make sure we have empty arrays in between
116 54 100       58 if ($nd > $self->num_sets)
117             {
118             # XXX maybe do this with splice
119 16         18 for ($self->num_sets .. $nd - 1)
120             {
121 16         13 push @{$self}, [];
  16         31  
122             }
123             }
124 54         70 $self->[$nd][$np] = $val;
125              
126 54         93 return $self;
127             }
128              
129             =head2 $data->set_x($np, $value);
130              
131             Set the X value of point I<$np> to I<$value>. Points are numbered
132             starting with 0. You probably will never need this. Returns undef on
133             failure.
134              
135             =cut
136              
137             sub set_x
138             {
139 0     0 1 0 my $self = shift;
140 0         0 $self->_set_value(0, @_);
141             }
142              
143             =head2 $data->get_x($np)
144              
145             Get the X value of point I<$np>. See L<"set_x">.
146              
147             =cut
148              
149             sub get_x
150             {
151 0     0 1 0 my $self = shift;
152 0         0 my $np = shift;
153 0 0 0     0 return $self->_set_error(ERR_ILL_POINT)
154             unless defined $np && $np >= 0;
155              
156 0         0 $self->[0][$np];
157             }
158              
159             =head2 $data->set_y($nd, $np, $value);
160              
161             Set the Y value of point I<$np> in data set I<$nd> to I<$value>. Points
162             are numbered starting with 0, data sets are numbered starting with 1.
163             You probably will never need this. Returns undef on failure.
164              
165             =cut
166              
167             sub set_y
168             {
169 0     0 1 0 my $self = shift;
170 0 0 0     0 return $self->_set_error(ERR_ILL_DATASET)
171             unless defined $_[0] && $_[0] >= 1;
172 0         0 $self->_set_value(@_);
173             }
174              
175             =head2 $data->get_y($nd, $np)
176              
177             Get the Y value of point I<$np> in data set I<$nd>. See L<"set_y">. This
178             will return undef on an error, but the fact that it returns undef does
179             not mean there was an error (since undefined values can be stored, and
180             therefore returned).
181              
182             =cut
183              
184             sub get_y
185             {
186 2     2 1 14 my $self = shift;
187 2         5 my ($nd, $np) = @_;
188 2 50 33     24 return $self->_set_error(ERR_ILL_DATASET)
      33        
189             unless defined $nd && $nd >= 1 && $nd <= $self->num_sets;
190 2 50 33     10 return $self->_set_error(ERR_ILL_POINT)
191             unless defined $np && $np >= 0;
192              
193 2         3 $self->[$nd][$np];
194             }
195              
196             =head2 $data->get_y_cumulative($nd, $np)
197              
198             Get the cumulative value of point I<$np> in data set<$nd>. The
199             cumulative value is obtained by adding all the values of the points
200             I<$np> in the data sets 1 to I<$nd>.
201              
202             =cut
203              
204             sub get_y_cumulative
205             {
206 0     0 1 0 my $self = shift;
207 0         0 my ($nd, $np, $incl_vec) = @_;
208 0 0 0     0 return $self->_set_error(ERR_ILL_DATASET)
      0        
209             unless defined $nd && $nd >= 1 && $nd <= $self->num_sets;
210 0 0 0     0 return $self->_set_error(ERR_ILL_POINT)
211             unless defined $np && $np >= 0;
212            
213 0         0 my $value;
214 0 0       0 my @indices = $incl_vec ? grep($_ <= $nd, @$incl_vec) : 1 .. $nd;
215 0         0 for my $i ( @indices )
216             {
217 0   0     0 $value += $self->[$i][$np] || 0;
218             }
219              
220 0         0 return $value;
221             }
222              
223             sub _get_min_max
224             {
225 6     6   6 my $self = shift;
226 6         6 my $nd = shift;
227 6         5 my ($min, $max);
228              
229 6         6 for my $val (@{$self->[$nd]})
  6         14  
230             {
231 18 100       32 next unless defined $val;
232 17 100 100     45 $min = $val if !defined $min || $val < $min;
233 17 100 100     48 $max = $val if !defined $max || $val > $max;
234             }
235              
236 6 50 66     39 return $self->_set_error("No (defined) values in " .
    100          
237             ($nd == 0 ? "X list" : "dataset $nd"))
238             unless defined $min && defined $max;
239            
240 5         12 return ($min, $max);
241             }
242              
243             =head2 $data->get_min_max_x
244              
245             Returns a list of the minimum and maximum x value or the
246             empty list on failure.
247              
248             =cut
249              
250             sub get_min_max_x
251             {
252 1     1 1 402 my $self = shift;
253 1         5 $self->_get_min_max(0);
254             }
255              
256             =head2 $data->get_min_max_y($nd)
257              
258             Returns a list of the minimum and maximum y value in data set $nd or the
259             empty list on failure.
260              
261             =cut
262              
263             sub get_min_max_y
264             {
265 5     5 1 578 my $self = shift;
266 5         6 my $nd = shift;
267              
268 5 50 33     34 return $self->_set_error(ERR_ILL_DATASET)
      33        
269             unless defined $nd && $nd >= 1 && $nd <= $self->num_sets;
270            
271 5         10 $self->_get_min_max($nd);
272             }
273              
274             =head2 $data->get_min_max_y_all()
275              
276             Returns a list of the minimum and maximum y value in all data sets or the
277             empty list on failure.
278              
279             =cut
280              
281             sub get_min_max_y_all
282             {
283 1     1 1 388 my $self = shift;
284 1         1 my ($min, $max);
285              
286 1         4 for (my $ds = 1; $ds <= $self->num_sets; $ds++)
287             {
288 3         5 my ($ds_min, $ds_max) = $self->get_min_max_y($ds);
289 3 50       7 next unless defined $ds_min;
290 3 100 100     12 $min = $ds_min if !defined $min || $ds_min < $min;
291 3 100 66     15 $max = $ds_max if !defined $max || $ds_max > $max;
292             }
293              
294 1 50 33     14 return $self->_set_error('No (defined) values in any data set')
295             unless defined $min && defined $max;
296            
297 1         4 return ($min, $max);
298             }
299              
300             # Undocumented, not part of interface right now. Might expose at later
301             # point in time.
302              
303             sub set_point
304             {
305 12     12 0 11 my $self = shift;
306 12         11 my $np = shift;
307 12 50 33     49 return $self->_set_error(ERR_ILL_POINT)
308             unless defined $np && $np >= 0;
309              
310 12         23 for (my $ds = 0; $ds < @_; $ds++)
311             {
312 54         72 $self->_set_value($ds, $np, $_[$ds]);
313             }
314 12         43 return $self;
315             }
316              
317             =head2 $data->add_point($X, $Y1, $Y2 ...)
318              
319             Adds a point to the data set. The base for the addition is the current
320             number of X values. This means that if you have a data set with the
321             contents
322              
323             (X1, X2)
324             (Y11, Y12)
325             (Y21)
326             (Y31, Y32, Y33, Y34)
327              
328             a $data->add_point(Xx, Y1x, Y2x, Y3x, Y4x) will result in
329              
330             (X1, X2, Xx )
331             (Y11, Y12, Y1x)
332             (Y21, undef, Y2x)
333             (Y31, Y32, Y3x, Y34)
334             (undef, undef, Y4x)
335              
336             In other words: beware how you use this. As long as you make sure that
337             all data sets are of equal length, this method is safe to use.
338              
339             =cut
340              
341             sub add_point
342             {
343 12     12 1 410 my $self = shift;
344 12         17 $self->set_point(scalar $self->num_points, @_);
345             }
346              
347             =head2 $data->num_sets()
348              
349             Returns the number of data sets.
350              
351             =cut
352              
353             sub num_sets
354             {
355 90     90 1 325 my $self = shift;
356 90         127 @{$self} - 1;
  90         255  
357             }
358              
359             =head2 $data->num_points()
360              
361             In list context, returns a list with its first element the number of X
362             values, and the subsequent elements the number of respective Y values
363             for each data set. In scalar context returns the number of points
364             that have an X value set, i.e. the number of data sets that would result
365             from a call to C.
366              
367             =cut
368              
369             sub num_points
370             {
371 17     17 1 419 my $self = shift;
372 17 100       13 return (0) unless @{$self};
  17         36  
373              
374             wantarray ?
375 0         0 map { scalar @{$_} } @{$self} :
  0         0  
  0         0  
376 14 50       24 scalar @{$self->[0]}
  14         38  
377             }
378              
379             =head2 $data->x_values()
380              
381             Return a list of all the X values.
382              
383             =cut
384              
385             sub x_values
386             {
387 0     0 1 0 my $self = shift;
388             return $self->_set_error(ERR_NO_DATASET)
389 0 0       0 unless @{$self};
  0         0  
390 0         0 @{$self->[0]};
  0         0  
391             }
392              
393             =head2 $data->y_values($nd)
394              
395             Return a list of the Y values for data set I<$nd>. Data sets are
396             numbered from 1. Returns the empty list if $nd is out of range, or if
397             the data set at $nd is empty.
398              
399             =cut
400              
401             sub y_values
402             {
403 3     3 1 455 my $self = shift;
404 3         4 my $nd = shift;
405 3 50 33     19 return $self->_set_error(ERR_ILL_DATASET)
      33        
406             unless defined $nd && $nd >= 1 && $nd <= $self->num_sets;
407             return $self->_set_error(ERR_NO_DATASET)
408 3 50       3 unless @{$self};
  3         7  
409              
410 3         2 @{$self->[$nd]};
  3         12  
411             }
412              
413             =head2 $data->reset() OR GD::Graph::Data->reset()
414              
415             As an object method: Reset the data container, get rid of all data and
416             error messages. As a class method: get rid of accumulated error messages
417             and possible other crud.
418              
419             =cut
420              
421             sub reset
422             {
423 5     5 1 6 my $self = shift;
424 5 50       10 @{$self} = () if ref($self);
  5         10  
425 5         12 $self->clear_errors();
426 5         5 return $self;
427             }
428              
429             =head2 $data->make_strict()
430              
431             Make all data set lists the same length as the X list by truncating data
432             sets that are too long, and filling data sets that are too short with
433             undef values. always returns a true value.
434              
435             =cut
436              
437             sub make_strict
438             {
439 0     0 1 0 my $self = shift;
440              
441 0         0 for my $ds (1 .. $self->num_sets)
442             {
443 0         0 my $data_set = $self->[$ds];
444              
445 0         0 my $short = $self->num_points - @{$data_set};
  0         0  
446 0 0       0 next if $short == 0;
447              
448 0 0       0 if ($short > 0)
449             {
450 0         0 my @fill = (undef) x $short;
451 0         0 push @{$data_set}, @fill;
  0         0  
452             }
453             else
454             {
455 0         0 splice @{$data_set}, $short;
  0         0  
456             }
457             }
458 0         0 return $self;
459             }
460              
461             =head2 $data->cumulate(preserve_undef => boolean)
462              
463             The B parameter will summarise the Y value sets as follows:
464             the first Y value list will be unchanged, the second will contain a
465             sum of the first and second, the third will contain the sum of first,
466             second and third, and so on. Returns undef on failure.
467              
468             if the argument I is set to a true value, then the sum
469             of exclusively undefined values will be preserved as an undefined value.
470             If it is not present or a false value, undef will be treated as zero.
471             Note that this still will leave undefined values in the first data set
472             alone.
473              
474             Note: Any non-numerical defined Y values will be treated as 0, but you
475             really shouldn't be using this to store that sort of Y data.
476              
477             =cut
478              
479             sub cumulate
480             {
481 1     1 1 392 my $self = shift;
482              
483 1 50 33     10 return $self->_set_error(ERR_ARGS_NO_HASH) if (@_ && @_ % 2);
484 1         5 my %args = @_;
485              
486             # For all the sets, starting at the last one, ending just
487             # before the first
488 1         2 for (my $ds = $self->num_sets; $ds > 1; $ds--)
489             {
490             # For each point in the set
491 2         1 for my $point (0 .. $#{$self->[$ds]})
  2         7  
492             {
493             # Add the value for each point in lower sets to this one
494 8         9 for my $i (1 .. $ds - 1)
495             {
496             # If neither are defined, we want to preserve the
497             # undefinedness of this point. If we don't do this, then
498             # the mathematical operation will force undef to be a 0.
499             next if
500             $args{preserve_undef} &&
501 12 0 33     26 ! defined $self->[$ds][$point] &&
      33        
502             ! defined $self->[$i][$point];
503              
504 12   100     33 $self->[$ds][$point] += $self->[$i][$point] || 0;
505             }
506             }
507             }
508 1         3 return $self;
509             }
510              
511             =head2 $data->wanted(indexes)
512              
513             Removes all data sets except the ones in the argument list. It will also
514             reorder the data sets in the order given. Returns undef on failure.
515              
516             To remove all data sets except the first, sixth and second, in that
517             order:
518              
519             $data->wanted(1, 6, 2) or die $data->error;
520              
521             =cut
522              
523             sub wanted
524             {
525 0     0 1 0 my $self = shift;
526              
527 0         0 for my $wanted (@_)
528             {
529 0 0 0     0 return $self->_set_error("Wanted index $wanted out of range 1-"
530             . $self->num_sets)
531             if $wanted < 1 || $wanted > $self->num_sets;
532             }
533 0         0 @{$self} = @{$self}[0, @_];
  0         0  
  0         0  
534 0         0 return $self;
535             }
536              
537             =head2 $data->reverse
538              
539             Reverse the order of the data sets.
540              
541             =cut
542              
543             sub reverse
544             {
545 1     1 1 389 my $self = shift;
546 1         3 @{$self} = ($self->[0], reverse @{$self}[1..$#{$self}]);
  1         2  
  1         3  
  1         2  
547 1         3 return $self;
548             }
549              
550             =head2 $data->copy_from($data_ref)
551              
552             Copy an 'old' style GD::Graph data structure or another GD::Graph::Data
553             object into this object. This will remove the current data. Returns undef
554             on failure.
555              
556             =cut
557              
558             sub copy_from
559             {
560 2     2 1 303 my $self = shift;
561 2         3 my $data = shift;
562 2 50 66     24 return $self->_set_error('Not a valid source data structure')
      33        
563             unless defined $data && (
564             ref($data) eq 'ARRAY' || ref($data) eq __PACKAGE__);
565            
566 2         6 $self->reset;
567              
568 2         2 my $i = 0;
569 2         2 for my $data_set (@{$data})
  2         10  
570             {
571 8 50       12 return $self->_set_error("Invalid data set: $i")
572             unless ref($data_set) eq 'ARRAY';
573              
574 8         8 push @{$self}, [@{$data_set}];
  8         6  
  8         13  
575 8         9 $i++;
576             }
577              
578 2         3 return $self;
579             }
580              
581             =head2 $data->copy()
582              
583             Returns a copy of the object, or undef on failure.
584              
585             =cut
586              
587             sub copy
588             {
589 1     1 1 395 my $self = shift;
590              
591 1         4 my $new = $self->new();
592 1         3 $new->copy_from($self);
593 1         2 return $new;
594             }
595              
596             =head2 $data->read(I)
597              
598             Read a data set from a file. This will remove the current data. returns
599             undef on failure. This method uses the standard module
600             Text::ParseWords to parse lines. If you don't have this for some odd
601             reason, don't use this method, or your program will die.
602              
603             B: The default data file format is tab separated data
604             (which can be changed with the delimiter argument). Comment lines are
605             any lines that start with a #. In the following example I have replaced
606             literal tabs with for clarity
607              
608             # This is a comment, and will be ignored
609             Jan1224
610             Feb1337
611             # March is missing
612             Mar
613             Apr918
614              
615             Valid arguments are:
616              
617             I, mandatory. The file name of the file to read from, or a
618             reference to a file handle or glob.
619              
620             $data->read(file => '/data/foo.dat') or die $data->error;
621             $data->read(file => \*DATA) or die $data->error;
622             $data->read(file => $file_handle) or die $data->error;
623              
624             I, optional. Give this a true value if you don't want lines
625             with an initial # to be skipped.
626              
627             $data->read(file => '/data/foo.dat', no_comment => 1);
628              
629             I, optional. A regular expression that will become the
630             delimiter instead of a single tab.
631              
632             $data->read(file => '/data/foo.dat', delimiter => '\s+');
633             $data->read(file => '/data/foo.dat', delimiter => qr/\s+/);
634              
635             =cut
636              
637             sub read
638             {
639 3     3 1 22 my $self = shift;
640              
641 3 50 33     16 return $self->_set_error(ERR_ARGS_NO_HASH) if (@_ && @_ % 2);
642 3         8 my %args = @_;
643              
644             return $self->_set_error('Missing required argument: file')
645 3 50       8 unless $args{file};
646              
647 3   100     9 my $delim = $args{delimiter} || "\t";
648              
649 3         6 $self->reset();
650              
651             # The following will die if these modules are not present, as
652             # documented.
653 3         575 require Text::ParseWords;
654              
655 3         1147 my $fh;
656 3         8 local *FH;
657              
658 3 100       16 if (UNIVERSAL::isa($args{file}, "GLOB"))
659             {
660 1         2 $fh = $args{file};
661             }
662             else
663             {
664             # $fh = \do{ local *FH }; # Odd... This dumps core, sometimes in 5.005
665 2         3 $fh = \*FH; # XXX Need this for perl 5.005
666 2 50       72 open($fh, $args{file}) or
667             return $self->_set_error("open ($args{file}): $!");
668             }
669              
670 3         41 while (my $line = <$fh>)
671             {
672 18         19 chomp $line;
673 18 100 66     86 next if $line =~ /^#/ && !$args{no_comment};
674 11         25 my @fields = Text::ParseWords::parse_line($delim, 1, $line);
675 11 50       912 next unless @fields;
676 11         21 $self->add_point(@fields);
677             }
678 3         24 return $self;
679             }
680              
681             =head2 $data->error() OR GD::Graph::Data->error()
682              
683             Returns a list of all the errors that the current object has
684             accumulated. In scalar context, returns the last error. If called as a
685             class method it works at a class level.
686              
687             This method is inherited, see L for more information.
688              
689             =cut
690              
691             =head2 $data->has_error() OR GD::Graph::Data->has_error()
692              
693             Returns true if the object (or class) has errors pending, false if not.
694             In some cases (see L<"copy">) this is the best way to check for errors.
695              
696             This method is inherited, see L for more information.
697              
698             =cut
699              
700             =head1 NOTES
701              
702             As with all Modules for Perl: Please stick to using the interface. If
703             you try to fiddle too much with knowledge of the internals of this
704             module, you could get burned. I may change them at any time.
705             Specifically, I probably won't always keep this implemented as an array
706             reference.
707              
708             =head1 AUTHOR
709              
710             Martien Verbruggen Emgjv@tradingpost.com.auE
711              
712             =head2 Copyright
713              
714             (c) Martien Verbruggen.
715              
716             All rights reserved. This package is free software; you can redistribute
717             it and/or modify it under the same terms as Perl itself.
718              
719             =head1 SEE ALSO
720              
721             L, L
722              
723             =cut
724              
725             "Just another true value";
726