lib/Imager/Graph/Pie.pm

   1 package 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(
  14                          data => [ $first_amount, $second_amount ],
  15                          size => 350);
  16
  17 =head1 DESCRIPTION
  18
  19 Imager::Graph::Pie is intender to make it simple to use L<Imager> to
  20 create good looking pie graphs.
  21
  22 Most of the basic layout and color selection is handed off to
  23 L<Imager::Graph>.
  24
  25 =over
  26
  27 =cut
  28
  29 use strict;
  30 use vars qw(@ISA);
  31 use Imager::Graph;
  32 @ISA = qw(Imager::Graph);
  33 use Imager::Graph::Util;
  34 use POSIX qw(floor);
  35
  36 use constant PI => 3.1415926535;
  37
  38 =item $graph->draw(...)
  39
  40 Draws a pie graph onto a new image and returns the image.
  41
  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.
  43
  44 The C<data> parameter should be a reference to an array containing the
  45 data the pie graph should present.
  46
  47 The C<labels> parameter is a reference to an array of labels,
  48 corresponding to the values in C<data>.
  49
  50 =back
  51
  52 =head1 FEATURES
  53
  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:
  56
  57 =over
  58
  59 =item show_callouts_onAll_segments()
  60
  61 all labels are presented as callouts
  62
  63 =cut
  64
  65 sub show_callouts_onAll_segments {
  66     $_[0]->{'custom_style'}->{'features'}->{'allcallouts'} = 1;
  67 }
  68
  69 =item show_only_label_percentages()
  70
  71 only show the percentage, not the labels.
  72
  73 =cut
  74
  75 sub show_only_label_percentages {
  76     $_[0]->{'custom_style'}->{'features'}->{'labelspconly'} = 1;
  77 }
  78
  79 =item show_label_percentages()
  80
  81 adds the percentage of the pie to each label.
  82
  83 =cut
  84
  85 sub show_label_percentages {
  86     $_[0]->{'custom_style'}->{'features'}->{'labelspc'} = 1;
  87 }
  88
  89 =back
  90
  91 Additionally, arguments can be added to draw() :
  92
  93 =over
  94
  95 =item legend
  96
  97 adds a legend to your graph.  Requires the labels parameter
  98
  99 =item labels
 100
 101 labels each segment of the graph.  If the label doesn't fit inside the
 102 segment it is presented as a callout.
 103
 104 =item labelspc
 105
 106 adds the percentage of the pie to each label.
 107
 108 =item labelspconly
 109
 110 the segments are labels with their percentages only.
 111
 112 =item allcallouts
 113
 114 all labels are presented as callouts
 115
 116 =item outline
 117
 118 the pie segments are outlined.
 119
 120 =item dropshadow
 121
 122 the pie is given a drop shadow.
 123
 124 =back
 125
 126 =head1 PIE CHART STYLES
 127
 128 The following style values are specific to pie charts:
 129
 130 Controlling callouts, the C<callout> option:
 131
 132 =over
 133
 134 =item *
 135
 136 color - the color of the callout line and the callout text.
 137
 138 =item *
 139
 140 font, size - font and size of the callout text
 141
 142 =item *
 143
 144 outside - the distance the radial callout line goes outside the pie
 145
 146 =item *
 147
 148 leadlen - the length of the horizontal callout line from the end of
 149 the radial line.
 150
 151 =item *
 152
 153 gap - the distance between the end of the horizontal callout line and
 154 the label.
 155
 156 =item *
 157
 158 inside - the length of the radial callout line within the pie.
 159
 160 =back
 161
 162 The outline, line option controls the color of the pie segment
 163 outlines, if enabled with the C<outline> feature.
 164
 165 Under C<pie>:
 166
 167 =over
 168
 169 =item *
 170
 171 maxsegment - any segment below this fraction of the total of the
 172 segments will be put into the "others" segment.  Default: 0.01
 173
 174 =back
 175
 176 The top level C<otherlabel> setting controls the label for the
 177 "others" segment, default "(others)".
 178
 179 =head1 EXAMPLES
 180
 181 Assuming:
 182
 183   # from the Netcraft September 2001 web survey
 184   # http://www.netcraft.com/survey/
 185   my @data   = qw(17874757  8146372   1321544  811406 );
 186   my @labels = qw(Apache    Microsoft i_planet  Zeus   );
 187
 188   my $pie = Imager::Graph::Pie->new;
 189
 190 First a simple graph, normal size, no labels:
 191
 192   my $img = $pie->draw(data=>\@data)
 193     or die $pie->error;
 194
 195 label the segments:
 196
 197   # error handling omitted for brevity from now on
 198   $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
 199
 200 just percentages in the segments:
 201
 202   $img = $pie->draw(data=>\@data, features=>'labelspconly');
 203
 204 add a legend as well:
 205
 206   $img = $pie->draw(data=>\@data, labels=>\@labels,
 207                     features=>[ 'labelspconly', 'legend' ]);
 208
 209 and 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
 216 something a bit prettier:
 217
 218   $img = $pie->draw(data=>\@data, labels=>\@labels,
 219                     style=>'fount_lin', features=>'legend');
 220
 221 suitable for monochrome output:
 222
 223   $img = $pie->draw(data=>\@data, labels=>\@labels,
 224                     style=>'mono', features=>'legend');
 225
 226 =cut
 227
 228 # this function is too long
 229 sub draw {
 230   my ($self, %opts) = @_;
 231
 232   my $data_series = $self->_get_data_series(\%opts);
 233
 234   $self->_valid_input($data_series)
 235     or return;
 236
 237   my @data = @{$data_series->[0]->{'data'}};
 238
 239   my @labels = @{$self->_get_labels(\%opts) || []};
 240
 241   $self->_style_setup(\%opts);
 242
 243   my $style = $self->{_style};
 244
 245   my $img = $self->_make_img()
 246     or return;
 247
 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
 254   my $total = 0;
 255   for my $item (@data) {
 256     $total += $item;
 257   }
 258
 259   # consolidate any segments that are too small to display
 260   $self->_consolidate_segments(\@data, \@labels, $total);
 261
 262   if ($style->{features}{legend} && (scalar @labels)) {
 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;
 291     if (scalar @labels) {
 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       }
 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           }
 322         }
 323       }
 324       if ($item->{callout}) {
 325         $item->{label} = 0;
 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+
 331                                            $callout_outside);
 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         }
 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) {
 351     $radius = int($max_width / 2);
 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) {
 364       $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1, aa => 1,
 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   }
 374
 375   my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
 376   for my $item (@info) {
 377     $item->{begin} < $item->{end}
 378       or next;
 379     my @fill = $self->_data_fill($item->{index}, \@fill_box)
 380       or return;
 381     $img->arc(x=>$cx, 'y'=>$cy, r=>$radius, aa => 1,
 382               d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
 383               @fill);
 384   }
 385   if ($style->{features}{outline}) {
 386     my $outcolor = $self->_get_color('outline.line');
 387     for my $item (@info) {
 388       my $px = int($cx + $radius * cos($item->{begin}));
 389       my $py = int($cy + $radius * sin($item->{begin}));
 390       $item->{begin} < $item->{end}
 391         or next;
 392       $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, color=>$outcolor);
 393       for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
 394         my $stroke_end = $i + PI/180;
 395         $stroke_end = $item->{end} if $stroke_end > $item->{end};
 396         my $nx = int($cx + $radius * cos($stroke_end));
 397         my $ny = int($cy + $radius * sin($stroke_end));
 398         $img->line(x1=>$px, y1=>$py, x2=>$nx, y2=>$ny, color=>$outcolor,
 399                   antialias=>1);
 400         ($px, $py) = ($nx, $ny);
 401       }
 402     }
 403   }
 404
 405   my $callout_inside = $radius - $self->_get_number('callout.inside');
 406   $callout_outside += $radius;
 407   my %callout_text;
 408   my %label_text;
 409   for my $label (@info) {
 410     if ($label->{label} && !$label->{callout}) {
 411       # at this point we know we need the label font, to calculate
 412       # whether the label will fit if anything else
 413       unless (%label_text) {
 414         %label_text = $self->_text_style('label')
 415           or return;
 416       }
 417       my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
 418                                  $label->{begin}, $label->{end});
 419       if (@loc) {
 420         my $tcx = ($loc[0]+$loc[2])/2;
 421         my $tcy = ($loc[1]+$loc[3])/2;
 422         #$img->box(xmin=>$loc[0], ymin=>$loc[1], xmax=>$loc[2], ymax=>$loc[3],
 423         #          color=>Imager::Color->new(0,0,0));
 424         $img->string(%label_text, x=>$tcx-$label->{lbox}[2]/2,
 425                      'y'=>$tcy+$label->{lbox}[3]/2+$label->{lbox}[1],
 426                      text=>$label->{text}, aa => 1);
 427       }
 428       else {
 429         $label->{callout} = 1;
 430         my @cbox = $self->_text_bbox($label->{text}, 'callout')
 431           or return;
 432         $label->{cbox} = \@cbox;
 433         $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
 434       }
 435     }
 436     if ($label->{callout}) {
 437       unless (%callout_text) {
 438         %callout_text = $self->_text_style('callout')
 439           or return;
 440       }
 441       my $ix = floor(0.5 + $cx + $callout_inside * cos($label->{cangle}));
 442       my $iy = floor(0.5 + $cy + $callout_inside * sin($label->{cangle}));
 443       my $ox = floor(0.5 + $cx + $callout_outside * cos($label->{cangle}));
 444       my $oy = floor(0.5 + $cy + $callout_outside * sin($label->{cangle}));
 445       my $lx = ($ox < $cx) ? $ox - $callout_leadlen : $ox + $callout_leadlen;
 446       $img->line(x1=>$ix, y1=>$iy, x2=>$ox, y2=>$oy, antialias=>1,
 447                  color=>$self->_get_color('callout.color'));
 448       $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
 449                  color=>$self->_get_color('callout.color'));
 450       #my $tx = $lx + $callout_gap;
 451       my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
 452       if ($lx < $cx) {
 453         $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
 454                      'y'=>$ty, text=>$label->{text}, aa=>1);
 455       }
 456       else {
 457         $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
 458                      text=>$label->{text}, aa=>1);
 459       }
 460     }
 461   }
 462
 463   $img;
 464 }
 465
 466 sub _valid_input {
 467   my ($self, $data_series) = @_;
 468
 469   if (!defined $data_series || !scalar @$data_series) {
 470     return $self->_error("No data supplied");
 471   }
 472
 473   @$data_series == 1
 474     or return $self->_error("Pie charts only allow one data series");
 475
 476   my $data = $data_series->[0]{data};
 477
 478   if (!scalar @$data) {
 479     return $self->_error("No values in data series");
 480   }
 481
 482   my $total = 0;
 483   {
 484     my $index = 0;
 485     for my $item (@$data) {
 486       $item < 0
 487         and return $self->_error("Data index $index is less than zero");
 488
 489       $total += $item;
 490
 491       ++$index;
 492     }
 493   }
 494   $total == 0
 495     and return $self->_error("Sum of all data values is zero");
 496
 497   return 1;
 498 }
 499
 500 =head1 INTERNAL FUNCTIONS
 501
 502 These are used in the implementation of Imager::Graph, and are
 503 documented for debuggers and developers.
 504
 505 =over
 506
 507 =item _consolidate_segments($data, $labels, $total)
 508
 509 Consolidate segments that are too small into an 'others' segment.
 510
 511 =cut
 512
 513 sub _consolidate_segments {
 514   my ($self, $data, $labels, $total) = @_;
 515
 516   my @others;
 517   my $index = 0;
 518   for my $item (@$data) {
 519     if ($item / $total < $self->{_style}{pie}{maxsegment}) {
 520       push(@others, $index);
 521     }
 522     ++$index;
 523   }
 524   if (@others) {
 525     my $others = 0;
 526     for my $index (reverse @others) {
 527       $others += $data->[$index];
 528       splice(@$labels, $index, 1);
 529       splice(@$data, $index, 1);
 530     }
 531     push(@$labels, $self->{_style}{otherlabel}) if @$labels;
 532     push(@$data, $others);
 533   }
 534 }
 535
 536 # used for debugging
 537 sub _test_line {
 538   my ($x, $y, @l) = @_;
 539
 540   my $res = $l[0]*$x + $l[1] * $y + $l[2];
 541   print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
 542 }
 543
 544 =item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
 545
 546 Attempts to fit text into a pie segment with its center at ($cx, $cy)
 547 with the given radius, covering the angles $begin through $end.
 548
 549 Returns a list defining the bounding box of the text if it does fit.
 550
 551 =cut
 552
 553 sub _fit_text {
 554   my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
 555
 556   #print "fit: $cx, $cy '$text' $radius $begin $end\n";
 557   my @tbox = $self->_text_bbox($text, $name)
 558     or return;
 559   my $tcx = floor(0.5+$cx + cos(($begin+$end)/2) * $radius *3/5);
 560   my $tcy = floor(0.5+$cy + sin(($begin+$end)/2) * $radius *3/5);
 561   my $topy = $tcy - $tbox[3]/2;
 562   my $boty = $topy + $tbox[3];
 563   my @lines;
 564   for my $y ($topy, $boty) {
 565     my %entry = ( 'y'=>$y );
 566     $entry{line} = [ line_from_points($tcx, $y, $tcx+1, $y) ];
 567     $entry{left} = -$radius;
 568     $entry{right} = $radius;
 569     for my $angle ($begin, $end) {
 570       my $ex = $cx + cos($angle)*$radius;
 571       my $ey = $cy + sin($angle)*$radius;
 572       my @line = line_from_points($cx, $cy, $ex, $ey);
 573       #_test_line($cx, $cy, @line);
 574       #_test_line($ex, $ey, @line);
 575       my $goodsign = $line[0] * $tcx + $line[1] * $tcy + $line[2];
 576       for my $pos (@entry{qw/left right/}) {
 577         my $sign = $line[0] * ($pos+$tcx) + $line[1] * $y + $line[2];
 578         if ($goodsign * $sign < 0) {
 579           if (my @p = intersect_lines(@line, @{$entry{line}})) {
 580             # die "$goodsign $sign ($pos, $tcx) no intersect (@line) (@{$entry{line}})"  ; # this would be wierd
 581             #_test_line(@p, @line);
 582             #_test_line(@p, @{$entry{line}});
 583             $pos = $p[0]-$tcx;
 584           }
 585           else {
 586             return;
 587           }
 588
 589         }
 590
 591         # circle
 592         my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx)
 593           + ($y - $cy) * ($y - $cy);
 594         if ($dist2 > $radius * $radius) {
 595           my @points =
 596             intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
 597           while (@points) {
 598             my @p = splice(@points, 0, 2);
 599             if ($p[0] < $cx && $tcx+$pos < $p[0]) {
 600               $pos = $p[0]-$tcx;
 601             }
 602             elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
 603               $pos = $p[0]-$tcx;
 604             }
 605           }
 606         }
 607       }
 608     }
 609     push(@lines, \%entry);
 610   }
 611   my $left = $lines[0]{left} > $lines[1]{left} ? $lines[0]{left} : $lines[1]{left};
 612   my $right = $lines[0]{right} < $lines[1]{right} ? $lines[0]{right} : $lines[1]{right};
 613   return if $right - $left < $tbox[2];
 614
 615   return ($tcx+$left, $topy, $tcx+$right, $boty);
 616 }
 617
 618 sub _composite {
 619   ( 'pie', $_[0]->SUPER::_composite() );
 620 }
 621
 622 sub _style_defs {
 623   my ($self) = @_;
 624
 625   my %work = %{$self->SUPER::_style_defs()};
 626   $work{otherlabel} = "(others)";
 627   $work{pie} =
 628     {
 629      guessfactor=>0.6,
 630      size=>0.8,
 631      maxsegment=> 0.01,
 632     };
 633
 634   \%work;
 635 }
 636
 637 1;
 638 __END__
 639
 640 =back
 641
 642 =head1 AUTHOR
 643
 644 Tony Cook <tony@develop-help.com>
 645
 646 =head1 SEE ALSO
 647
 648 Imager::Graph(3), Imager(3), perl(1)
 649
 650 =cut