0ecc1320e29f39e577ac0813bb1a46fa58664a27
[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(
14                          data => [ $first_amount, $second_amount ],
15                          size => 350);
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.  If you supply a C<labels> parameter, you must supply a C<font> 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 PIE CHART STYLES
91
92 The following style values are specific to pie charts:
93
94 Controlling callouts, the C<callout> option:
95
96 =over
97
98 =item *
99
100 color - the color of the callout line and the callout text.
101
102 =item *
103
104 font, size - font and size of the callout text
105
106 =item *
107
108 outside - the distance the radial callout line goes outside the pie
109
110 =item *
111
112 leadlen - the length of the horizontal callout line from the end of
113 the radial line.
114
115 =item *
116
117 gap - the distance between the end of the horizontal callout line and
118 the label.
119
120 =item *
121
122 inside - the length of the radial callout line within the pie.
123
124 =back
125
126 The outline, line option controls the color of the pie segment
127 outlines, if enabled with the C<outline> feature.
128
129 Under C<pie>:
130
131 =over
132
133 =item *
134
135 maxsegment - any segment below this fraction of the total of the
136 segments will be put into the "others" segment.  Default: 0.01
137
138 =back
139
140 The top level C<otherlabel> setting controls the label for the
141 "others" segment, default "(others)".
142
143 =head1 EXAMPLES
144
145 Assuming:
146
147   # from the Netcraft September 2001 web survey
148   # http://www.netcraft.com/survey/
149   my @data   = qw(17874757  8146372   1321544  811406 );
150   my @labels = qw(Apache    Microsoft iPlanet  Zeus   );
151
152   my $pie = Imager::Graph::Pie->new;
153
154 First a simple graph, normal size, no labels:
155
156   my $img = $pie->draw(data=>\@data)
157     or die $pie->error;
158
159 label the segments:
160
161   # error handling omitted for brevity from now on
162   $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
163
164 just percentages in the segments:
165
166   $img = $pie->draw(data=>\@data, features=>'labelspconly');
167
168 add a legend as well:
169
170   $img = $pie->draw(data=>\@data, labels=>\@labels,
171                     features=>[ 'labelspconly', 'legend' ]);
172
173 and a title, but move the legend down, and add a dropshadow:
174
175   $img = $pie->draw(data=>\@data, labels=>\@labels,
176                     title=>'Netcraft Web Survey',
177                     legend=>{ valign=>'bottom' },
178                     features=>[ qw/labelspconly legend dropshadow/ ]);
179
180 something a bit prettier:
181
182   $img = $pie->draw(data=>\@data, labels=>\@labels,
183                     style=>'fount_lin', features=>'legend');
184
185 suitable for monochrome output:
186
187   $img = $pie->draw(data=>\@data, labels=>\@labels,
188                     style=>'mono', features=>'legend');
189
190 =cut
191
192 # this function is too long
193 sub draw {
194   my ($self, %opts) = @_;
195
196   $self->_processOptions(\%opts);
197
198   if (!$self->_validInput()) {
199     return;
200   }
201
202   my @data = @{$self->_getDataSeries()->[0]->{'data'}};
203
204   my @labels = @{$self->_getLabels() || []};
205
206
207   $self->_style_setup(\%opts);
208
209   my $style = $self->{_style};
210
211   my $img = $self->_make_img()
212     or return;
213
214   my @chart_box = ( 0, 0, $img->getwidth-1, $img->getheight-1 );
215   if ($style->{title}{text}) {
216     $self->_draw_title($img, \@chart_box)
217       or return;
218   }
219
220   my $total = 0;
221   for my $item (@data) {
222     $total += $item;
223   }
224
225   # consolidate any segments that are too small to display
226   $self->_consolidate_segments(\@data, \@labels, $total);
227
228   if ($style->{features}{legend} && (scalar @labels)) {
229     $self->_draw_legend($img, \@labels, \@chart_box)
230       or return;
231   }
232
233   # the following code is fairly ugly
234   # it attempts to work out a good layout for the components of the chart
235   my @info;
236   my $index = 0;
237   my $pos = 0;
238   my @ebox = (0, 0, 0, 0);
239   defined(my $callout_outside = $self->_get_number('callout.outside'))
240     or return;
241   defined(my $callout_leadlen = $self->_get_number('callout.leadlen'))
242     or return;
243   defined(my $callout_gap = $self->_get_number('callout.gap'))
244     or return;
245   defined(my $label_vpad = $self->_get_number('label.vpad'))
246     or return;
247   defined(my $label_hpad = $self->_get_number('label.hpad'))
248     or return;
249   my $guessradius = 
250     int($self->_small_extent(\@chart_box) * $style->{pie}{guessfactor} * 0.5);
251   for my $data (@data) {
252     my $item = { data=>$data, index=>$index };
253     my $size = 2 * PI * $data / $total;
254     $item->{begin} = $pos;
255     $pos += $size;
256     $item->{end} = $pos;
257     if (scalar @labels) {
258       $item->{text} = $labels[$index];
259     }
260     if ($style->{features}{labelspconly}) {
261       $item->{text} = 
262         $style->{label}{pconlyformat}->($data/$total * 100);
263     }
264     if ($item->{text}) {
265       if ($style->{features}{labelspc}) {
266         $item->{text} = 
267           $style->{label}{pcformat}->($item->{text}, $data/$total * 100);
268         $item->{label} = 1;
269       }
270       elsif ($style->{features}{labelspconly}) {
271         $item->{text} = 
272           $style->{label}{pconlyformat}->($data/$total * 100);
273         $item->{label} = 1;
274       }
275       elsif ($style->{features}{labels}) {
276         $item->{label} = 1;
277       }
278       $item->{callout} = 1 if $style->{features}{allcallouts};
279       if (!$item->{callout}) {
280         my @lbox = $self->_text_bbox($item->{text}, 'label')
281           or return;
282         $item->{lbox} = \@lbox;
283         if ($item->{label}) {
284           unless ($self->_fit_text(0, 0, 'label', $item->{text}, $guessradius,
285                                    $item->{begin}, $item->{end})) {
286             $item->{callout} = 1;
287           }
288         }
289       }
290       if ($item->{callout}) {
291         $item->{label} = 0;
292         my @cbox = $self->_text_bbox($item->{text}, 'callout')
293           or return;
294         $item->{cbox} = \@cbox;
295         $item->{cangle} = ($item->{begin} + $item->{end}) / 2;
296         my $dist = cos($item->{cangle}) * ($guessradius+
297                                            $callout_outside);
298         my $co_size = $callout_leadlen + $callout_gap + $item->{cbox}[2];
299         if ($dist < 0) {
300           $dist -= $co_size - $guessradius;
301           $dist < $ebox[0] and $ebox[0] = $dist;
302         }
303         else {
304           $dist += $co_size - $guessradius;
305           $dist > $ebox[2] and $ebox[2] = $dist;
306         }
307       }
308     }
309     push(@info, $item);
310     ++$index;
311   }
312
313   my $radius = 
314     int($self->_small_extent(\@chart_box) * $style->{pie}{size} * 0.5);
315   my $max_width = $chart_box[2] - $chart_box[0] + $ebox[0] - $ebox[2];
316   if ($radius > $max_width / 2) {
317     $radius = int($max_width / 2);
318   }
319   $chart_box[0] -= $ebox[0];
320   $chart_box[2] -= $ebox[2];
321   my $cx = int(($chart_box[0] + $chart_box[2]) / 2);
322   my $cy = int(($chart_box[1] + $chart_box[3]) / 2);
323   if ($style->{features}{dropshadow}) {
324     my @shadow_fill = $self->_get_fill('dropshadow.fill')
325       or return;
326     my $offx = $self->_get_number('dropshadow.offx')
327       or return;
328     my $offy = $self->_get_number('dropshadow.offy');
329     for my $item (@info) {
330       $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
331                 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
332                 @shadow_fill);
333     }
334     $self->_filter_region($img, 
335                           $cx+$offx-$radius-10, $cy+$offy-$radius-10, 
336                           $cx+$offx+$radius+10, $cy+$offy+$radius+10,
337                           'dropshadow.filter')
338       if $style->{dropshadow}{filter};
339   }
340
341   my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
342   for my $item (@info) {
343     $item->{begin} < $item->{end}
344       or next;
345     my @fill = $self->_data_fill($item->{index}, \@fill_box)
346       or return;
347     $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
348               d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
349               @fill);
350   }
351   if ($style->{features}{outline}) {
352     my $outcolor = $self->_get_color('outline.line');
353     for my $item (@info) {
354       my $px = int($cx + $radius * cos($item->{begin}));
355       my $py = int($cy + $radius * sin($item->{begin}));
356       $item->{begin} < $item->{end}
357         or next;
358       $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, color=>$outcolor);
359       for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
360         my $stroke_end = $i + PI/180;
361         $stroke_end = $item->{end} if $stroke_end > $item->{end};
362         my $nx = int($cx + $radius * cos($stroke_end));
363         my $ny = int($cy + $radius * sin($stroke_end));
364         $img->line(x1=>$px, y1=>$py, x2=>$nx, y2=>$ny, color=>$outcolor,
365                   antialias=>1);
366         ($px, $py) = ($nx, $ny);
367       }
368     }
369   }
370
371   my $callout_inside = $radius - $self->_get_number('callout.inside');
372   $callout_outside += $radius;
373   my %callout_text;
374   my %label_text;
375   for my $label (@info) {
376     if ($label->{label} && !$label->{callout}) {
377       # at this point we know we need the label font, to calculate
378       # whether the label will fit if anything else
379       unless (%label_text) {
380         %label_text = $self->_text_style('label')
381           or return;
382       }
383       my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
384                                  $label->{begin}, $label->{end});
385       if (@loc) {
386         my $tcx = ($loc[0]+$loc[2])/2;
387         my $tcy = ($loc[1]+$loc[3])/2;
388         #$img->box(xmin=>$loc[0], ymin=>$loc[1], xmax=>$loc[2], ymax=>$loc[3],
389         #          color=>Imager::Color->new(0,0,0));
390         $img->string(%label_text, x=>$tcx-$label->{lbox}[2]/2,
391                      'y'=>$tcy+$label->{lbox}[3]/2+$label->{lbox}[1],
392                      text=>$label->{text});
393       }
394       else {
395         $label->{callout} = 1;
396         my @cbox = $self->_text_bbox($label->{text}, 'callout')
397           or return;
398         $label->{cbox} = \@cbox; 
399         $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
400       }
401     }
402     if ($label->{callout}) {
403       unless (%callout_text) {
404         %callout_text = $self->_text_style('callout')
405           or return;
406       }
407       my $ix = floor(0.5 + $cx + $callout_inside * cos($label->{cangle}));
408       my $iy = floor(0.5 + $cy + $callout_inside * sin($label->{cangle}));
409       my $ox = floor(0.5 + $cx + $callout_outside * cos($label->{cangle}));
410       my $oy = floor(0.5 + $cy + $callout_outside * sin($label->{cangle}));
411       my $lx = ($ox < $cx) ? $ox - $callout_leadlen : $ox + $callout_leadlen;
412       $img->line(x1=>$ix, y1=>$iy, x2=>$ox, y2=>$oy, antialias=>1,
413                  color=>$self->_get_color('callout.color'));
414       $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
415                  color=>$self->_get_color('callout.color'));
416       #my $tx = $lx + $callout_gap;
417       my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
418       if ($lx < $cx) {
419         $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2], 
420                      'y'=>$ty, text=>$label->{text});
421       }
422       else {
423         $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty, 
424                      text=>$label->{text});
425       }
426     }
427   }
428
429   $img;
430 }
431
432 sub _validInput {
433   my $self = shift;
434
435   if (!defined $self->_getDataSeries() || !scalar @{$self->_getDataSeries()}) {
436     return $self->_error("No data supplied");
437   }
438
439   if (!scalar @{$self->_getDataSeries()->[0]->{'data'}}) {
440     return $self->_error("No values in data series");
441   }
442
443   my @data = @{$self->_getDataSeries()->[0]->{'data'}};
444
445   my $total = 0;
446   {
447     my $index = 0;
448     for my $item (@data) {
449       $item < 0
450         and return $self->_error("Data index $index is less than zero");
451
452       $total += $item;
453
454       ++$index;
455     }
456   }
457   $total == 0
458     and return $self->_error("Sum of all data values is zero");
459
460   return 1;
461 }
462
463 =head1 INTERNAL FUNCTIONS
464
465 These are used in the implementation of Imager::Graph, and are
466 documented for debuggers and developers.
467
468 =over
469
470 =item _consolidate_segments($data, $labels, $total)
471
472 Consolidate segments that are too small into an 'others' segment.
473
474 =cut
475
476 sub _consolidate_segments {
477   my ($self, $data, $labels, $total) = @_;
478
479   my @others;
480   my $index;
481   for my $item (@$data) {
482     if ($item / $total < $self->{_style}{pie}{maxsegment}) {
483       push(@others, $index);
484     }
485     ++$index;
486   }
487   if (@others) {
488     my $others = 0;
489     for my $index (reverse @others) {
490       $others += $data->[$index];
491       splice(@$labels, $index, 1);
492       splice(@$data, $index, 1);
493     }
494     push(@$labels, $self->{_style}{otherlabel}) if @$labels;
495     push(@$data, $others);
496   }
497 }
498
499 # used for debugging
500 sub _test_line {
501   my ($x, $y, @l) = @_;
502
503   my $res = $l[0]*$x + $l[1] * $y + $l[2];
504   print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
505 }
506
507 =item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
508
509 Attempts to fit text into a pie segment with its center at ($cx, $cy)
510 with the given radius, covering the angles $begin through $end.
511
512 Returns a list defining the bounding box of the text if it does fit.
513
514 =cut
515
516 sub _fit_text {
517   my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
518
519   #print "fit: $cx, $cy '$text' $radius $begin $end\n";
520   my @tbox = $self->_text_bbox($text, $name)
521     or return;
522   my $tcx = floor(0.5+$cx + cos(($begin+$end)/2) * $radius *3/5);
523   my $tcy = floor(0.5+$cy + sin(($begin+$end)/2) * $radius *3/5);
524   my $topy = $tcy - $tbox[3]/2;
525   my $boty = $topy + $tbox[3];
526   my @lines;
527   for my $y ($topy, $boty) {
528     my %entry = ( 'y'=>$y );
529     $entry{line} = [ line_from_points($tcx, $y, $tcx+1, $y) ];
530     $entry{left} = -$radius;
531     $entry{right} = $radius;
532     for my $angle ($begin, $end) {
533       my $ex = $cx + cos($angle)*$radius;
534       my $ey = $cy + sin($angle)*$radius;
535       my @line = line_from_points($cx, $cy, $ex, $ey);
536       #_test_line($cx, $cy, @line);
537       #_test_line($ex, $ey, @line);
538       my $goodsign = $line[0] * $tcx + $line[1] * $tcy + $line[2];
539       for my $pos (@entry{qw/left right/}) {
540         my $sign = $line[0] * ($pos+$tcx) + $line[1] * $y + $line[2];
541         if ($goodsign * $sign < 0) {
542           if (my @p = intersect_lines(@line, @{$entry{line}})) {
543             # die "$goodsign $sign ($pos, $tcx) no intersect (@line) (@{$entry{line}})"  ; # this would be wierd
544             #_test_line(@p, @line);
545             #_test_line(@p, @{$entry{line}});
546             $pos = $p[0]-$tcx;
547           }
548           else {
549             return;
550           }
551             
552         }
553
554         # circle
555         my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx) 
556           + ($y - $cy) * ($y - $cy);
557         if ($dist2 > $radius * $radius) {
558           my @points = 
559             intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
560           while (@points) {
561             my @p = splice(@points, 0, 2);
562             if ($p[0] < $cx && $tcx+$pos < $p[0]) {
563               $pos = $p[0]-$tcx;
564             }
565             elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
566               $pos = $p[0]-$tcx;
567             }
568           }
569         }
570       }
571     }
572     push(@lines, \%entry);
573   }
574   my $left = $lines[0]{left} > $lines[1]{left} ? $lines[0]{left} : $lines[1]{left};
575   my $right = $lines[0]{right} < $lines[1]{right} ? $lines[0]{right} : $lines[1]{right};
576   return if $right - $left < $tbox[2];
577
578   return ($tcx+$left, $topy, $tcx+$right, $boty);
579 }
580
581 sub _composite {
582   ( 'pie', $_[0]->SUPER::_composite() );
583 }
584
585 sub _style_defs {
586   my ($self) = @_;
587
588   my %work = %{$self->SUPER::_style_defs()};
589   $work{otherlabel} = "(others)";
590   $work{pie} = 
591     {
592      guessfactor=>0.6,
593      size=>0.8,
594      maxsegment=> 0.01,
595     };
596
597   \%work;
598 }
599
600 1;
601 __END__
602
603 =back
604
605 =head1 AUTHOR
606
607 Tony Cook <tony@develop-help.com>
608
609 =head1 SEE ALSO
610
611 Imager::Graph(3), Imager(3), perl(1)
612
613 =cut