changes from Patrick Michaud, line, bar, stacked column graphs
[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
59=item legend
60
61adds a legend to your graph. Requires the labels parameter
62
63=item labels
64
65labels each segment of the graph. If the label doesn't fit inside the
66segment it is presented as a callout.
67
68=item labelspc
69
70adds the percentage of the pie to each label.
71
72=item labelspconly
73
74the segments are labels with their percentages only.
75
76=item allcallouts
77
78all labels are presented as callouts
79
35574351
TC
80=item outline
81
82the pie segments are outlined.
83
84=item dropshadow
85
86the pie is given a drop shadow.
87
88=back
89
320f5a49
TC
90=head1 PIE CHART STYLES
91
92The following style values are specific to pie charts:
93
94Controlling callouts, the C<callout> option:
95
96=over
97
98=item *
99
100color - the color of the callout line and the callout text.
101
102=item *
103
104font, size - font and size of the callout text
105
106=item *
107
108outside - the distance the radial callout line goes outside the pie
109
110=item *
111
112leadlen - the length of the horizontal callout line from the end of
113the radial line.
114
115=item *
116
117gap - the distance between the end of the horizontal callout line and
118the label.
119
120=item *
121
122inside - the length of the radial callout line within the pie.
123
124=back
125
126The outline, line option controls the color of the pie segment
127outlines, if enabled with the C<outline> feature.
128
129Under C<pie>:
130
131=over
132
133=item *
134
135maxsegment - any segment below this fraction of the total of the
136segments will be put into the "others" segment. Default: 0.01
137
138=back
139
140The top level C<otherlabel> setting controls the label for the
141"others" segment, default "(others)".
142
35574351
TC
143=head1 EXAMPLES
144
145Assuming:
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
154First a simple graph, normal size, no labels:
155
156 my $img = $pie->draw(data=>\@data)
157 or die $pie->error;
158
159label the segments:
160
161 # error handling omitted for brevity from now on
162 $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
163
164just percentages in the segments:
165
166 $img = $pie->draw(data=>\@data, features=>'labelspconly');
167
168add a legend as well:
169
170 $img = $pie->draw(data=>\@data, labels=>\@labels,
171 features=>[ 'labelspconly', 'legend' ]);
172
173and 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
180something a bit prettier:
181
35574351
TC
182 $img = $pie->draw(data=>\@data, labels=>\@labels,
183 style=>'fount_lin', features=>'legend');
184
185suitable for monochrome output:
186
35574351
TC
187 $img = $pie->draw(data=>\@data, labels=>\@labels,
188 style=>'mono', features=>'legend');
189
190=cut
191
192# this function is too long
193sub draw {
194 my ($self, %opts) = @_;
195
dfd889da 196 $self->_processOptions(\%opts);
35574351 197
dfd889da 198 if (!$self->_validInput()) {
199 return;
d7fd5863 200 }
dfd889da 201
202 my @data = @{$self->_getDataSeries()->[0]->{'data'}};
203
204 my @labels = @{$self->_getLabels() || []};
205
d7fd5863 206
35574351
TC
207 $self->_style_setup(\%opts);
208
209 my $style = $self->{_style};
210
211 my $img = $self->_make_img()
212 or return;
213
35574351
TC
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
dfd889da 220 my $total = 0;
221 for my $item (@data) {
222 $total += $item;
223 }
224
35574351
TC
225 # consolidate any segments that are too small to display
226 $self->_consolidate_segments(\@data, \@labels, $total);
227
dfd889da 228 if ($style->{features}{legend} && (scalar @labels)) {
35574351
TC
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;
dfd889da 257 if (scalar @labels) {
35574351
TC
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 }
d7fd5863
TC
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 }
35574351
TC
288 }
289 }
35574351
TC
290 if ($item->{callout}) {
291 $item->{label} = 0;
d7fd5863
TC
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+
35574351 297 $callout_outside);
d7fd5863
TC
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 }
35574351
TC
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) {
3c9a5609 317 $radius = int($max_width / 2);
35574351
TC
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) {
bfcf9414 330 $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
35574351
TC
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 }
bfcf9414 340
35574351
TC
341 my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
342 for my $item (@info) {
26c93f46
TC
343 $item->{begin} < $item->{end}
344 or next;
35574351
TC
345 my @fill = $self->_data_fill($item->{index}, \@fill_box)
346 or return;
bfcf9414 347 $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
35574351
TC
348 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
349 @fill);
350 }
35574351
TC
351 if ($style->{features}{outline}) {
352 my $outcolor = $self->_get_color('outline.line');
353 for my $item (@info) {
bfcf9414
TC
354 my $px = int($cx + $radius * cos($item->{begin}));
355 my $py = int($cy + $radius * sin($item->{begin}));
26c93f46 356 $item->{begin} < $item->{end}
d7fd5863 357 or next;
35574351
TC
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) {
d7fd5863
TC
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);
35574351
TC
367 }
368 }
369 }
370
371 my $callout_inside = $radius - $self->_get_number('callout.inside');
372 $callout_outside += $radius;
d7fd5863
TC
373 my %callout_text;
374 my %label_text;
35574351 375 for my $label (@info) {
d7fd5863
TC
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 }
35574351
TC
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;
d7fd5863
TC
396 my @cbox = $self->_text_bbox($label->{text}, 'callout')
397 or return;
5d622bb8 398 $label->{cbox} = \@cbox;
35574351
TC
399 $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
400 }
401 }
402 if ($label->{callout}) {
d7fd5863
TC
403 unless (%callout_text) {
404 %callout_text = $self->_text_style('callout')
405 or return;
406 }
35574351
TC
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,
d7fd5863 413 color=>$self->_get_color('callout.color'));
35574351 414 $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
d7fd5863 415 color=>$self->_get_color('callout.color'));
35574351
TC
416 #my $tx = $lx + $callout_gap;
417 my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
418 if ($lx < $cx) {
d7fd5863
TC
419 $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
420 'y'=>$ty, text=>$label->{text});
35574351
TC
421 }
422 else {
d7fd5863
TC
423 $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
424 text=>$label->{text});
35574351
TC
425 }
426 }
427 }
428
429 $img;
430}
431
dfd889da 432sub _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
35574351
TC
463=head1 INTERNAL FUNCTIONS
464
465These are used in the implementation of Imager::Graph, and are
466documented for debuggers and developers.
467
468=over
469
470=item _consolidate_segments($data, $labels, $total)
471
472Consolidate segments that are too small into an 'others' segment.
473
474=cut
475
476sub _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
35574351
TC
499# used for debugging
500sub _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
509Attempts to fit text into a pie segment with its center at ($cx, $cy)
510with the given radius, covering the angles $begin through $end.
511
512Returns a list defining the bounding box of the text if it does fit.
513
514=cut
515
516sub _fit_text {
517 my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
518
519 #print "fit: $cx, $cy '$text' $radius $begin $end\n";
d7fd5863
TC
520 my @tbox = $self->_text_bbox($text, $name)
521 or return;
35574351
TC
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
581sub _composite {
582 ( 'pie', $_[0]->SUPER::_composite() );
583}
584
585sub _style_defs {
586 my ($self) = @_;
587
588 my %work = %{$self->SUPER::_style_defs()};
589 $work{otherlabel} = "(others)";
35574351
TC
590 $work{pie} =
591 {
35574351
TC
592 guessfactor=>0.6,
593 size=>0.8,
320f5a49 594 maxsegment=> 0.01,
35574351
TC
595 };
596
597 \%work;
598}
599
6001;
601__END__
602
54ada35d
TC
603=back
604
35574351
TC
605=head1 AUTHOR
606
607Tony Cook <tony@develop-help.com>
608
609=head1 SEE ALSO
610
611Imager::Graph(3), Imager(3), perl(1)
612
613=cut