You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
131 lines
4.4 KiB
131 lines
4.4 KiB
#!/usr/bin/perl -w
|
|
#
|
|
# $Id: bargraph.pl,v 1.9 2004/05/11 21:00:18 jeffo Exp $
|
|
#
|
|
|
|
# The code needs to be changed to unmunge the data values.
|
|
|
|
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 a target for URL to build Graphs using the GD::Graph modules.
|
|
# The parameters are four lists, and a collection of scalars. The lists are
|
|
# URL parameters that are ultimately split on a colon, and unmunged after that.
|
|
# The three 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 @data = ([split(/:/,param('labels'))],
|
|
[map(($_ eq ''? undef : $_),split(/:/,param('values')))]);
|
|
if (param('values2')) {push @data,[map(($_ eq ''? undef : $_),split(/:/,param('values2')))];}
|
|
|
|
# The variable is an array of arrays. The first array is a list of names.
|
|
# The second array is a list of the values for the first name.
|
|
# The third array is a list of the values for the second name.
|
|
|
|
#print STDERR Dumper(\@data);
|
|
|
|
my $max = 0;
|
|
foreach (@{$data[1]}) {defined $_ and $max = ($max > $_? $max : $_);}
|
|
if ($data[2]) {foreach (@{$data[2]}) {defined $_ and $max = ($max > $_? $max : $_);}}
|
|
|
|
$max *= 1.2;
|
|
$max=5*(int($max/5)+1);
|
|
|
|
my $xdim = param('xdim');
|
|
if (not $xdim) {$xdim = 500;}
|
|
my $ydim = param('ydim');
|
|
if (not $ydim) {$ydim = 150};
|
|
my $graph;
|
|
if (param('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 (param('title')) {$opt{'title'} = param('title');}
|
|
if (param('xlabel')) {$opt{'x_label'} = param('xlabel');}
|
|
if (param('ylabel')) {$opt{'y_label'} = param('ylabel');}
|
|
if (param('ymax')) {$opt{'y_max_value'} = param('ymax');}
|
|
if (param('ymin')) {$opt{'y_min_value'} = param('ymin');}
|
|
if (param('t_margin')) {$opt{'t_margin'} = param('t_margin');}
|
|
if (param('b_margin')) {$opt{'b_margin'} = param('b_margin');}
|
|
if (param('l_margin')) {$opt{'l_margin'} = param('l_margin');}
|
|
if (param('r_margin')) {$opt{'r_margin'} = param('r_margin');}
|
|
if (param('yticknum')) {$opt{'y_tick_number'} = param('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 (param('colorscheme') and param('colorscheme')==1) {
|
|
$graph->set( dclrs => [ qw(blue yellow) ] );
|
|
}
|
|
|
|
if (param('colours')) {
|
|
my @new_colors = split /:/ , param('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;
|
|
|