lib/Yaala/Report/GDGraph.pm

   1 package Yaala::Report::GDGraph;
   2
   3 use strict;
   4 use warnings;
   5 use vars qw#$GRAPH_WIDTH $GRAPH_HEIGHT#;
   6
   7 use Exporter;
   8 use Yaala::Data::Core qw#get_values receive#;
   9 use Yaala::Config qw#get_config#;
  10 use Yaala::Html qw#get_filename get_title#;
  11 use Yaala::Report::Core qw#$OUTPUTDIR#;
  12
  13 @Yaala::Report::GDGraph::EXPORT_OK = qw#generate_graph $GRAPH_WIDTH $GRAPH_HEIGHT#;
  14 @Yaala::Report::GDGraph::ISA = ('Exporter');
  15
  16 $GRAPH_WIDTH = 500;
  17 $GRAPH_HEIGHT = 250;
  18
  19 our $HAVE_GD_GRAPH = 0;
  20 our $MAX_VALUES = 25;
  21 our $WANT_GRAPHS = 0;
  22
  23 my $VERSION = '$Id: GDGraph.pm,v 1.9 2003/12/07 14:53:30 octo Exp $';
  24 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  25
  26 eval "use GD::Graph::bars;";
  27 if (!$@)
  28 {
  29         $HAVE_GD_GRAPH = 1;
  30         print STDERR ' - GD::Graph is installed' if ($::DEBUG);
  31 }
  32 else
  33 {
  34         print STDERR ' - GD::Graph is NOT installed' if ($::DEBUG);
  35 }
  36
  37 $WANT_GRAPHS = $HAVE_GD_GRAPH;
  38
  39 if (get_config ('graph_height'))
  40 {
  41         my $height = get_config ('graph_height');
  42         $height =~ s/\D//g;
  43
  44         if (($height > 100) and ($height < 1000))
  45         {
  46                 $GRAPH_HEIGHT = $height;
  47         }
  48         else
  49         {
  50                 print STDERR $/, __FILE__, ": ``$height'' is not a valid value for ``graph_height'' and will be ignored.";
  51         }
  52 }
  53
  54 if (get_config ('graph_width'))
  55 {
  56         my $width = get_config ('graph_width');
  57         $width =~ s/\D//g;
  58
  59         if (($width > 100) and ($width < 1000))
  60         {
  61                 $GRAPH_WIDTH = $width;
  62                 $MAX_VALUES = int ($GRAPH_WIDTH / 20);
  63         }
  64         else
  65         {
  66                 print STDERR $/, __FILE__, ": ``$width'' is not a valid value for ``graph_width'' and will be ignored.";
  67         }
  68 }
  69
  70 if (get_config ('print_graphs'))
  71 {
  72         my $want = lc (get_config ('print_graphs'));
  73         if ($want eq 'no' or $want eq 'false' or $want eq 'off')
  74         {
  75                 $WANT_GRAPHS = 0;
  76         }
  77         elsif ($want eq 'yes' or $want eq 'true' or $want eq 'on')
  78         {
  79                 if (!$HAVE_GD_GRAPH)
  80                 {
  81                         print STDERR $/, __FILE__, ": You've set ``print_graphs'' to ``$want''.",
  82                                 $/, __FILE__, '  However, the graphs cannot be genereted, because GD::Graph cannot be found.',
  83                                 $/, __FILE__, '  Please go to your nearest CPAN-mirror and install it first.',
  84                                 $/, __FILE__, '  This config-option will be ignored.';
  85                 }
  86         }
  87         elsif ($want eq 'auto' or $want eq 'automatic')
  88         {
  89                 # do nothing.. Already been done.
  90         }
  91         else
  92         {
  93                 print STDERR $/, __FILE__, ": You've set ``print_graphs'' to ``$want''.",
  94                         $/, __FILE__, '  This value is not understood and is being ignored.';
  95         }
  96 }
  97
  98 if ($::DEBUG & 0x100)
  99 {
 100         print STDERR $/, __FILE__, ': Size: ', $GRAPH_WIDTH, 'x', $GRAPH_HEIGHT,
 101         "; Max number of values: $MAX_VALUES";
 102 }
 103
 104 return (1);
 105
 106 sub generate_graph
 107 {
 108         my $sel = shift;
 109         my $key = shift;
 110
 111         my $where_key = shift;
 112         my $where_val = shift;
 113
 114         return ('') unless ($HAVE_GD_GRAPH and $WANT_GRAPHS);
 115
 116         if (!defined ($where_key) or !defined ($where_val)
 117                         or !$where_key or !$where_val)
 118         {
 119                 $where_key = '';
 120                 $where_val = '';
 121         }
 122
 123         my @aggs = @{$sel->[0]};
 124         my $num_aggs = scalar (@aggs);
 125
 126         my $filename = get_filename ($sel);
 127         {
 128                 my $replacement = "__$key";
 129                 if ($where_key)
 130                 {
 131                         $replacement .= "__$where_key" . "_$where_val";
 132                 }
 133                 $replacement =~ s/\W+/_/g;
 134                 $replacement .= '.png';
 135
 136                 $filename =~ s/\.html$/$replacement/;
 137         }
 138
 139         my @key_values = get_values ($sel, $key);
 140         @key_values = sort (@key_values);
 141
 142         my @agg_values = get_agg_values ($sel, $key, \@key_values, $where_key, $where_val);
 143
 144         if (scalar (@key_values) > $MAX_VALUES)
 145         {
 146                 discard_values (\@key_values, \@agg_values);
 147         }
 148
 149         for (@key_values)
 150         {
 151                 next if (length ($_) < 20);
 152
 153                 substr ($_, 17) = ' ..';
 154         }
 155
 156         my @data_set = (\@key_values, @agg_values);
 157
 158         my $title = join (', ', map { ucfirst ($_) } (@aggs)) . ' by ' . ucfirst ($key);
 159         if ($where_val) { $title .= ' for ' . $where_val; }
 160
 161         print STDERR $/, __FILE__, qq#: Generating image "$title" [$filename]#
 162         if ($::DEBUG & 0x100);
 163
 164         my $graph = GD::Graph::bars->new ($GRAPH_WIDTH, $GRAPH_HEIGHT);
 165         $graph->set
 166         (
 167                 title           => $title,
 168                 x_label         => ucfirst ($key),
 169                 y_label         => 'Percent',
 170
 171                 x_labels_vertical => 1,
 172                 x_label_position  => 1,
 173                 long_ticks      => 1,
 174
 175 #               logo            => 'reports/logo.png',
 176                 transparent     => 1,
 177                 shadow_depth    => 2,
 178
 179                 fgclr           => 'lgray',
 180                 bgclr           => 'white',
 181                 dclrs           => [ qw(lgray gray dgray) ],
 182                 borderclrs      => [ qw(black black black) ],
 183                 shadowclr       => 'gray',
 184                 labelclr        => 'black',
 185                 axislabelclr    => 'black',
 186                 legendclr       => 'black',
 187                 valuesclr       => 'black',
 188                 textclr         => 'black'
 189         );
 190
 191         if ($num_aggs > 1)
 192         {
 193                 $graph->set (legend_placement => 'BR');
 194                 $graph->set_legend (map { ucfirst ($_) } (@aggs));
 195         }
 196
 197         if (open (IMG, ">  $OUTPUTDIR$filename"))
 198         {
 199                 binmode IMG;
 200                 print IMG $graph->plot(\@data_set)->png;
 201                 close IMG;
 202         }
 203         else
 204         {
 205                 print STDERR $/, __FILE__, ": Unable to open ``$filename'': $!";
 206                 $filename = undef;
 207         }
 208
 209         return ($filename);
 210 }
 211
 212 sub discard_values
 213 {
 214         my $key_array = shift;
 215         my $val_array = shift;
 216
 217         my @orig_sort = @$key_array;
 218         my $num_values = scalar (@$key_array);
 219
 220         return (1) if ($num_values < $MAX_VALUES);
 221
 222         my %vals_by_key = ();
 223         my %tmp_hash = ();
 224
 225         my $i;
 226         for ($i = 0; $i < $num_values; $i++)
 227         {
 228                 my $key = shift (@$key_array);
 229                 my @vals = ();
 230                 my $sum = 0;
 231
 232                 for (@$val_array)
 233                 {
 234                         my $tmp = shift (@$_);
 235                         push (@vals, $tmp);
 236                         $sum += $tmp;
 237                 }
 238
 239                 $vals_by_key{$key} = \@vals;
 240                 $tmp_hash{$key} = $sum;
 241         }
 242
 243         my @small_sorted = sort { $tmp_hash{$b} <=> $tmp_hash{$a} } (keys (%tmp_hash));
 244
 245         for ($i = 0; $i < $MAX_VALUES; $i++)
 246         {
 247                 shift (@small_sorted);
 248         }
 249
 250         for (@orig_sort)
 251         {
 252                 my $this_key = $_;
 253                 if (grep { $_ eq $this_key } (@small_sorted))
 254                 {
 255                         #$other += $tmp_hash{$this_key};
 256                 }
 257                 else
 258                 {
 259                         push (@$key_array, $this_key);
 260                         my $vals = $vals_by_key{$this_key};
 261                         for (@$val_array)
 262                         {
 263                                 my $val = shift (@$vals);
 264                                 push (@$_, $val);
 265                         }
 266                 }
 267         }
 268 }
 269
 270 sub get_agg_values
 271 {
 272         my $sel = shift;
 273         my $key = shift;
 274         my $key_values = shift;
 275
 276         my $where_key = '';
 277         my $where_val = '';
 278
 279         if (@_)
 280         {
 281                 $where_key = shift;
 282                 $where_val = shift;
 283         }
 284
 285         my @aggs = @{$sel->[0]};
 286         my @agg_values = ();
 287
 288         my %max_val = ();
 289
 290         for (@aggs)
 291         {
 292                 my $agg = $_;
 293                 my @tmp = ();
 294                 $max_val{$agg} = 0;
 295
 296                 my $grand_total = 0;
 297                 #if (scalar (@aggs) > 1)
 298                 {
 299                         my %query = ();
 300                         if ($where_key) { $query{$where_key} = $where_val; }
 301
 302                         $grand_total = receive ($sel, $agg, {});
 303                 }
 304
 305                 for (@$key_values)
 306                 {
 307                         my %query = ($key => $_);
 308                         if ($where_key) { $query{$where_key} = $where_val; }
 309
 310                         my $sum = receive ($sel, $agg, \%query);
 311
 312                         if ($grand_total)
 313                         {
 314                                 $sum = 100 * $sum / $grand_total;
 315                         }
 316
 317                         push (@tmp, $sum);
 318
 319                         if ($sum > $max_val{$agg})
 320                         {
 321                                 $max_val{$agg} = $sum;
 322                         }
 323                 }
 324
 325                 push (@agg_values, \@tmp);
 326         }
 327
 328         return (@agg_values);
 329 }