f7e9177a99735298821c71df3e54fd00ee5dd732
[imager-graph.git] / lib / Imager / Graph / Pie.pm
1 package Imager::Graph::Pie;
2
3 =head1 NAME
4
5   Imager::Graph::Pie - a tool for drawing pie charts on Imager images
6
7 =head1 SYNOPSIS
8
9   use Imager::Graph::Pie;
10
11   my $chart = Imager::Graph::Pie->new;
12   # see Imager::Graph for options
13   my $img = $chart->draw(labels=>['first segment', 'second segment'],
14                          data=>[ $first_amount, $second_amount ],
15                          size=>[$width, $height])
16
17 =head1 DESCRIPTION
18
19 Imager::Graph::Pie is intender to make it simple to use L<Imager> to
20 create good looking pie graphs.
21
22 Most of the basic layout and color selection is handed off to
23 L<Imager::Graph>.
24
25 =over
26
27 =cut
28
29 use strict;
30 use vars qw(@ISA);
31 use Imager::Graph;
32 @ISA = qw(Imager::Graph);
33 use Imager::Graph::Util;
34 use POSIX qw(floor);
35
36 use constant PI => 3.1415926535;
37
38 =item $graph->draw(...)
39
40 Draws a pie graph onto a new image and returns the image.
41
42 You must at least supply a C<data> parameter and should probably supply a C<labels> parameter.
43
44 The C<data> parameter should be a reference to an array containing the
45 data the pie graph should present.
46
47 The C<labels> parameter is a reference to an array of labels,
48 corresponding to the values in C<data>.
49
50 =back
51
52 =head1 FEATURES
53
54 As described in L<Imager::Graph> you can enable extra features for
55 your graph.  The features you can use with pie graphs are:
56
57 =over
58
59 =item legend
60
61 adds a legend to your graph.  Requires the labels parameter
62
63 =item labels
64
65 labels each segment of the graph.  If the label doesn't fit inside the
66 segment it is presented as a callout.
67
68 =item labelspc
69
70 adds the percentage of the pie to each label.
71
72 =item labelspconly
73
74 the segments are labels with their percentages only.
75
76 =item allcallouts
77
78 all labels are presented as callouts
79
80 =item outline
81
82 the pie segments are outlined.
83
84 =item dropshadow
85
86 the pie is given a drop shadow.
87
88 =back
89
90 =head1 EXAMPLES
91
92 Assuming:
93
94   # from the Netcraft September 2001 web survey
95   # http://www.netcraft.com/survey/
96   my @data   = qw(17874757  8146372   1321544  811406 );
97   my @labels = qw(Apache    Microsoft iPlanet  Zeus   );
98
99   my $pie = Imager::Graph::Pie->new;
100
101 First a simple graph, normal size, no labels:
102
103   my $img = $pie->draw(data=>\@data)
104     or die $pie->error;
105
106 label the segments:
107
108   # error handling omitted for brevity from now on
109   $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
110
111 just percentages in the segments:
112
113   $img = $pie->draw(data=>\@data, features=>'labelspconly');
114
115 add a legend as well:
116
117   $img = $pie->draw(data=>\@data, labels=>\@labels,
118                     features=>[ 'labelspconly', 'legend' ]);
119
120 and a title, but move the legend down, and add a dropshadow:
121
122   $img = $pie->draw(data=>\@data, labels=>\@labels,
123                     title=>'Netcraft Web Survey',
124                     legend=>{ valign=>'bottom' },
125                     features=>[ qw/labelspconly legend dropshadow/ ]);
126
127 something a bit prettier:
128
129   # requires Imager > 0.38
130   $img = $pie->draw(data=>\@data, labels=>\@labels,
131                     style=>'fount_lin', features=>'legend');
132
133 suitable for monochrome output:
134
135   # requires Imager > 0.38
136   $img = $pie->draw(data=>\@data, labels=>\@labels,
137                     style=>'mono', features=>'legend');
138
139 =cut
140
141 # this function is too long
142 sub draw {
143   my ($self, %opts) = @_;
144
145   $opts{data} 
146     or return $self->_error("No data parameter supplied");
147   my @data = @{$opts{data}};
148   my @labels;
149   @labels = @{$opts{labels}} if $opts{labels};
150
151   $self->_style_setup(\%opts);
152
153   my $style = $self->{_style};
154
155   my $img = $self->_make_img()
156     or return;
157
158   my $total = 0;
159   for my $item (@data) {
160     $total += $item;
161   }
162
163   my @chart_box = ( 0, 0, $img->getwidth-1, $img->getheight-1 );
164   if ($style->{title}{text}) {
165     $self->_draw_title($img, \@chart_box)
166       or return;
167   }
168
169   # consolidate any segments that are too small to display
170   $self->_consolidate_segments(\@data, \@labels, $total);
171
172   if ($style->{features}{legend} && $opts{labels}) {
173     $self->_draw_legend($img, \@labels, \@chart_box)
174       or return;
175   }
176
177   # the following code is fairly ugly
178   # it attempts to work out a good layout for the components of the chart
179   my @info;
180   my $index = 0;
181   my $pos = 0;
182   my @ebox = (0, 0, 0, 0);
183   defined(my $callout_outside = $self->_get_number('callout.outside'))
184     or return;
185   defined(my $callout_leadlen = $self->_get_number('callout.leadlen'))
186     or return;
187   defined(my $callout_gap = $self->_get_number('callout.gap'))
188     or return;
189   defined(my $label_vpad = $self->_get_number('label.vpad'))
190     or return;
191   defined(my $label_hpad = $self->_get_number('label.hpad'))
192     or return;
193   my $guessradius = 
194     int($self->_small_extent(\@chart_box) * $style->{pie}{guessfactor} * 0.5);
195   for my $data (@data) {
196     my $item = { data=>$data, index=>$index };
197     my $size = 2 * PI * $data / $total;
198     $item->{begin} = $pos;
199     $pos += $size;
200     $item->{end} = $pos;
201     if ($opts{labels}) {
202       $item->{text} = $labels[$index];
203     }
204     if ($style->{features}{labelspconly}) {
205       $item->{text} = 
206         $style->{label}{pconlyformat}->($data/$total * 100);
207     }
208     if ($item->{text}) {
209       if ($style->{features}{labelspc}) {
210         $item->{text} = 
211           $style->{label}{pcformat}->($item->{text}, $data/$total * 100);
212         $item->{label} = 1;
213       }
214       elsif ($style->{features}{labelspconly}) {
215         $item->{text} = 
216           $style->{label}{pconlyformat}->($data/$total * 100);
217         $item->{label} = 1;
218       }
219       elsif ($style->{features}{labels}) {
220         $item->{label} = 1;
221       }
222       $item->{lbox} = [ $self->_text_bbox($item->{text}, 'label') ];
223       if ($item->{label}) {
224         unless ($self->_fit_text(0, 0, 'label', $item->{text}, $guessradius,
225                                  $item->{begin}, $item->{end})) {
226           $item->{callout} = 1;
227         }
228       }
229       $item->{callout} = 1 if $style->{features}{allcallouts};
230       if ($item->{callout}) {
231         $item->{label} = 0;
232         $item->{cbox} = [ $self->_text_bbox($item->{text}, 'callout') ];
233         $item->{cangle} = ($item->{begin} + $item->{end}) / 2;
234         my $dist = cos($item->{cangle}) * ($guessradius+
235                                            $callout_outside);
236         my $co_size = $callout_leadlen + $callout_gap + $item->{cbox}[2];
237         if ($dist < 0) {
238           $dist -= $co_size - $guessradius;
239           $dist < $ebox[0] and $ebox[0] = $dist;
240         }
241         else {
242           $dist += $co_size - $guessradius;
243           $dist > $ebox[2] and $ebox[2] = $dist;
244         }
245       }
246     }
247     push(@info, $item);
248     ++$index;
249   }
250
251   my $radius = 
252     int($self->_small_extent(\@chart_box) * $style->{pie}{size} * 0.5);
253   my $max_width = $chart_box[2] - $chart_box[0] + $ebox[0] - $ebox[2];
254   if ($radius > $max_width / 2) {
255     $radius = $max_width / 2;
256   }
257   $chart_box[0] -= $ebox[0];
258   $chart_box[2] -= $ebox[2];
259   my $cx = int(($chart_box[0] + $chart_box[2]) / 2);
260   my $cy = int(($chart_box[1] + $chart_box[3]) / 2);
261   if ($style->{features}{dropshadow}) {
262     my @shadow_fill = $self->_get_fill('dropshadow.fill')
263       or return;
264     my $offx = $self->_get_number('dropshadow.offx')
265       or return;
266     my $offy = $self->_get_number('dropshadow.offy');
267     for my $item (@info) {
268       $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
269                 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
270                 @shadow_fill);
271     }
272     $self->_filter_region($img, 
273                           $cx+$offx-$radius-10, $cy+$offy-$radius-10, 
274                           $cx+$offx+$radius+10, $cy+$offy+$radius+10,
275                           'dropshadow.filter')
276       if $style->{dropshadow}{filter};
277   }
278
279   my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
280   for my $item (@info) {
281     my @fill = $self->_data_fill($item->{index}, \@fill_box)
282       or return;
283     $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
284               d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
285               @fill);
286   }
287   if ($style->{features}{outline}) {
288     my $outcolor = $self->_get_color('outline.line');
289     for my $item (@info) {
290       my $px = int($cx + $radius * cos($item->{begin}));
291       my $py = int($cy + $radius * sin($item->{begin}));
292       $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, color=>$outcolor);
293       for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
294         my $stroke_end = $i + PI/180;
295         $stroke_end = $item->{end} if $stroke_end > $item->{end};
296         my $nx = int($cx + $radius * cos($stroke_end));
297         my $ny = int($cy + $radius * sin($stroke_end));
298         $img->line(x1=>$px, y1=>$py, x2=>$nx, y2=>$ny, color=>$outcolor,
299                   antialias=>1);
300         ($px, $py) = ($nx, $ny);
301       }
302     }
303   }
304
305   my $callout_inside = $radius - $self->_get_number('callout.inside');
306   $callout_outside += $radius;
307   my %callout_text = $self->_text_style('callout');
308   my %label_text = $self->_text_style('label');
309   for my $label (@info) {
310     if ($label->{label}) {
311       my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
312                                  $label->{begin}, $label->{end});
313       if (@loc) {
314         my $tcx = ($loc[0]+$loc[2])/2;
315         my $tcy = ($loc[1]+$loc[3])/2;
316         #$img->box(xmin=>$loc[0], ymin=>$loc[1], xmax=>$loc[2], ymax=>$loc[3],
317         #          color=>Imager::Color->new(0,0,0));
318         $img->string(%label_text, x=>$tcx-$label->{lbox}[2]/2,
319                      'y'=>$tcy+$label->{lbox}[3]/2+$label->{lbox}[1],
320                      text=>$label->{text});
321       }
322       else {
323         $label->{callout} = 1;
324         $label->{cbox} = [ $self->_text_bbox($label->{text}, 'callout') ]; 
325         $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
326       }
327     }
328     if ($label->{callout}) {
329       my $ix = floor(0.5 + $cx + $callout_inside * cos($label->{cangle}));
330       my $iy = floor(0.5 + $cy + $callout_inside * sin($label->{cangle}));
331       my $ox = floor(0.5 + $cx + $callout_outside * cos($label->{cangle}));
332       my $oy = floor(0.5 + $cy + $callout_outside * sin($label->{cangle}));
333       my $lx = ($ox < $cx) ? $ox - $callout_leadlen : $ox + $callout_leadlen;
334       $img->line(x1=>$ix, y1=>$iy, x2=>$ox, y2=>$oy, antialias=>1,
335                  color=>$self->_get_color('callout.color'));
336       $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
337                  color=>$self->_get_color('callout.color'));
338       #my $tx = $lx + $callout_gap;
339       my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
340       if ($lx < $cx) {
341         $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2], 
342                      'y'=>$ty, text=>$label->{text});
343       }
344       else {
345         $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty, 
346                      text=>$label->{text});
347       }
348     }
349   }
350
351   $img;
352 }
353
354 =head1 INTERNAL FUNCTIONS
355
356 These are used in the implementation of Imager::Graph, and are
357 documented for debuggers and developers.
358
359 =over
360
361 =item _consolidate_segments($data, $labels, $total)
362
363 Consolidate segments that are too small into an 'others' segment.
364
365 =cut
366
367 sub _consolidate_segments {
368   my ($self, $data, $labels, $total) = @_;
369
370   my @others;
371   my $index;
372   for my $item (@$data) {
373     if ($item / $total < $self->{_style}{pie}{maxsegment}) {
374       push(@others, $index);
375     }
376     ++$index;
377   }
378   if (@others) {
379     my $others = 0;
380     for my $index (reverse @others) {
381       $others += $data->[$index];
382       splice(@$labels, $index, 1);
383       splice(@$data, $index, 1);
384     }
385     push(@$labels, $self->{_style}{otherlabel}) if @$labels;
386     push(@$data, $others);
387   }
388 }
389
390 # used for debugging
391 sub _test_line {
392   my ($x, $y, @l) = @_;
393
394   my $res = $l[0]*$x + $l[1] * $y + $l[2];
395   print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
396 }
397
398 =item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
399
400 Attempts to fit text into a pie segment with its center at ($cx, $cy)
401 with the given radius, covering the angles $begin through $end.
402
403 Returns a list defining the bounding box of the text if it does fit.
404
405 =cut
406
407 sub _fit_text {
408   my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
409
410   #print "fit: $cx, $cy '$text' $radius $begin $end\n";
411   my @tbox = $self->_text_bbox($text, $name);
412   my $tcx = floor(0.5+$cx + cos(($begin+$end)/2) * $radius *3/5);
413   my $tcy = floor(0.5+$cy + sin(($begin+$end)/2) * $radius *3/5);
414   my $topy = $tcy - $tbox[3]/2;
415   my $boty = $topy + $tbox[3];
416   my @lines;
417   for my $y ($topy, $boty) {
418     my %entry = ( 'y'=>$y );
419     $entry{line} = [ line_from_points($tcx, $y, $tcx+1, $y) ];
420     $entry{left} = -$radius;
421     $entry{right} = $radius;
422     for my $angle ($begin, $end) {
423       my $ex = $cx + cos($angle)*$radius;
424       my $ey = $cy + sin($angle)*$radius;
425       my @line = line_from_points($cx, $cy, $ex, $ey);
426       #_test_line($cx, $cy, @line);
427       #_test_line($ex, $ey, @line);
428       my $goodsign = $line[0] * $tcx + $line[1] * $tcy + $line[2];
429       for my $pos (@entry{qw/left right/}) {
430         my $sign = $line[0] * ($pos+$tcx) + $line[1] * $y + $line[2];
431         if ($goodsign * $sign < 0) {
432           if (my @p = intersect_lines(@line, @{$entry{line}})) {
433             # die "$goodsign $sign ($pos, $tcx) no intersect (@line) (@{$entry{line}})"  ; # this would be wierd
434             #_test_line(@p, @line);
435             #_test_line(@p, @{$entry{line}});
436             $pos = $p[0]-$tcx;
437           }
438           else {
439             return;
440           }
441             
442         }
443
444         # circle
445         my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx) 
446           + ($y - $cy) * ($y - $cy);
447         if ($dist2 > $radius * $radius) {
448           my @points = 
449             intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
450           while (@points) {
451             my @p = splice(@points, 0, 2);
452             if ($p[0] < $cx && $tcx+$pos < $p[0]) {
453               $pos = $p[0]-$tcx;
454             }
455             elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
456               $pos = $p[0]-$tcx;
457             }
458           }
459         }
460       }
461     }
462     push(@lines, \%entry);
463   }
464   my $left = $lines[0]{left} > $lines[1]{left} ? $lines[0]{left} : $lines[1]{left};
465   my $right = $lines[0]{right} < $lines[1]{right} ? $lines[0]{right} : $lines[1]{right};
466   return if $right - $left < $tbox[2];
467
468   return ($tcx+$left, $topy, $tcx+$right, $boty);
469 }
470
471 sub _composite {
472   ( 'pie', $_[0]->SUPER::_composite() );
473 }
474
475 sub _style_defs {
476   my ($self) = @_;
477
478   my %work = %{$self->SUPER::_style_defs()};
479   $work{otherlabel} = "(others)";
480   $work{features}{pieblur} = 1;
481   $work{pie} = 
482     {
483      blur => { 
484               type=>'conv',
485               coef=>[0.05, 0.1, 0.3, 1, 0.3, 0.1, 0.05]
486              },
487      guessfactor=>0.6,
488      size=>0.8,
489      maxsegment=> 0.05,
490     };
491
492   \%work;
493 }
494
495 1;
496 __END__
497
498 =back
499
500 =head1 AUTHOR
501
502 Tony Cook <tony@develop-help.com>
503
504 =head1 SEE ALSO
505
506 Imager::Graph(3), Imager(3), perl(1)
507
508 =cut