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