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 # requires Imager > 0.38
183 $img = $pie->draw(data=>\@data, labels=>\@labels,
184 style=>'fount_lin', features=>'legend');
186 suitable for monochrome output:
188 # requires Imager > 0.38
189 $img = $pie->draw(data=>\@data, labels=>\@labels,
190 style=>'mono', features=>'legend');
194 # this function is too long
196 my ($self, %opts) = @_;
199 or return $self->_error("No data parameter supplied");
200 my @data = @{$opts{data}};
202 @labels = @{$opts{labels}} if $opts{labels};
204 $self->_style_setup(\%opts);
206 my $style = $self->{_style};
208 my $img = $self->_make_img()
212 for my $item (@data) {
216 my @chart_box = ( 0, 0, $img->getwidth-1, $img->getheight-1 );
217 if ($style->{title}{text}) {
218 $self->_draw_title($img, \@chart_box)
222 # consolidate any segments that are too small to display
223 $self->_consolidate_segments(\@data, \@labels, $total);
225 if ($style->{features}{legend} && $opts{labels}) {
226 $self->_draw_legend($img, \@labels, \@chart_box)
230 # the following code is fairly ugly
231 # it attempts to work out a good layout for the components of the chart
235 my @ebox = (0, 0, 0, 0);
236 defined(my $callout_outside = $self->_get_number('callout.outside'))
238 defined(my $callout_leadlen = $self->_get_number('callout.leadlen'))
240 defined(my $callout_gap = $self->_get_number('callout.gap'))
242 defined(my $label_vpad = $self->_get_number('label.vpad'))
244 defined(my $label_hpad = $self->_get_number('label.hpad'))
247 int($self->_small_extent(\@chart_box) * $style->{pie}{guessfactor} * 0.5);
248 for my $data (@data) {
249 my $item = { data=>$data, index=>$index };
250 my $size = 2 * PI * $data / $total;
251 $item->{begin} = $pos;
255 $item->{text} = $labels[$index];
257 if ($style->{features}{labelspconly}) {
259 $style->{label}{pconlyformat}->($data/$total * 100);
262 if ($style->{features}{labelspc}) {
264 $style->{label}{pcformat}->($item->{text}, $data/$total * 100);
267 elsif ($style->{features}{labelspconly}) {
269 $style->{label}{pconlyformat}->($data/$total * 100);
272 elsif ($style->{features}{labels}) {
275 $item->{lbox} = [ $self->_text_bbox($item->{text}, 'label') ];
276 if ($item->{label}) {
277 unless ($self->_fit_text(0, 0, 'label', $item->{text}, $guessradius,
278 $item->{begin}, $item->{end})) {
279 $item->{callout} = 1;
282 $item->{callout} = 1 if $style->{features}{allcallouts};
283 if ($item->{callout}) {
285 $item->{cbox} = [ $self->_text_bbox($item->{text}, 'callout') ];
286 $item->{cangle} = ($item->{begin} + $item->{end}) / 2;
287 my $dist = cos($item->{cangle}) * ($guessradius+
289 my $co_size = $callout_leadlen + $callout_gap + $item->{cbox}[2];
291 $dist -= $co_size - $guessradius;
292 $dist < $ebox[0] and $ebox[0] = $dist;
295 $dist += $co_size - $guessradius;
296 $dist > $ebox[2] and $ebox[2] = $dist;
305 int($self->_small_extent(\@chart_box) * $style->{pie}{size} * 0.5);
306 my $max_width = $chart_box[2] - $chart_box[0] + $ebox[0] - $ebox[2];
307 if ($radius > $max_width / 2) {
308 $radius = int($max_width / 2);
310 $chart_box[0] -= $ebox[0];
311 $chart_box[2] -= $ebox[2];
312 my $cx = int(($chart_box[0] + $chart_box[2]) / 2);
313 my $cy = int(($chart_box[1] + $chart_box[3]) / 2);
314 if ($style->{features}{dropshadow}) {
315 my @shadow_fill = $self->_get_fill('dropshadow.fill')
317 my $offx = $self->_get_number('dropshadow.offx')
319 my $offy = $self->_get_number('dropshadow.offy');
320 for my $item (@info) {
321 $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
322 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
325 $self->_filter_region($img,
326 $cx+$offx-$radius-10, $cy+$offy-$radius-10,
327 $cx+$offx+$radius+10, $cy+$offy+$radius+10,
329 if $style->{dropshadow}{filter};
332 my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
333 for my $item (@info) {
334 $item->{begin} < $item->{end}
336 my @fill = $self->_data_fill($item->{index}, \@fill_box)
338 $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
339 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
342 if ($style->{features}{outline}) {
343 my $outcolor = $self->_get_color('outline.line');
344 for my $item (@info) {
345 my $px = int($cx + $radius * cos($item->{begin}));
346 my $py = int($cy + $radius * sin($item->{begin}));
347 $item->{begin} < $item->{end}
349 $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, color=>$outcolor);
350 for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
351 my $stroke_end = $i + PI/180;
352 $stroke_end = $item->{end} if $stroke_end > $item->{end};
353 my $nx = int($cx + $radius * cos($stroke_end));
354 my $ny = int($cy + $radius * sin($stroke_end));
355 $img->line(x1=>$px, y1=>$py, x2=>$nx, y2=>$ny, color=>$outcolor,
357 ($px, $py) = ($nx, $ny);
362 my $callout_inside = $radius - $self->_get_number('callout.inside');
363 $callout_outside += $radius;
364 my %callout_text = $self->_text_style('callout');
365 my %label_text = $self->_text_style('label');
366 for my $label (@info) {
367 if ($label->{label}) {
368 my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
369 $label->{begin}, $label->{end});
371 my $tcx = ($loc[0]+$loc[2])/2;
372 my $tcy = ($loc[1]+$loc[3])/2;
373 #$img->box(xmin=>$loc[0], ymin=>$loc[1], xmax=>$loc[2], ymax=>$loc[3],
374 # color=>Imager::Color->new(0,0,0));
375 $img->string(%label_text, x=>$tcx-$label->{lbox}[2]/2,
376 'y'=>$tcy+$label->{lbox}[3]/2+$label->{lbox}[1],
377 text=>$label->{text});
380 $label->{callout} = 1;
381 $label->{cbox} = [ $self->_text_bbox($label->{text}, 'callout') ];
382 $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
385 if ($label->{callout}) {
386 my $ix = floor(0.5 + $cx + $callout_inside * cos($label->{cangle}));
387 my $iy = floor(0.5 + $cy + $callout_inside * sin($label->{cangle}));
388 my $ox = floor(0.5 + $cx + $callout_outside * cos($label->{cangle}));
389 my $oy = floor(0.5 + $cy + $callout_outside * sin($label->{cangle}));
390 my $lx = ($ox < $cx) ? $ox - $callout_leadlen : $ox + $callout_leadlen;
391 $img->line(x1=>$ix, y1=>$iy, x2=>$ox, y2=>$oy, antialias=>1,
392 color=>$self->_get_color('callout.color'));
393 $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
394 color=>$self->_get_color('callout.color'));
395 #my $tx = $lx + $callout_gap;
396 my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
398 $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
399 'y'=>$ty, text=>$label->{text});
402 $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
403 text=>$label->{text});
411 =head1 INTERNAL FUNCTIONS
413 These are used in the implementation of Imager::Graph, and are
414 documented for debuggers and developers.
418 =item _consolidate_segments($data, $labels, $total)
420 Consolidate segments that are too small into an 'others' segment.
424 sub _consolidate_segments {
425 my ($self, $data, $labels, $total) = @_;
429 for my $item (@$data) {
430 if ($item / $total < $self->{_style}{pie}{maxsegment}) {
431 push(@others, $index);
437 for my $index (reverse @others) {
438 $others += $data->[$index];
439 splice(@$labels, $index, 1);
440 splice(@$data, $index, 1);
442 push(@$labels, $self->{_style}{otherlabel}) if @$labels;
443 push(@$data, $others);
449 my ($x, $y, @l) = @_;
451 my $res = $l[0]*$x + $l[1] * $y + $l[2];
452 print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
455 =item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
457 Attempts to fit text into a pie segment with its center at ($cx, $cy)
458 with the given radius, covering the angles $begin through $end.
460 Returns a list defining the bounding box of the text if it does fit.
465 my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
467 #print "fit: $cx, $cy '$text' $radius $begin $end\n";
468 my @tbox = $self->_text_bbox($text, $name);
469 my $tcx = floor(0.5+$cx + cos(($begin+$end)/2) * $radius *3/5);
470 my $tcy = floor(0.5+$cy + sin(($begin+$end)/2) * $radius *3/5);
471 my $topy = $tcy - $tbox[3]/2;
472 my $boty = $topy + $tbox[3];
474 for my $y ($topy, $boty) {
475 my %entry = ( 'y'=>$y );
476 $entry{line} = [ line_from_points($tcx, $y, $tcx+1, $y) ];
477 $entry{left} = -$radius;
478 $entry{right} = $radius;
479 for my $angle ($begin, $end) {
480 my $ex = $cx + cos($angle)*$radius;
481 my $ey = $cy + sin($angle)*$radius;
482 my @line = line_from_points($cx, $cy, $ex, $ey);
483 #_test_line($cx, $cy, @line);
484 #_test_line($ex, $ey, @line);
485 my $goodsign = $line[0] * $tcx + $line[1] * $tcy + $line[2];
486 for my $pos (@entry{qw/left right/}) {
487 my $sign = $line[0] * ($pos+$tcx) + $line[1] * $y + $line[2];
488 if ($goodsign * $sign < 0) {
489 if (my @p = intersect_lines(@line, @{$entry{line}})) {
490 # die "$goodsign $sign ($pos, $tcx) no intersect (@line) (@{$entry{line}})" ; # this would be wierd
491 #_test_line(@p, @line);
492 #_test_line(@p, @{$entry{line}});
502 my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx)
503 + ($y - $cy) * ($y - $cy);
504 if ($dist2 > $radius * $radius) {
506 intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
508 my @p = splice(@points, 0, 2);
509 if ($p[0] < $cx && $tcx+$pos < $p[0]) {
512 elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
519 push(@lines, \%entry);
521 my $left = $lines[0]{left} > $lines[1]{left} ? $lines[0]{left} : $lines[1]{left};
522 my $right = $lines[0]{right} < $lines[1]{right} ? $lines[0]{right} : $lines[1]{right};
523 return if $right - $left < $tbox[2];
525 return ($tcx+$left, $topy, $tcx+$right, $boty);
529 ( 'pie', $_[0]->SUPER::_composite() );
535 my %work = %{$self->SUPER::_style_defs()};
536 $work{otherlabel} = "(others)";
554 Tony Cook <tony@develop-help.com>
558 Imager::Graph(3), Imager(3), perl(1)