survey-manager/survey-nginx/cgi-bin/bargraph_pnm.pm

#!/usr/bin/perl -w
#
# $Id: bargraph_pnm.pl
#

use strict;
use GD;
use GD::Graph::colour;
use GD::Graph::bars;
use GD::Graph::hbars;
# use GD::Graph::bars3d;
# use CGI qw(:standard);
#use Data::Dumper;

# This perl code is builds Graphs using the GD::Graph modules.
sub Build_Graph_PNM {
# The parameters are four lists, and a collection of scalars.  The lists are 
#  references to lists.
# The four lists are turned into lists of lists for the GD::Graph input.
# The scalars are individual options.
# The list parameters are: labels,colours, values, and values2.
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum
#   and t_margin, b_margin, l_margin, r_margin
# NOTE: xdim, and ydim are used as the height and width when the graph is created.

	my ($labels, $colours, $values, $values2, $xdim, $ydim, $hbar, $title,
		$xlabel, $ylabel, $ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin,
		$colorscheme)
		= @_ ;

	my $HBI_Debug_data = 1 ;

	my $max = 0;
	# $data[1] is now $values, $data[2] is now $values2. $data[0] is now $labels.
	my $element ;
	foreach $element (@{$values}) {
		defined $element and $max = ($max > $element ? $max : $element) ;
	}
	foreach $element (@{$values2}) {
		defined $element and $max = ($max > $element ? $max : $element) ;
	}

	my @data = ($labels, $values) ; # labels and values are mandatory.

	push @data, $values2 if ($values2) ; # values2 is optional.

	if ($HBI_Debug_data) {
		warn "INFO: " . __FILE__ . " data array len is $#data.\n" ;
		warn "INFO: labels array len is $#{$labels}.\n" ;
		warn "INFO: values array len is $#{$values}.\n" ;
		warn "INFO: values2 array len is $#{$values2}.\n" ;
	}

	$max *= 1.2;
	$max=5*(int($max/5)+1);

	if (not $xdim) {$xdim = 500;}
	if (not $ydim) {$ydim = 150};
	my $graph;
if ($hbar) {
    #print STDERR "hbar set\n";
    $graph = GD::Graph::hbars->new($xdim,$ydim);
} else {
    $graph = GD::Graph::bars->new($xdim,$ydim);
    #print STDERR "hbar not set\n";
}

my %opt = ('transparent' => 0,
	   'x_label_position' => 0.5,
	   'show_values' => 1,
	   'y_max_value' => $max,
	   'overwrite' => 1);
if ($title) {$opt{'title'} = $title;}
if ($xlabel) {$opt{'x_label'} = $xlabel;}
if ($ylabel) {$opt{'y_label'} = $ylabel;}
if ($ymax) {$opt{'y_max_value'} = $ymax;}
if ($ymin) {$opt{'y_min_value'} = $ymin;}
if ($t_margin) {$opt{'t_margin'} = $t_margin;}
if ($b_margin) {$opt{'b_margin'} = $b_margin;}
if ($l_margin) {$opt{'l_margin'} = $l_margin;}
if ($r_margin) {$opt{'r_margin'} = $r_margin;}
if ($yticknum) {$opt{'y_tick_number'} = $yticknum;}

my @ret_colour_names_avail = () ;
my %valid_colour_name = () ;
@ret_colour_names_avail = GD::Graph::colour::colour_list(59) ;
for my $clr_name (@ret_colour_names_avail) {
  if (defined $clr_name) {$valid_colour_name{$clr_name} = 1;}
}
# The keys of the hash array valid_colour_name are the known color names.

# warn $full_colour_list ;
# warn "The number of colours is $#ret_colour_names_avail ." ;
# The colors I found at one time are: pink lbrown lred purple 
# dblue lpurple green white gold blue dyellow red lgreen marine 
# dred cyan yellow lblue orange lgray dgreen dbrown lyellow 
# black gray dpink dgray lorange dpurple

# Set blue yellow if the colorscheme parameter is 1.
# else use the default.
if ($colorscheme and $colorscheme ==1) {
	$graph->set( dclrs => [ qw(blue yellow) ] ); 
}

if ($colours) {
	my @new_colors = split /:/ , $colours ;
	my $index = 0 ;
	my $colors = $graph->get('dclrs');
	my $color ;
	foreach $color (@new_colors) {
		if ($valid_colour_name{$color} ) {
			# warn "Pushed $color ." ;
			$colors->[$index] = $color ;
			$index ++ ;
		} else {
			# warn "Invalid color $color requested." ;
		}
	}
	# warn "Setting dclrs." ;
	$graph->set( dclrs => $colors) ;
	# warn "Set dclrs." ;
}

# my $HBI_colors="blue,yellow" ;
# my @HBI_color = split /,/ , $HBI_colors ;
# $graph->set( dclrs => [ split /./ , @HBI_color ] ) ;
# param('colours') = [ qw(blue yellow) ] ;
# if (param('colours')) {$graph->set( dclrs => param('colours')) ; }

$graph->set(%opt) or die $graph->error;
$graph->set_title_font(gdGiantFont);
$graph->set_x_label_font(gdGiantFont);
$graph->set_y_label_font(gdGiantFont);
$graph->set_x_axis_font(gdGiantFont);
$graph->set_y_axis_font(gdGiantFont);
$graph->set_values_font(gdGiantFont);

my $gd = $graph->plot(\@data) or die $graph->error;
#open(IMG, '>file.png') or die $!;
# binmode STDOUT;
# print header("image/png");
# print $gd->png;

my $png_data_str = $gd->png;

return $png_data_str ;

}

1 ;