define new style settings text.aa, lineaa and fill.aa each based on
[imager-graph.git] / lib / Imager / Graph / Pie.pm
CommitLineData
35574351
TC
1package 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
81453d28 13 my $img = $chart->draw(
d7fd5863
TC
14 data => [ $first_amount, $second_amount ],
15 size => 350);
35574351
TC
16
17=head1 DESCRIPTION
18
19Imager::Graph::Pie is intender to make it simple to use L<Imager> to
20create good looking pie graphs.
21
22Most of the basic layout and color selection is handed off to
23L<Imager::Graph>.
24
25=over
26
27=cut
28
29use strict;
30use vars qw(@ISA);
31use Imager::Graph;
32@ISA = qw(Imager::Graph);
33use Imager::Graph::Util;
34use POSIX qw(floor);
35
36use constant PI => 3.1415926535;
37
35574351
TC
38=item $graph->draw(...)
39
40Draws a pie graph onto a new image and returns the image.
41
81453d28 42You 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.
35574351
TC
43
44The C<data> parameter should be a reference to an array containing the
45data the pie graph should present.
46
47The C<labels> parameter is a reference to an array of labels,
48corresponding to the values in C<data>.
49
50=back
51
52=head1 FEATURES
53
54As described in L<Imager::Graph> you can enable extra features for
55your graph. The features you can use with pie graphs are:
56
57=over
58
2eac77fc 59=item show_callouts_onAll_segments()
60
61all labels are presented as callouts
62
63=cut
64
65sub show_callouts_onAll_segments {
66 $_[0]->{'custom_style'}->{'features'}->{'allcallouts'} = 1;
67}
68
69=item show_only_label_percentages()
70
71only show the percentage, not the labels.
72
73=cut
74
75sub show_only_label_percentages {
76 $_[0]->{'custom_style'}->{'features'}->{'labelspconly'} = 1;
77}
78
79=item show_label_percentages()
80
81adds the percentage of the pie to each label.
82
83=cut
84
85sub show_label_percentages {
86 $_[0]->{'custom_style'}->{'features'}->{'labelspc'} = 1;
87}
88
89=back
90
91Additionally, arguments can be added to draw() :
92
93=over
94
35574351
TC
95=item legend
96
97adds a legend to your graph. Requires the labels parameter
98
99=item labels
100
101labels each segment of the graph. If the label doesn't fit inside the
102segment it is presented as a callout.
103
104=item labelspc
105
106adds the percentage of the pie to each label.
107
108=item labelspconly
109
110the segments are labels with their percentages only.
111
112=item allcallouts
113
114all labels are presented as callouts
115
35574351
TC
116=item outline
117
118the pie segments are outlined.
119
120=item dropshadow
121
122the pie is given a drop shadow.
123
124=back
125
320f5a49
TC
126=head1 PIE CHART STYLES
127
128The following style values are specific to pie charts:
129
130Controlling callouts, the C<callout> option:
131
132=over
133
134=item *
135
136color - the color of the callout line and the callout text.
137
138=item *
139
140font, size - font and size of the callout text
141
142=item *
143
144outside - the distance the radial callout line goes outside the pie
145
146=item *
147
148leadlen - the length of the horizontal callout line from the end of
149the radial line.
150
151=item *
152
153gap - the distance between the end of the horizontal callout line and
154the label.
155
156=item *
157
158inside - the length of the radial callout line within the pie.
159
160=back
161
162The outline, line option controls the color of the pie segment
163outlines, if enabled with the C<outline> feature.
164
165Under C<pie>:
166
167=over
168
169=item *
170
171maxsegment - any segment below this fraction of the total of the
172segments will be put into the "others" segment. Default: 0.01
173
174=back
175
176The top level C<otherlabel> setting controls the label for the
177"others" segment, default "(others)".
178
35574351
TC
179=head1 EXAMPLES
180
181Assuming:
182
183 # from the Netcraft September 2001 web survey
184 # http://www.netcraft.com/survey/
185 my @data = qw(17874757 8146372 1321544 811406 );
2eac77fc 186 my @labels = qw(Apache Microsoft i_planet Zeus );
35574351
TC
187
188 my $pie = Imager::Graph::Pie->new;
189
190First a simple graph, normal size, no labels:
191
192 my $img = $pie->draw(data=>\@data)
193 or die $pie->error;
194
195label the segments:
196
197 # error handling omitted for brevity from now on
198 $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
199
200just percentages in the segments:
201
202 $img = $pie->draw(data=>\@data, features=>'labelspconly');
203
204add a legend as well:
205
206 $img = $pie->draw(data=>\@data, labels=>\@labels,
207 features=>[ 'labelspconly', 'legend' ]);
208
209and 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
216something a bit prettier:
217
35574351
TC
218 $img = $pie->draw(data=>\@data, labels=>\@labels,
219 style=>'fount_lin', features=>'legend');
220
221suitable for monochrome output:
222
35574351
TC
223 $img = $pie->draw(data=>\@data, labels=>\@labels,
224 style=>'mono', features=>'legend');
225
226=cut
227
228# this function is too long
229sub draw {
230 my ($self, %opts) = @_;
231
2eac77fc 232 my $data_series = $self->_get_data_series(\%opts);
35574351 233
2eac77fc 234 $self->_valid_input($data_series)
a17e870a 235 or return;
dfd889da 236
a17e870a 237 my @data = @{$data_series->[0]->{'data'}};
dfd889da 238
2eac77fc 239 my @labels = @{$self->_get_labels(\%opts) || []};
d7fd5863 240
35574351
TC
241 $self->_style_setup(\%opts);
242
243 my $style = $self->{_style};
244
245 my $img = $self->_make_img()
246 or return;
247
35574351
TC
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
dfd889da 254 my $total = 0;
255 for my $item (@data) {
256 $total += $item;
257 }
258
35574351
TC
259 # consolidate any segments that are too small to display
260 $self->_consolidate_segments(\@data, \@labels, $total);
261
dfd889da 262 if ($style->{features}{legend} && (scalar @labels)) {
35574351
TC
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;
dfd889da 291 if (scalar @labels) {
35574351
TC
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 }
d7fd5863
TC
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 }
35574351
TC
322 }
323 }
35574351
TC
324 if ($item->{callout}) {
325 $item->{label} = 0;
d7fd5863
TC
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+
35574351 331 $callout_outside);
d7fd5863
TC
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 }
35574351
TC
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) {
3c9a5609 351 $radius = int($max_width / 2);
35574351
TC
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) {
bfcf9414 364 $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
35574351
TC
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 }
bfcf9414 374
35574351 375 my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
49a35584 376 my $fill_aa = $self->_get_number('fill.aa');
35574351 377 for my $item (@info) {
26c93f46
TC
378 $item->{begin} < $item->{end}
379 or next;
35574351
TC
380 my @fill = $self->_data_fill($item->{index}, \@fill_box)
381 or return;
49a35584 382 $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => $fill_aa,
35574351
TC
383 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
384 @fill);
385 }
35574351 386 if ($style->{features}{outline}) {
49a35584
TC
387 my %outstyle = $self->_line_style('outline');
388 my $out_radius = 0.5 + $radius;
35574351 389 for my $item (@info) {
49a35584
TC
390 my $px = int($cx + $out_radius * cos($item->{begin}));
391 my $py = int($cy + $out_radius * sin($item->{begin}));
26c93f46 392 $item->{begin} < $item->{end}
d7fd5863 393 or next;
49a35584 394 $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, %outstyle);
35574351 395 for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
d7fd5863
TC
396 my $stroke_end = $i + PI/180;
397 $stroke_end = $item->{end} if $stroke_end > $item->{end};
49a35584
TC
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);
d7fd5863 401 ($px, $py) = ($nx, $ny);
35574351
TC
402 }
403 }
404 }
405
406 my $callout_inside = $radius - $self->_get_number('callout.inside');
407 $callout_outside += $radius;
d7fd5863
TC
408 my %callout_text;
409 my %label_text;
49a35584
TC
410 my %callout_line;
411 my $leader_aa = $self->_get_number('callout.leadaa');
35574351 412 for my $label (@info) {
d7fd5863
TC
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 }
35574351
TC
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],
49a35584 429 text=>$label->{text});
35574351
TC
430 }
431 else {
432 $label->{callout} = 1;
d7fd5863
TC
433 my @cbox = $self->_text_bbox($label->{text}, 'callout')
434 or return;
5d622bb8 435 $label->{cbox} = \@cbox;
35574351
TC
436 $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
437 }
438 }
439 if ($label->{callout}) {
d7fd5863
TC
440 unless (%callout_text) {
441 %callout_text = $self->_text_style('callout')
442 or return;
49a35584 443 %callout_line = $self->_line_style('callout');
d7fd5863 444 }
35574351
TC
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;
49a35584
TC
450 $img->polyline(points => [ [ $ix, $iy ],
451 [ $ox, $oy ],
452 [ $lx, $oy ] ],
453 %callout_line);
35574351
TC
454 #my $tx = $lx + $callout_gap;
455 my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
456 if ($lx < $cx) {
d7fd5863 457 $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
49a35584 458 'y'=>$ty, text=>$label->{text});
35574351
TC
459 }
460 else {
d7fd5863 461 $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
49a35584 462 text=>$label->{text});
35574351
TC
463 }
464 }
465 }
466
467 $img;
468}
469
2eac77fc 470sub _valid_input {
a17e870a 471 my ($self, $data_series) = @_;
dfd889da 472
a17e870a 473 if (!defined $data_series || !scalar @$data_series) {
dfd889da 474 return $self->_error("No data supplied");
475 }
476
a17e870a
TC
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) {
dfd889da 483 return $self->_error("No values in data series");
484 }
485
dfd889da 486 my $total = 0;
487 {
488 my $index = 0;
a17e870a 489 for my $item (@$data) {
dfd889da 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
35574351
TC
504=head1 INTERNAL FUNCTIONS
505
506These are used in the implementation of Imager::Graph, and are
507documented for debuggers and developers.
508
509=over
510
511=item _consolidate_segments($data, $labels, $total)
512
513Consolidate segments that are too small into an 'others' segment.
514
515=cut
516
517sub _consolidate_segments {
518 my ($self, $data, $labels, $total) = @_;
519
520 my @others;
2eac77fc 521 my $index = 0;
35574351
TC
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
35574351
TC
540# used for debugging
541sub _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
550Attempts to fit text into a pie segment with its center at ($cx, $cy)
551with the given radius, covering the angles $begin through $end.
552
553Returns a list defining the bounding box of the text if it does fit.
554
555=cut
556
557sub _fit_text {
558 my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
559
560 #print "fit: $cx, $cy '$text' $radius $begin $end\n";
d7fd5863
TC
561 my @tbox = $self->_text_bbox($text, $name)
562 or return;
35574351
TC
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
622sub _composite {
623 ( 'pie', $_[0]->SUPER::_composite() );
624}
625
626sub _style_defs {
627 my ($self) = @_;
628
629 my %work = %{$self->SUPER::_style_defs()};
630 $work{otherlabel} = "(others)";
35574351
TC
631 $work{pie} =
632 {
35574351
TC
633 guessfactor=>0.6,
634 size=>0.8,
320f5a49 635 maxsegment=> 0.01,
35574351
TC
636 };
637
638 \%work;
639}
640
6411;
642__END__
643
54ada35d
TC
644=back
645
35574351
TC
646=head1 AUTHOR
647
648Tony Cook <tony@develop-help.com>
649
650=head1 SEE ALSO
651
652Imager::Graph(3), Imager(3), perl(1)
653
654=cut