- zero-sized segments were drawn as covering the whole pie. Skip
[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
13 my $img = $chart->draw(labels=>['first segment', 'second segment'],
14 data=>[ $first_amount, $second_amount ],
15 size=>[$width, $height])
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
42You must at least supply a C<data> parameter and should probably supply a C<labels> parameter.
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
90=head1 EXAMPLES
91
92Assuming:
93
94 # from the Netcraft September 2001 web survey
95 # http://www.netcraft.com/survey/
96 my @data = qw(17874757 8146372 1321544 811406 );
97 my @labels = qw(Apache Microsoft iPlanet Zeus );
98
99 my $pie = Imager::Graph::Pie->new;
100
101First a simple graph, normal size, no labels:
102
103 my $img = $pie->draw(data=>\@data)
104 or die $pie->error;
105
106label the segments:
107
108 # error handling omitted for brevity from now on
109 $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
110
111just percentages in the segments:
112
113 $img = $pie->draw(data=>\@data, features=>'labelspconly');
114
115add a legend as well:
116
117 $img = $pie->draw(data=>\@data, labels=>\@labels,
118 features=>[ 'labelspconly', 'legend' ]);
119
120and a title, but move the legend down, and add a dropshadow:
121
122 $img = $pie->draw(data=>\@data, labels=>\@labels,
123 title=>'Netcraft Web Survey',
124 legend=>{ valign=>'bottom' },
125 features=>[ qw/labelspconly legend dropshadow/ ]);
126
127something a bit prettier:
128
129 # requires Imager > 0.38
130 $img = $pie->draw(data=>\@data, labels=>\@labels,
131 style=>'fount_lin', features=>'legend');
132
133suitable for monochrome output:
134
135 # requires Imager > 0.38
136 $img = $pie->draw(data=>\@data, labels=>\@labels,
137 style=>'mono', features=>'legend');
138
139=cut
140
141# this function is too long
142sub draw {
143 my ($self, %opts) = @_;
144
145 $opts{data}
146 or return $self->_error("No data parameter supplied");
147 my @data = @{$opts{data}};
148 my @labels;
149 @labels = @{$opts{labels}} if $opts{labels};
150
151 $self->_style_setup(\%opts);
152
153 my $style = $self->{_style};
154
155 my $img = $self->_make_img()
156 or return;
157
158 my $total = 0;
159 for my $item (@data) {
160 $total += $item;
161 }
162
163 my @chart_box = ( 0, 0, $img->getwidth-1, $img->getheight-1 );
164 if ($style->{title}{text}) {
165 $self->_draw_title($img, \@chart_box)
166 or return;
167 }
168
169 # consolidate any segments that are too small to display
170 $self->_consolidate_segments(\@data, \@labels, $total);
171
172 if ($style->{features}{legend} && $opts{labels}) {
173 $self->_draw_legend($img, \@labels, \@chart_box)
174 or return;
175 }
176
177 # the following code is fairly ugly
178 # it attempts to work out a good layout for the components of the chart
179 my @info;
180 my $index = 0;
181 my $pos = 0;
182 my @ebox = (0, 0, 0, 0);
183 defined(my $callout_outside = $self->_get_number('callout.outside'))
184 or return;
185 defined(my $callout_leadlen = $self->_get_number('callout.leadlen'))
186 or return;
187 defined(my $callout_gap = $self->_get_number('callout.gap'))
188 or return;
189 defined(my $label_vpad = $self->_get_number('label.vpad'))
190 or return;
191 defined(my $label_hpad = $self->_get_number('label.hpad'))
192 or return;
193 my $guessradius =
194 int($self->_small_extent(\@chart_box) * $style->{pie}{guessfactor} * 0.5);
195 for my $data (@data) {
196 my $item = { data=>$data, index=>$index };
197 my $size = 2 * PI * $data / $total;
198 $item->{begin} = $pos;
199 $pos += $size;
200 $item->{end} = $pos;
201 if ($opts{labels}) {
202 $item->{text} = $labels[$index];
203 }
204 if ($style->{features}{labelspconly}) {
205 $item->{text} =
206 $style->{label}{pconlyformat}->($data/$total * 100);
207 }
208 if ($item->{text}) {
209 if ($style->{features}{labelspc}) {
210 $item->{text} =
211 $style->{label}{pcformat}->($item->{text}, $data/$total * 100);
212 $item->{label} = 1;
213 }
214 elsif ($style->{features}{labelspconly}) {
215 $item->{text} =
216 $style->{label}{pconlyformat}->($data/$total * 100);
217 $item->{label} = 1;
218 }
219 elsif ($style->{features}{labels}) {
220 $item->{label} = 1;
221 }
222 $item->{lbox} = [ $self->_text_bbox($item->{text}, 'label') ];
223 if ($item->{label}) {
224 unless ($self->_fit_text(0, 0, 'label', $item->{text}, $guessradius,
225 $item->{begin}, $item->{end})) {
226 $item->{callout} = 1;
227 }
228 }
229 $item->{callout} = 1 if $style->{features}{allcallouts};
230 if ($item->{callout}) {
231 $item->{label} = 0;
232 $item->{cbox} = [ $self->_text_bbox($item->{text}, 'callout') ];
233 $item->{cangle} = ($item->{begin} + $item->{end}) / 2;
234 my $dist = cos($item->{cangle}) * ($guessradius+
235 $callout_outside);
236 my $co_size = $callout_leadlen + $callout_gap + $item->{cbox}[2];
237 if ($dist < 0) {
238 $dist -= $co_size - $guessradius;
239 $dist < $ebox[0] and $ebox[0] = $dist;
240 }
241 else {
242 $dist += $co_size - $guessradius;
243 $dist > $ebox[2] and $ebox[2] = $dist;
244 }
245 }
246 }
247 push(@info, $item);
248 ++$index;
249 }
250
251 my $radius =
252 int($self->_small_extent(\@chart_box) * $style->{pie}{size} * 0.5);
253 my $max_width = $chart_box[2] - $chart_box[0] + $ebox[0] - $ebox[2];
254 if ($radius > $max_width / 2) {
255 $radius = $max_width / 2;
256 }
257 $chart_box[0] -= $ebox[0];
258 $chart_box[2] -= $ebox[2];
259 my $cx = int(($chart_box[0] + $chart_box[2]) / 2);
260 my $cy = int(($chart_box[1] + $chart_box[3]) / 2);
261 if ($style->{features}{dropshadow}) {
262 my @shadow_fill = $self->_get_fill('dropshadow.fill')
263 or return;
264 my $offx = $self->_get_number('dropshadow.offx')
265 or return;
266 my $offy = $self->_get_number('dropshadow.offy');
267 for my $item (@info) {
bfcf9414 268 $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
35574351
TC
269 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
270 @shadow_fill);
271 }
272 $self->_filter_region($img,
273 $cx+$offx-$radius-10, $cy+$offy-$radius-10,
274 $cx+$offx+$radius+10, $cy+$offy+$radius+10,
275 'dropshadow.filter')
276 if $style->{dropshadow}{filter};
277 }
bfcf9414 278
35574351
TC
279 my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
280 for my $item (@info) {
26c93f46
TC
281 $item->{begin} < $item->{end}
282 or next;
35574351
TC
283 my @fill = $self->_data_fill($item->{index}, \@fill_box)
284 or return;
bfcf9414 285 $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
35574351
TC
286 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
287 @fill);
288 }
35574351
TC
289 if ($style->{features}{outline}) {
290 my $outcolor = $self->_get_color('outline.line');
291 for my $item (@info) {
bfcf9414
TC
292 my $px = int($cx + $radius * cos($item->{begin}));
293 my $py = int($cy + $radius * sin($item->{begin}));
26c93f46
TC
294 $item->{begin} < $item->{end}
295 or next;
35574351
TC
296 $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, color=>$outcolor);
297 for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
298 my $stroke_end = $i + PI/180;
299 $stroke_end = $item->{end} if $stroke_end > $item->{end};
bfcf9414
TC
300 my $nx = int($cx + $radius * cos($stroke_end));
301 my $ny = int($cy + $radius * sin($stroke_end));
35574351
TC
302 $img->line(x1=>$px, y1=>$py, x2=>$nx, y2=>$ny, color=>$outcolor,
303 antialias=>1);
304 ($px, $py) = ($nx, $ny);
305 }
306 }
307 }
308
309 my $callout_inside = $radius - $self->_get_number('callout.inside');
310 $callout_outside += $radius;
311 my %callout_text = $self->_text_style('callout');
312 my %label_text = $self->_text_style('label');
313 for my $label (@info) {
314 if ($label->{label}) {
315 my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
316 $label->{begin}, $label->{end});
317 if (@loc) {
318 my $tcx = ($loc[0]+$loc[2])/2;
319 my $tcy = ($loc[1]+$loc[3])/2;
320 #$img->box(xmin=>$loc[0], ymin=>$loc[1], xmax=>$loc[2], ymax=>$loc[3],
321 # color=>Imager::Color->new(0,0,0));
322 $img->string(%label_text, x=>$tcx-$label->{lbox}[2]/2,
323 'y'=>$tcy+$label->{lbox}[3]/2+$label->{lbox}[1],
324 text=>$label->{text});
325 }
326 else {
327 $label->{callout} = 1;
328 $label->{cbox} = [ $self->_text_bbox($label->{text}, 'callout') ];
329 $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
330 }
331 }
332 if ($label->{callout}) {
333 my $ix = floor(0.5 + $cx + $callout_inside * cos($label->{cangle}));
334 my $iy = floor(0.5 + $cy + $callout_inside * sin($label->{cangle}));
335 my $ox = floor(0.5 + $cx + $callout_outside * cos($label->{cangle}));
336 my $oy = floor(0.5 + $cy + $callout_outside * sin($label->{cangle}));
337 my $lx = ($ox < $cx) ? $ox - $callout_leadlen : $ox + $callout_leadlen;
338 $img->line(x1=>$ix, y1=>$iy, x2=>$ox, y2=>$oy, antialias=>1,
339 color=>$self->_get_color('callout.color'));
340 $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
341 color=>$self->_get_color('callout.color'));
342 #my $tx = $lx + $callout_gap;
343 my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
344 if ($lx < $cx) {
345 $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
346 'y'=>$ty, text=>$label->{text});
347 }
348 else {
349 $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
350 text=>$label->{text});
351 }
352 }
353 }
354
355 $img;
356}
357
358=head1 INTERNAL FUNCTIONS
359
360These are used in the implementation of Imager::Graph, and are
361documented for debuggers and developers.
362
363=over
364
365=item _consolidate_segments($data, $labels, $total)
366
367Consolidate segments that are too small into an 'others' segment.
368
369=cut
370
371sub _consolidate_segments {
372 my ($self, $data, $labels, $total) = @_;
373
374 my @others;
375 my $index;
376 for my $item (@$data) {
377 if ($item / $total < $self->{_style}{pie}{maxsegment}) {
378 push(@others, $index);
379 }
380 ++$index;
381 }
382 if (@others) {
383 my $others = 0;
384 for my $index (reverse @others) {
385 $others += $data->[$index];
386 splice(@$labels, $index, 1);
387 splice(@$data, $index, 1);
388 }
389 push(@$labels, $self->{_style}{otherlabel}) if @$labels;
390 push(@$data, $others);
391 }
392}
393
35574351
TC
394# used for debugging
395sub _test_line {
396 my ($x, $y, @l) = @_;
397
398 my $res = $l[0]*$x + $l[1] * $y + $l[2];
399 print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
400}
401
402=item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
403
404Attempts to fit text into a pie segment with its center at ($cx, $cy)
405with the given radius, covering the angles $begin through $end.
406
407Returns a list defining the bounding box of the text if it does fit.
408
409=cut
410
411sub _fit_text {
412 my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
413
414 #print "fit: $cx, $cy '$text' $radius $begin $end\n";
415 my @tbox = $self->_text_bbox($text, $name);
416 my $tcx = floor(0.5+$cx + cos(($begin+$end)/2) * $radius *3/5);
417 my $tcy = floor(0.5+$cy + sin(($begin+$end)/2) * $radius *3/5);
418 my $topy = $tcy - $tbox[3]/2;
419 my $boty = $topy + $tbox[3];
420 my @lines;
421 for my $y ($topy, $boty) {
422 my %entry = ( 'y'=>$y );
423 $entry{line} = [ line_from_points($tcx, $y, $tcx+1, $y) ];
424 $entry{left} = -$radius;
425 $entry{right} = $radius;
426 for my $angle ($begin, $end) {
427 my $ex = $cx + cos($angle)*$radius;
428 my $ey = $cy + sin($angle)*$radius;
429 my @line = line_from_points($cx, $cy, $ex, $ey);
430 #_test_line($cx, $cy, @line);
431 #_test_line($ex, $ey, @line);
432 my $goodsign = $line[0] * $tcx + $line[1] * $tcy + $line[2];
433 for my $pos (@entry{qw/left right/}) {
434 my $sign = $line[0] * ($pos+$tcx) + $line[1] * $y + $line[2];
435 if ($goodsign * $sign < 0) {
436 if (my @p = intersect_lines(@line, @{$entry{line}})) {
437 # die "$goodsign $sign ($pos, $tcx) no intersect (@line) (@{$entry{line}})" ; # this would be wierd
438 #_test_line(@p, @line);
439 #_test_line(@p, @{$entry{line}});
440 $pos = $p[0]-$tcx;
441 }
442 else {
443 return;
444 }
445
446 }
447
448 # circle
449 my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx)
450 + ($y - $cy) * ($y - $cy);
451 if ($dist2 > $radius * $radius) {
452 my @points =
453 intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
454 while (@points) {
455 my @p = splice(@points, 0, 2);
456 if ($p[0] < $cx && $tcx+$pos < $p[0]) {
457 $pos = $p[0]-$tcx;
458 }
459 elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
460 $pos = $p[0]-$tcx;
461 }
462 }
463 }
464 }
465 }
466 push(@lines, \%entry);
467 }
468 my $left = $lines[0]{left} > $lines[1]{left} ? $lines[0]{left} : $lines[1]{left};
469 my $right = $lines[0]{right} < $lines[1]{right} ? $lines[0]{right} : $lines[1]{right};
470 return if $right - $left < $tbox[2];
471
472 return ($tcx+$left, $topy, $tcx+$right, $boty);
473}
474
475sub _composite {
476 ( 'pie', $_[0]->SUPER::_composite() );
477}
478
479sub _style_defs {
480 my ($self) = @_;
481
482 my %work = %{$self->SUPER::_style_defs()};
483 $work{otherlabel} = "(others)";
484 $work{features}{pieblur} = 1;
485 $work{pie} =
486 {
487 blur => {
488 type=>'conv',
489 coef=>[0.05, 0.1, 0.3, 1, 0.3, 0.1, 0.05]
490 },
491 guessfactor=>0.6,
492 size=>0.8,
493 maxsegment=> 0.05,
494 };
495
496 \%work;
497}
498
4991;
500__END__
501
54ada35d
TC
502=back
503
35574351
TC
504=head1 AUTHOR
505
506Tony Cook <tony@develop-help.com>
507
508=head1 SEE ALSO
509
510Imager::Graph(3), Imager(3), perl(1)
511
512=cut