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(labels=>['first segment', 'second segment'],
  14                          data=>[ $first_amount, $second_amount ],
  15                          size=>[$width, $height])
  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 # Imager doesn't have a arc boundary function, and the obvious code
  39 # either leaves gaps between the circle and the fill, or has some of the
  40 # fill outside the outline.  These fudge factors produced good results
  41 # for the test images <sigh>
  42 use constant CIRCLE_FUDGE_X => 0.4;
  43 use constant CIRCLE_FUDGE_Y => 0.4;
  44 use constant CIRCLE_RADIUS_FUDGE => 0.2;
  45
  46 =item $graph->draw(...)
  47
  48 Draws a pie graph onto a new image and returns the image.
  49
  50 You must at least supply a C<data> parameter and should probably supply a C<labels> parameter.
  51
  52 The C<data> parameter should be a reference to an array containing the
  53 data the pie graph should present.
  54
  55 The C<labels> parameter is a reference to an array of labels,
  56 corresponding to the values in C<data>.
  57
  58 =back
  59
  60 =head1 FEATURES
  61
  62 As described in L<Imager::Graph> you can enable extra features for
  63 your graph.  The features you can use with pie graphs are:
  64
  65 =over
  66
  67 =item legend
  68
  69 adds a legend to your graph.  Requires the labels parameter
  70
  71 =item labels
  72
  73 labels each segment of the graph.  If the label doesn't fit inside the
  74 segment it is presented as a callout.
  75
  76 =item labelspc
  77
  78 adds the percentage of the pie to each label.
  79
  80 =item labelspconly
  81
  82 the segments are labels with their percentages only.
  83
  84 =item allcallouts
  85
  86 all labels are presented as callouts
  87
  88 =item pieblur
  89
  90 the segments are blurred, as a substitute for anti-aliased arcs
  91
  92 =item outline
  93
  94 the pie segments are outlined.
  95
  96 =item dropshadow
  97
  98 the pie is given a drop shadow.
  99
 100 =back
 101
 102 =head1 EXAMPLES
 103
 104 Assuming:
 105
 106   # from the Netcraft September 2001 web survey
 107   # http://www.netcraft.com/survey/
 108   my @data   = qw(17874757  8146372   1321544  811406 );
 109   my @labels = qw(Apache    Microsoft iPlanet  Zeus   );
 110
 111   my $pie = Imager::Graph::Pie->new;
 112
 113 First a simple graph, normal size, no labels:
 114
 115   my $img = $pie->draw(data=>\@data)
 116     or die $pie->error;
 117
 118 label the segments:
 119
 120   # error handling omitted for brevity from now on
 121   $img = $pie->draw(data=>\@data, labels=>\@labels, features=>'labels');
 122
 123 just percentages in the segments:
 124
 125   $img = $pie->draw(data=>\@data, features=>'labelspconly');
 126
 127 add a legend as well:
 128
 129   $img = $pie->draw(data=>\@data, labels=>\@labels,
 130                     features=>[ 'labelspconly', 'legend' ]);
 131
 132 and a title, but move the legend down, and add a dropshadow:
 133
 134   $img = $pie->draw(data=>\@data, labels=>\@labels,
 135                     title=>'Netcraft Web Survey',
 136                     legend=>{ valign=>'bottom' },
 137                     features=>[ qw/labelspconly legend dropshadow/ ]);
 138
 139 something a bit prettier:
 140
 141   # requires Imager > 0.38
 142   $img = $pie->draw(data=>\@data, labels=>\@labels,
 143                     style=>'fount_lin', features=>'legend');
 144
 145 suitable for monochrome output:
 146
 147   # requires Imager > 0.38
 148   $img = $pie->draw(data=>\@data, labels=>\@labels,
 149                     style=>'mono', features=>'legend');
 150
 151 =cut
 152
 153 # this function is too long
 154 sub draw {
 155   my ($self, %opts) = @_;
 156
 157   $opts{data}
 158     or return $self->_error("No data parameter supplied");
 159   my @data = @{$opts{data}};
 160   my @labels;
 161   @labels = @{$opts{labels}} if $opts{labels};
 162
 163   $self->_style_setup(\%opts);
 164
 165   my $style = $self->{_style};
 166
 167   my $img = $self->_make_img()
 168     or return;
 169
 170   my $total = 0;
 171   for my $item (@data) {
 172     $total += $item;
 173   }
 174
 175   my @chart_box = ( 0, 0, $img->getwidth-1, $img->getheight-1 );
 176   if ($style->{title}{text}) {
 177     $self->_draw_title($img, \@chart_box)
 178       or return;
 179   }
 180
 181   # consolidate any segments that are too small to display
 182   $self->_consolidate_segments(\@data, \@labels, $total);
 183
 184   if ($style->{features}{legend} && $opts{labels}) {
 185     $self->_draw_legend($img, \@labels, \@chart_box)
 186       or return;
 187   }
 188
 189   # the following code is fairly ugly
 190   # it attempts to work out a good layout for the components of the chart
 191   my @info;
 192   my $index = 0;
 193   my $pos = 0;
 194   my @ebox = (0, 0, 0, 0);
 195   defined(my $callout_outside = $self->_get_number('callout.outside'))
 196     or return;
 197   defined(my $callout_leadlen = $self->_get_number('callout.leadlen'))
 198     or return;
 199   defined(my $callout_gap = $self->_get_number('callout.gap'))
 200     or return;
 201   defined(my $label_vpad = $self->_get_number('label.vpad'))
 202     or return;
 203   defined(my $label_hpad = $self->_get_number('label.hpad'))
 204     or return;
 205   my $guessradius =
 206     int($self->_small_extent(\@chart_box) * $style->{pie}{guessfactor} * 0.5);
 207   for my $data (@data) {
 208     my $item = { data=>$data, index=>$index };
 209     my $size = 2 * PI * $data / $total;
 210     $item->{begin} = $pos;
 211     $pos += $size;
 212     $item->{end} = $pos;
 213     if ($opts{labels}) {
 214       $item->{text} = $labels[$index];
 215     }
 216     if ($style->{features}{labelspconly}) {
 217       $item->{text} =
 218         $style->{label}{pconlyformat}->($data/$total * 100);
 219     }
 220     if ($item->{text}) {
 221       if ($style->{features}{labelspc}) {
 222         $item->{text} =
 223           $style->{label}{pcformat}->($item->{text}, $data/$total * 100);
 224         $item->{label} = 1;
 225       }
 226       elsif ($style->{features}{labelspconly}) {
 227         $item->{text} =
 228           $style->{label}{pconlyformat}->($data/$total * 100);
 229         $item->{label} = 1;
 230       }
 231       elsif ($style->{features}{labels}) {
 232         $item->{label} = 1;
 233       }
 234       $item->{lbox} = [ $self->_text_bbox($item->{text}, 'label') ];
 235       if ($item->{label}) {
 236         unless ($self->_fit_text(0, 0, 'label', $item->{text}, $guessradius,
 237                                  $item->{begin}, $item->{end})) {
 238           $item->{callout} = 1;
 239         }
 240       }
 241       $item->{callout} = 1 if $style->{features}{allcallouts};
 242       if ($item->{callout}) {
 243         $item->{label} = 0;
 244         $item->{cbox} = [ $self->_text_bbox($item->{text}, 'callout') ];
 245         $item->{cangle} = ($item->{begin} + $item->{end}) / 2;
 246         my $dist = cos($item->{cangle}) * ($guessradius+
 247                                            $callout_outside);
 248         my $co_size = $callout_leadlen + $callout_gap + $item->{cbox}[2];
 249         if ($dist < 0) {
 250           $dist -= $co_size - $guessradius;
 251           $dist < $ebox[0] and $ebox[0] = $dist;
 252         }
 253         else {
 254           $dist += $co_size - $guessradius;
 255           $dist > $ebox[2] and $ebox[2] = $dist;
 256         }
 257       }
 258     }
 259     push(@info, $item);
 260     ++$index;
 261   }
 262
 263   my $radius =
 264     int($self->_small_extent(\@chart_box) * $style->{pie}{size} * 0.5);
 265   my $max_width = $chart_box[2] - $chart_box[0] + $ebox[0] - $ebox[2];
 266   if ($radius > $max_width / 2) {
 267     $radius = $max_width / 2;
 268   }
 269   $chart_box[0] -= $ebox[0];
 270   $chart_box[2] -= $ebox[2];
 271   my $cx = int(($chart_box[0] + $chart_box[2]) / 2);
 272   my $cy = int(($chart_box[1] + $chart_box[3]) / 2);
 273   if ($style->{features}{dropshadow}) {
 274     my @shadow_fill = $self->_get_fill('dropshadow.fill')
 275       or return;
 276     my $offx = $self->_get_number('dropshadow.offx')
 277       or return;
 278     my $offy = $self->_get_number('dropshadow.offy');
 279     for my $item (@info) {
 280       $img->arc(x=>$cx+$offx, 'y'=>$cy+$offy, r=>$radius+1,
 281                 d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
 282                 @shadow_fill);
 283     }
 284     $self->_filter_region($img,
 285                           $cx+$offx-$radius-10, $cy+$offy-$radius-10,
 286                           $cx+$offx+$radius+10, $cy+$offy+$radius+10,
 287                           'dropshadow.filter')
 288       if $style->{dropshadow}{filter};
 289   }
 290   my @fill_box = ( $cx-$radius, $cy-$radius, $cx+$radius, $cy+$radius );
 291   for my $item (@info) {
 292     my @fill = $self->_data_fill($item->{index}, \@fill_box)
 293       or return;
 294     $img->arc(x=>$cx, 'y'=>$cy, r=>$radius,
 295               d1=>180/PI * $item->{begin}, d2=>180/PI * $item->{end},
 296               @fill);
 297   }
 298   if ($style->{features}{pieblur}) {
 299     $self->_pieblur($img, $cx, $cy, $radius);
 300   }
 301   if ($style->{features}{outline}) {
 302     my $outcolor = $self->_get_color('outline.line');
 303     for my $item (@info) {
 304       my $px = int($cx + CIRCLE_FUDGE_X +
 305                    ($radius+CIRCLE_RADIUS_FUDGE) * cos($item->{begin}));
 306       my $py = int($cy + CIRCLE_FUDGE_Y +
 307                    ($radius+CIRCLE_RADIUS_FUDGE) * sin($item->{begin}));
 308       $img->line(x1=>$cx, y1=>$cy, x2=>$px, y2=>$py, color=>$outcolor);
 309       for (my $i = $item->{begin}; $i < $item->{end}; $i += PI/180) {
 310         my $stroke_end = $i + PI/180;
 311         $stroke_end = $item->{end} if $stroke_end > $item->{end};
 312         my $nx = int($cx + CIRCLE_FUDGE_X +
 313                      ($radius+CIRCLE_RADIUS_FUDGE) * cos($stroke_end));
 314         my $ny = int($cy + CIRCLE_FUDGE_Y +
 315                      ($radius+CIRCLE_RADIUS_FUDGE) * sin($stroke_end));
 316         $img->line(x1=>$px, y1=>$py, x2=>$nx, y2=>$ny, color=>$outcolor,
 317                   antialias=>1);
 318         ($px, $py) = ($nx, $ny);
 319       }
 320     }
 321   }
 322
 323   my $callout_inside = $radius - $self->_get_number('callout.inside');
 324   $callout_outside += $radius;
 325   my %callout_text = $self->_text_style('callout');
 326   my %label_text = $self->_text_style('label');
 327   for my $label (@info) {
 328     if ($label->{label}) {
 329       my @loc = $self->_fit_text($cx, $cy, 'label', $label->{text}, $radius,
 330                                  $label->{begin}, $label->{end});
 331       if (@loc) {
 332         my $tcx = ($loc[0]+$loc[2])/2;
 333         my $tcy = ($loc[1]+$loc[3])/2;
 334         #$img->box(xmin=>$loc[0], ymin=>$loc[1], xmax=>$loc[2], ymax=>$loc[3],
 335         #          color=>Imager::Color->new(0,0,0));
 336         $img->string(%label_text, x=>$tcx-$label->{lbox}[2]/2,
 337                      'y'=>$tcy+$label->{lbox}[3]/2+$label->{lbox}[1],
 338                      text=>$label->{text});
 339       }
 340       else {
 341         $label->{callout} = 1;
 342         $label->{cbox} = [ $self->_text_bbox($label->{text}, 'callout') ];
 343         $label->{cangle} = ($label->{begin} + $label->{end}) / 2;
 344       }
 345     }
 346     if ($label->{callout}) {
 347       my $ix = floor(0.5 + $cx + $callout_inside * cos($label->{cangle}));
 348       my $iy = floor(0.5 + $cy + $callout_inside * sin($label->{cangle}));
 349       my $ox = floor(0.5 + $cx + $callout_outside * cos($label->{cangle}));
 350       my $oy = floor(0.5 + $cy + $callout_outside * sin($label->{cangle}));
 351       my $lx = ($ox < $cx) ? $ox - $callout_leadlen : $ox + $callout_leadlen;
 352       $img->line(x1=>$ix, y1=>$iy, x2=>$ox, y2=>$oy, antialias=>1,
 353                  color=>$self->_get_color('callout.color'));
 354       $img->line(x1=>$ox, y1=>$oy, x2=>$lx, y2=>$oy, antialias=>1,
 355                  color=>$self->_get_color('callout.color'));
 356       #my $tx = $lx + $callout_gap;
 357       my $ty = $oy + $label->{cbox}[3]/2+$label->{cbox}[1];
 358       if ($lx < $cx) {
 359         $img->string(%callout_text, x=>$lx-$callout_gap-$label->{cbox}[2],
 360                      'y'=>$ty, text=>$label->{text});
 361       }
 362       else {
 363         $img->string(%callout_text, x=>$lx+$callout_gap, 'y'=>$ty,
 364                      text=>$label->{text});
 365       }
 366     }
 367   }
 368
 369   $img;
 370 }
 371
 372 =head1 INTERNAL FUNCTIONS
 373
 374 These are used in the implementation of Imager::Graph, and are
 375 documented for debuggers and developers.
 376
 377 =over
 378
 379 =item _consolidate_segments($data, $labels, $total)
 380
 381 Consolidate segments that are too small into an 'others' segment.
 382
 383 =cut
 384
 385 sub _consolidate_segments {
 386   my ($self, $data, $labels, $total) = @_;
 387
 388   my @others;
 389   my $index;
 390   for my $item (@$data) {
 391     if ($item / $total < $self->{_style}{pie}{maxsegment}) {
 392       push(@others, $index);
 393     }
 394     ++$index;
 395   }
 396   if (@others) {
 397     my $others = 0;
 398     for my $index (reverse @others) {
 399       $others += $data->[$index];
 400       splice(@$labels, $index, 1);
 401       splice(@$data, $index, 1);
 402     }
 403     push(@$labels, $self->{_style}{otherlabel}) if @$labels;
 404     push(@$data, $others);
 405   }
 406 }
 407
 408 =item _pieblur($img, $cx, $cy, $radius)
 409
 410 Blurs the pie as a substitute for anti-aliased segments.
 411
 412 =cut
 413
 414 sub _pieblur {
 415   my ($self, $img, $cx, $cy, $radius) = @_;
 416
 417   my $left = $cx - $radius - 2;
 418   $left > 1 or $left = 2;
 419   my $right = $cx + $radius + 2;
 420   my $top = $cy - $radius - 2;
 421   $top > 1 or $top = 2;
 422   my $bottom = $cy + $radius + 2;
 423
 424   my $filter = $self->_get_thing("pie.blur")
 425     or return;
 426
 427   # newer versions of Imager let you work on just part of an image
 428   if ($img->can('masked') && !$self->{_style}{features}{_debugblur}) {
 429     # the mask prevents the blur from leaking over the edges
 430     my $mask = Imager->new(xsize=>$right-$left, ysize=>$bottom-$top,
 431                            channels=>1);
 432     $mask->arc(x=>$cx-$left, 'y'=>$cy-$top, r=>$radius);
 433     my $masked = $img->masked(mask=>$mask,
 434                               left=>$left, top=>$top,
 435                               right=>$right, bottom=>$bottom);
 436     $masked->filter(%{$self->{_style}{pie}{blur}});
 437   }
 438   else {
 439     # for older versions of Imager
 440     my $subset = $img->crop(left=>$left, top=>$top,
 441                             right=>$right, bottom=>$bottom);
 442     $subset->filter(%{$self->{_style}{pie}{blur}});
 443     $img->paste(left=>$left, top=>$top, img=>$subset);
 444   }
 445 }
 446
 447 # used for debugging
 448 sub _test_line {
 449   my ($x, $y, @l) = @_;
 450
 451   my $res = $l[0]*$x + $l[1] * $y + $l[2];
 452   print "test ", (abs($res) < 0.000001) ? "success\n" : "failure $res\n";
 453 }
 454
 455 =item _fit_text($cx, $cy, $name, $text, $radius, $begin, $end)
 456
 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.
 459
 460 Returns a list defining the bounding box of the text if it does fit.
 461
 462 =cut
 463
 464 sub _fit_text {
 465   my ($self, $cx, $cy, $name, $text, $radius, $begin, $end) = @_;
 466
 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];
 473   my @lines;
 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}});
 493             $pos = $p[0]-$tcx;
 494           }
 495           else {
 496             return;
 497           }
 498
 499         }
 500
 501         # circle
 502         my $dist2 = ($pos+$tcx-$cx) * ($pos+$tcx-$cx)
 503           + ($y - $cy) * ($y - $cy);
 504         if ($dist2 > $radius * $radius) {
 505           my @points =
 506             intersect_line_and_circle(@{$entry{line}}, $cx, $cy, $radius);
 507           while (@points) {
 508             my @p = splice(@points, 0, 2);
 509             if ($p[0] < $cx && $tcx+$pos < $p[0]) {
 510               $pos = $p[0]-$tcx;
 511             }
 512             elsif ($p[0] > $cx && $tcx+$pos > $p[0]) {
 513               $pos = $p[0]-$tcx;
 514             }
 515           }
 516         }
 517       }
 518     }
 519     push(@lines, \%entry);
 520   }
 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];
 524
 525   return ($tcx+$left, $topy, $tcx+$right, $boty);
 526 }
 527
 528 sub _composite {
 529   ( 'pie', $_[0]->SUPER::_composite() );
 530 }
 531
 532 sub _style_defs {
 533   my ($self) = @_;
 534
 535   my %work = %{$self->SUPER::_style_defs()};
 536   $work{otherlabel} = "(others)";
 537   $work{features}{pieblur} = 1;
 538   $work{pie} =
 539     {
 540      blur => {
 541               type=>'conv',
 542               coef=>[0.05, 0.1, 0.3, 1, 0.3, 0.1, 0.05]
 543              },
 544      guessfactor=>0.6,
 545      size=>0.8,
 546      maxsegment=> 0.05,
 547     };
 548
 549   \%work;
 550 }
 551
 552 1;
 553 __END__
 554
 555 =head1 AUTHOR
 556
 557 Tony Cook <tony@develop-help.com>
 558
 559 =head1 SEE ALSO
 560
 561 Imager::Graph(3), Imager(3), perl(1)
 562
 563 =cut