File Coverage

blib/lib/Chart/Mountain.pm
Criterion Covered Total %
statement 79 108 73.1
branch 22 40 55.0
condition 9 21 42.9
subroutine 6 6 100.0
pod n/a
total 116 175 66.3


line stmt bran cond sub pod time code
1             #====================================================================
2             #
3             # Chart::Mountain
4             #
5             # Inspired by Chart::Lines
6             # by davidb bonner
7             # dbonner@cs.bu.edu
8             #
9             # Updated for
10             # compatibility with
11             # changes to Chart::Base
12             # by peter clark
13             # ninjaz@webexpress.com
14             #
15             # Copyright 1998, 1999 by James F. Miner.
16             # All rights reserved.
17             # This program is free software; you can redistribute it
18             # and/or modify it under the same terms as Perl itself.
19             #
20             # maintained by the Chart Group
21             # Chart@wettzell.ifag.de
22             #
23             #---------------------------------------------------------------------
24             # History:
25             #----------
26             # $RCSfile: Mountain.pm,v $ $Revision: 1.4 $ $Date: 2003/02/14 14:16:23 $
27             # $Author: dassing $
28             # $Log: Mountain.pm,v $
29             # Revision 1.4 2003/02/14 14:16:23 dassing
30             # First setup to cvs
31             #
32             #
33             #====================================================================
34              
35             package Chart::Mountain;
36              
37 2     2   69 use Chart::Base 2.3;
  2         51  
  2         63  
38 2     2   47 use GD;
  2         20  
  2         38  
39 2     2   29 use Carp;
  2         18  
  2         33  
40 2     2   32 use strict;
  2         18  
  2         29  
41              
42             @Chart::Mountain::ISA = qw ( Chart::Base );
43             @Chart::Mountain::VERSION = '2.3';
44              
45              
46             ## Some Mountain chart details:
47             #
48             # The effective y data value for a given x point and dataset
49             # is the sum of the actual y data values of that dataset and
50             # all datasets "below" it (i.e., with higher dataset indexes).
51             #
52             # If the y data value in any dataset is undef or negative for
53             # a given x, then all datasets are treated as missing for that x.
54             #
55             # The y minimum is always forced to zero.
56             #
57             # To avoid a dataset area "cutting into" the area of the dataset below
58             # it, the y pixel for each dataset point will never be below the y pixel for
59             # the same point in the dataset below the dataset.
60              
61             # This probably should have a custom legend method, because each
62             # dataset is identified by the fill color (and optional pattern)
63             # of its area, not just a line color. So the legend shou a square
64             # of the color and pattern for each dataset.
65              
66             #===================#
67             # private methods #
68             #===================#
69              
70             sub _find_y_range {
71 4     4   37     my $self = shift;
72                 
73             # This finds the maximum point-sum over all x points,
74             # where the point-sum is the sum of the dataset values at that point.
75             # If the y value in any dataset is undef for a given x, then all datasets
76             # are treated as missing for that x.
77                 
78 4         41     my $data = $self->{'dataref'};
79 4         36     my $max = undef;
80 4         35     for my $i (0..$#{$data->[0]}) {
  4         101  
81 36         336 my $y_sum = $data->[1]->[$i];
82 36 50 33     453 if ( defined $y_sum && $y_sum >= 0 ) {
83 36         467 for my $dataset ( @$data[2..$#$data] ) { # order not important
84 72         717 my $datum = $dataset->[$i];
85 72 50 33     1051 if ( defined $datum && $datum >= 0 ) {
86 72         742 $y_sum += $datum
87             }
88             else { # undef or negative, treat all at same x as missing.
89 0         0 $y_sum = undef;
90             last 
91 0         0 }
92             }
93             }
94 36 50       365 if ( defined $y_sum ) {
95 36 100 100     2385 $max = $y_sum unless defined $max && $y_sum <= $max;
96             }
97                 }
98              
99             ## new _find_y_scale does this:
100             # my $tmp = ($max) ? 10 ** (int (log ($max) / log (10))) : 10;
101             # $max = $tmp * (int ($max / $tmp) + 1);
102              
103 4         66     (0, $max);
104             }
105              
106              
107             sub _draw_data {
108 4     4   38     my $self = shift;
109 4         40     my $data = $self->{'dataref'};
110                 
111 4 100       34     my @patterns = @{ $self->{'patterns'} || [] };
  4         66  
112                 
113             # Calculate array of x pixel positions (@x).
114 4 50       59     my $x_step = ($self->{'curr_x_max'} - $self->{'curr_x_min'}) / ($self->{'num_datapoints'} > 0 ? $self->{'num_datapoints'} : 1);
115 4         43     my $x_min = $self->{'curr_x_min'} + $x_step / 2;
116 4         39     my $x_max = $self->{'curr_x_max'} - $x_step / 2;
117 4         50     my @x = map { $_ * $x_step + $x_min } 0..$self->{'num_datapoints'}-1;
  36         901  
118 4         42     my ($t_x_min, $t_x_max, $t_y_min, $t_y_max, $abs_x_max, $abs_y_max);
119 4         35     my $repair_top_flag = 0;
120             # Calculate array of y pixel positions for upper boundary each dataset (@y).
121                 
122 4 50       51     my $map = ($self->{'max_val'})
123             ? ($self->{'curr_y_max'} - $self->{'curr_y_min'}) / $self->{'max_val'}
124             : ($self->{'curr_y_max'} - $self->{'curr_y_min'}) / 10;
125              
126 4         39     my $y_max = $self->{'curr_y_max'}; # max pixel point (lower y values)
127                 
128 4         35     my @y;
129 4         34     for my $j (0..$#{$data->[0]}) {
  4         51  
130 36         324 my $sum = 0;
131 36         288 for my $i (reverse 1..$#{$data}) { # bottom to top of chart
  36         364  
132 108         1215 my $datum = $data->[$i][$j];
133              
134             #set the repair flag, if the datum is out of the borders of the chart
135 108 50 33     1385             if ( defined $datum && $datum > $self->{'max_val'}) { $repair_top_flag = 1;}
  0         0  
136                         
137                         
138 108 50 33     1361             if ( defined $datum && $datum >= 0 ) {
139 108         885 $sum += $datum;
140 108         1334 $y[$i-1][$j] = $y_max - $map * $sum;
141             }
142             else { # missing value, force all to undefined
143 0         0 foreach my $k (1..$#{$data}) { $y[$k-1][$j] = undef }
  0         0  
  0         0  
144 0         0 last;
145             }
146             }
147                 }
148                 
149             # Find first and last x where y is defined in the bottom dataset.
150 4         40     my $x_begin = 0;
151 4         39     my $x_end = $self->{'num_datapoints'}-1;
152 4   33     64     while ( $x_begin <= $x_end && ! defined $y[-1]->[$x_begin] ) { $x_begin++ }
  0         0  
153 4   33     60     while ( $x_begin <= $x_end && ! defined $y[-1]->[$x_end] ) { $x_end-- }
  0         0  
154                
155 4 50       42     if ( $x_begin > $x_end ) { croak "Internal error: x_begin > x_end ($x_begin > $x_end)"; }
  0         0  
156                 
157             # For each dataset, generate a polygon for the dataset's area of the chart,
158             # and fill the polygon with the dataset's color/pattern.
159                 
160 4         103     my $poly = GD::Polygon->new;
161 4         158     $poly->addPt($x[$x_end], $y_max); # right end of x axis
162 4         138     $poly->addPt($x[$x_begin], $y_max); # left end of x axis (right-to-left)
163                 
164 4         109     for my $dataset (reverse 0..@y-1) {
165 12         136 my $y_ref = $y[$dataset];
166                 
167             # Append points for this dataset to polygon, direction depends on $dataset % 2.
168 12         170 my $last_vertex_count = $poly->length;
169 12 100       273 if ( (@y - 1 - $dataset) % 2 ) { # right-to-left
170 4         51 for (reverse $x_begin..$x_end) {
171 36 50       2620 $poly->addPt($x[$_], $y_ref->[$_]) if defined $y_ref->[$_]
172             }
173             }
174             else { # left-to-right
175 8         80 for ($x_begin..$x_end) {
176 72 50       1944 $poly->addPt($x[$_], $y_ref->[$_]) if defined $y_ref->[$_]
177             }
178             }
179            
180             # draw the polygon
181 12         401 my $color = $self->_color_role_to_index('dataset'.$dataset);
182 12 100       141 if ( $patterns[$dataset] ) {
183 6 50       89 $self->{'gd_obj'}->filledPolygon($poly, $color) if $patterns[$dataset]->transparent >= 0;
184 6         3207 $self->{'gd_obj'}->setTile($patterns[$dataset]);
185 6         124 $self->{'gd_obj'}->filledPolygon($poly, gdTiled);
186             }
187             else {
188 6         142 $self->{'gd_obj'}->filledPolygon($poly, $color);
189             }
190            
191             # delete previous dataset's points from the polygon, update $last_vertex_count.
192 12 100       8735 unless ( $dataset == 0 ) { # don't bother do delete points after last area
193 8         102 while ( $last_vertex_count ) { $poly->deletePt(0); $last_vertex_count-- }
  44         725  
  44         13032  
194             }
195                 }
196              
197             # Enclose the plots
198 4         78     $self->{'gd_obj'}->rectangle(
199             $self->{'curr_x_min'}, $self->{'curr_y_min'},
200             $self->{'curr_x_max'}, $self->{'curr_y_max'},
201             $self->_color_role_to_index('misc')
202                 );
203              
204             #get the width and the heigth of the complete picture
205 4         57    ($abs_x_max, $abs_y_max) = $self->{'gd_obj'}->getBounds();
206              
207             #repair the chart, if the lines are out of the borders of the chart
208 4 50       46     if ($repair_top_flag) {
209              
210             #overwrite the ugly mistakes
211 0                 $self->{'gd_obj'}->filledRectangle ($self->{'curr_x_min'}, 0,
212             $self->{'curr_x_max'}, $self->{'curr_y_min'}-1,
213             $self->_color_role_to_index('background'));
214              
215             #save the actual x and y values
216 0                 $t_x_min = $self->{'curr_x_min'};
217 0                 $t_x_max = $self->{'curr_x_max'};
218 0                 $t_y_min = $self->{'curr_y_min'};
219 0                 $t_y_max = $self->{'curr_y_max'};
220              
221              
222             #get back to the point, where everything began
223 0                 $self->{'curr_x_min'} = 0;
224 0                 $self->{'curr_y_min'} = 0;
225 0                 $self->{'curr_x_max'} = $abs_x_max;
226 0                 $self->{'curr_y_max'} = $abs_y_max;
227              
228             #draw the title again
229 0 0               if ($self->{'title'}) {
230 0                   $self->_draw_title
231                   }
232              
233             #draw the sub title again
234 0 0               if ($self->{'sub_title'}) {
235 0                   $self->_draw_sub_title
236                   }
237              
238             #draw the top legend again
239 0 0               if ($self->{'legend'} =~ /^top$/i) {
240 0                    $self->_draw_top_legend;
241                   }
242              
243             #reset the actual values
244 0                 $self->{'curr_x_min'} = $t_x_min;
245 0                 $self->{'curr_x_max'} = $t_x_max;
246 0                 $self->{'curr_y_min'} = $t_y_min;
247 0                 $self->{'curr_y_max'} = $t_y_max;
248                   }
249             }    
250              
251              
252             ###############################################################
253              
254             ### Fix a bug in GD::Polygon.
255             ### A patch has been submitted to Lincoln Stein.
256              
257             require GD;
258             unless ( defined &GD::Polygon::deletePt ) {
259                 *GD::Polygon::deletePt = sub {
260             my($self,$index) = @_;
261             unless (($index >= 0) && ($index < @{$self->{'points'}})) {
262             warn "Attempt to set an undefined polygon vertex";
263             return undef;
264             }
265             my($vertex) = splice(@{$self->{'points'}},$index,1);
266             $self->{'length'}--;
267             return @$vertex;
268                 }
269             }
270              
271             ###############################################################
272              
273             1;
274