1 package Imager::Graph::Pie;
5 Imager::Graph::Pie - a tool for drawing pie charts on Imager images
9 use Imager::Graph::Pie;
11 my $chart = Imager::Graph::Pie->new;
12 # see Imager::Graph for options
13 my $img = $chart->draw(
14 data => [ $first_amount, $second_amount ],
19 Imager::Graph::Pie is intender to make it simple to use L<Imager> to
20 create good looking pie graphs.
22 Most of the basic layout and color selection is handed off to
32 @ISA = qw(Imager::Graph);
33 use Imager::Graph::Util;
36 use constant PI => 3.1415926535;
38 =item $graph->draw(...)
40 Draws a pie graph onto a new image and returns the image.
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.
44 The C<data> parameter should be a reference to an array containing the
45 data the pie graph should present.
47 The C<labels> parameter is a reference to an array of labels,
48 corresponding to the values in C<data>.
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:
61 adds a legend to your graph. Requires the labels parameter
65 labels each segment of the graph. If the label doesn't fit inside the
66 segment it is presented as a callout.
70 adds the percentage of the pie to each label.
74 the segments are labels with their percentages only.
78 all labels are presented as callouts
82 the pie segments are outlined.
86 the pie is given a drop shadow.
90 =head1 PIE CHART STYLES
92 The following style values are specific to pie charts:
94 Controlling callouts, the C<callout> option:
100 color - the color of the callout line and the callout text.
104 font, size - font and size of the callout text
108 outside - the distance the radial callout line goes outside the pie
112 leadlen - the length of the horizontal callout line from the end of
117 gap - the distance between the end of the horizontal callout line and
122 inside - the length of the radial callout line within the pie.
126 The outline, line option controls the color of the pie segment
127 outlines, if enabled with the C<outline> feature.
135 maxsegment - any segment below this fraction of the total of the
136 segments will be put into the "others" segment. Default: 0.01
140 The top level C<otherlabel> setting controls the label for the
141 "others" segment, default "(others)".
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 );
152 my $pie = Imager::Graph::Pie->new;
154 First a simple graph, normal size, no labels:
156 my $img = $pie->draw(data=>\@data)
161 # error handling omitted for brevity from now on
162 $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
164 just percentages in the segments:
166 $img = $pie->draw(data=>\@data, features=>'labelspconly');
168 add a legend as well:
170 $img = $pie->draw(data=>\@data, labels=>\@labels,
171 features=>[ 'labelspconly', 'legend' ]);
173 and a title, but move the legend down, and add a dropshadow:
175 $img = $pie->draw(data=>\@data, labels=>\@labels,
176 title=>'Netcraft Web Survey',
177 legend=>{ valign=>'bottom' },
178 features=>[ qw/labelspconly legend dropshadow/ ]);
180 something a bit prettier:
182 $img = $pie->draw(data=>\@data, labels=>\@labels,
183 style=>'fount_lin', features=>'legend');
185 suitable for monochrome output:
187 $img = $pie->draw(data=>\@data, labels=>\@labels,
188 style=>'mono', features=>'legend');
192 # this function is too long
194 my ($self, %opts) = @_;
196 $self->_processOptions(\%opts);
198 if (!$self->_validInput()) {
202 my @data = @{$self->_getDataSeries()->[0]->{'data'}};
204 my @labels = @{$self->_getLabels() || []};
207 $self->_style_setup(\%opts);
209 my $style = $self->{_style};
211 my $img = $self->_make_img()
214 my @chart_box = ( 0, 0, $img->getwidth-1, $img->getheight-1 );
215 if ($style->{title}{text}) {
216 $self->_draw_title($img, \@chart_box)
221 for my $item (@data) {
225 # consolidate any segments that are too small to display
226 $self->_consolidate_segments(\@data, \@labels, $total);
228 if ($style->{features}{legend} && (scalar @labels)) {
229 $self->_draw_legend($img, \@labels, \@chart_box)
233 # the following code is fairly ugly
234 # it attempts to work out a good layout for the components of the chart
238 my @ebox = (0, 0, 0, 0);
239 defined(my $callout_outside = $self->_get_number('callout.outside'))
241 defined(my $callout_leadlen = $self->_get_number('callout.leadlen'))
243 defined(my $callout_gap = $self->_get_number('callout.gap'))
245 defined(my $label_vpad = $self->_get_number('label.vpad'))
247 defined(my $label_hpad = $self->_get_number('label.hpad'))
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;
257 if (scalar @labels) {
258 $item->{text} = $labels[$index];
260 if ($style->{features}{labelspconly}) {
262 $style->{label}{pconlyformat}->($data/$total * 100);
265 if ($style->{features}{labelspc}) {
267 $style->{label}{pcformat}->($item->{text}, $data/$total * 100);
270 elsif ($style->{features}{labelspconly}) {
272 $style->{label}{pconlyformat}->($data/$total * 100);
275 elsif ($style->{features}{labels}) {
278 $item->{callout} = 1 if $style->{features}{allcallouts};
279 if (!$item->{callout}) {
280 my @lbox = $self->_text_bbox($item->{text}, 'label')
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;
290 if ($item->{callout}) {
292 my @cbox = $self->_text_bbox($item->{text}, 'callout')
294 $item->{cbox} = \@cbox;
295 $item->{cangle} = ($item->{begin} + $item->{end}) / 2;
296 my $dist = cos($item->{cangle}) * ($guessradius+
298 my $co_size = $callout_leadlen + $callout_gap + $item->{cbox}[2];
300 $dist -= $co_size - $guessradius;
301 $dist < $ebox[0] and $ebox[0] = $dist;
304 $dist += $co_size - $guessradius;
305 $dist > $ebox[2] and $ebox[2] = $dist;
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);
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')
326 my $offx = $self->_get_number('dropshadow.offx')
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},
334 $self->_filter_region($img,
335 $cx+$offx-$radius-10, $cy+$offy-$radius-10,
336 $cx+$offx+$radius+10, $cy+$offy+$radius+10,
338 if $style->{dropshadow}{filter};
341 my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
342 for my $item (@info) {
343 $item->{begin} < $item->{end}
345 my @fill = $self->_data_fill($item->{index}, \@fill_box)
347 $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
348 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
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}
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,
366 ($px, $py) = ($nx, $ny);
371 my $callout_inside = $radius - $self->_get_number('callout.inside');
372 $callout_outside += $radius;
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')
383 my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
384 $label->{begin}, $label->{end});
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});
395 $label->{callout} = 1;
396 my @cbox = $self->_text_bbox($label->{text}, 'callout')
398 $label->{cbox} = \@cbox;
399 $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
402 if ($label->{callout}) {
403 unless (%callout_text) {
404 %callout_text = $self->_text_style('callout')
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];
419 $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
420 'y'=>$ty, text=>$label->{text});
423 $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
424 text=>$label->{text});
435 if (!defined $self->_getDataSeries() || !scalar @{$self->_getDataSeries()}) {
436 return $self->_error("No data supplied");
439 if (!scalar @{$self->_getDataSeries()->[0]->{'data'}}) {
440 return $self->_error("No values in data series");
443 my @data = @{$self->_getDataSeries()->[0]->{'data'}};
448 for my $item (@data) {
450 and return $self->_error("Data index $index is less than zero");
458 and return $self->_error("Sum of all data values is zero");
463 =head1 INTERNAL FUNCTIONS
465 These are used in the implementation of Imager::Graph, and are
466 documented for debuggers and developers.
470 =item _consolidate_segments($data, $labels, $total)
472 Consolidate segments that are too small into an 'others' segment.
476 sub _consolidate_segments {
477 my ($self, $data, $labels, $total) = @_;
481 for my $item (@$data) {
482 if ($item / $total < $self->{_style}{pie}{maxsegment}) {
483 push(@others, $index);
489 for my $index (reverse @others) {
490 $others += $data->[$index];
491 splice(@$labels, $index, 1);
492 splice(@$data, $index, 1);
494 push(@$labels, $self->{_style}{otherlabel}) if @$labels;
495 push(@$data, $others);
501 my ($x, $y, @l) = @_;
503 my $res = $l[0]*$x + $l[1] * $y + $l[2];
504 print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
507 =item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
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.
512 Returns a list defining the bounding box of the text if it does fit.
517 my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
519 #print "fit: $cx, $cy '$text' $radius $begin $end\n";
520 my @tbox = $self->_text_bbox($text, $name)
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];
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}});
555 my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx)
556 + ($y - $cy) * ($y - $cy);
557 if ($dist2 > $radius * $radius) {
559 intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
561 my @p = splice(@points, 0, 2);
562 if ($p[0] < $cx && $tcx+$pos < $p[0]) {
565 elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
572 push(@lines, \%entry);
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];
578 return ($tcx+$left, $topy, $tcx+$right, $boty);
582 ( 'pie', $_[0]->SUPER::_composite() );
588 my %work = %{$self->SUPER::_style_defs()};
589 $work{otherlabel} = "(others)";
607 Tony Cook <tony@develop-help.com>
611 Imager::Graph(3), Imager(3), perl(1)