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.
244 lines
11 KiB
244 lines
11 KiB
4 months ago
|
#!/usr/bin/perl -w
|
||
|
|
#
|
||
|
|
# $Id: bargraph_multi.pm
|
||
|
|
#
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
package bargraph_multi ;
|
||
|
|
require Exporter ;
|
||
|
|
@bargraph_multi::ISA = qw(Exporter) ;
|
||
|
|
@bargraph_multi::EXPORT = qw(Build_Labeled_X_Axis_Graph_Str Build_Labeled_X_Axis_Graph_Obj) ;
|
||
|
|
@bargraph_multi::EXPORT_OK = qw( ) ;
|
||
|
|
use GD;
|
||
|
|
use GD::Graph::colour;
|
||
|
|
use GD::Graph::bars;
|
||
|
|
use GD::Graph::hbars;
|
||
|
|
use GD::Graph::bars3d;
|
||
|
|
#use Data::Dumper;
|
||
|
|
|
||
|
|
# This perl code is builds Graphs using the GD::Graph modules.
|
||
|
|
# This code deals with a non-numeric X-Axis. Each tick on the X-Axis is the name of a group.
|
||
|
|
# The other style has a numeric X-Axis.
|
||
|
|
sub Build_Labeled_X_Axis_Graph_Str {
|
||
|
|
# The parameters are:
|
||
|
|
# $Data_In - A reference to a list of lists. (aka, Array of Arrays)
|
||
|
|
# Each of the sublists has the same number of elements.
|
||
|
|
# An element might be the undef value.
|
||
|
|
# The first sublist is the names of the groups.
|
||
|
|
# The other sublists are related to the elements in the $Legend parameter.
|
||
|
|
# $Legend - A reference to a list.
|
||
|
|
# Each element of the list is the name of a group.
|
||
|
|
# The data for each group is a sublist in the $Data_In parameter.
|
||
|
|
# ---- The rest of the parameters are individual options as scalars: numbers, character strings, or undef.
|
||
|
|
# The returned value is a list of (reference to the plotted graphical object, and graphic string in the mode.
|
||
|
|
my ($Data_In, $Legend, $Graphic_Mode, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel,
|
||
|
|
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin,
|
||
|
|
$colorscheme, $bar_spacing, $bargroup_spacing,
|
||
|
|
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite,
|
||
|
|
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth,
|
||
|
|
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs,
|
||
|
|
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format,
|
||
|
|
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks,
|
||
|
|
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values,
|
||
|
|
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space,
|
||
|
|
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space,
|
||
|
|
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols
|
||
|
|
) = @_ ;
|
||
|
|
my $Graph_Obj = &Build_Labeled_X_Axis_Graph_Obj
|
||
|
|
($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel,
|
||
|
|
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin,
|
||
|
|
$colorscheme, $bar_spacing, $bargroup_spacing,
|
||
|
|
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite,
|
||
|
|
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth,
|
||
|
|
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs,
|
||
|
|
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format,
|
||
|
|
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks,
|
||
|
|
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values,
|
||
|
|
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space,
|
||
|
|
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space,
|
||
|
|
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) ;
|
||
|
|
my $Plotted_Str ;
|
||
|
|
unless (defined $Graph_Obj) {
|
||
|
|
return (undef, "") ;
|
||
|
|
} else {
|
||
|
|
if ($Graphic_Mode =~ m/png/i) {
|
||
|
|
$Plotted_Str = $Graph_Obj -> png ;
|
||
|
|
} elsif ($Graphic_Mode =~ m/gif/i) {
|
||
|
|
$Plotted_Str = $Graph_Obj -> gif ;
|
||
|
|
} else {
|
||
|
|
return ($Graphic_Mode, "Unsupported Graphical Mode $Graph_Obj.\n") ;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return ($Graph_Obj, $Plotted_Str) ;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub Build_Labeled_X_Axis_Graph_Obj {
|
||
|
|
my ($Data_In, $Legend, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel,
|
||
|
|
$ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin,
|
||
|
|
$colorscheme, $bar_spacing, $bargroup_spacing,
|
||
|
|
$show_values, $x_label_position, $y_label_position, $transparent, $overwrite,
|
||
|
|
$interlaced, $bgclr, $fgclr, $boxclr, $accentclr, $shadowclr, $shadow_depth,
|
||
|
|
$labelclr, $axislabelclr, $legendclr, $valuesclr, $textclr, $dclrs, $borderclrs,
|
||
|
|
$cycle_clrs, $accent_treshold, $long_ticks, $tick_length, $x_ticks, $y_number_format,
|
||
|
|
$x_label_skip, $y_label_skip, $x_last_label_skip, $x_tick_offset, $x_all_ticks,
|
||
|
|
$x_label_position, $y_label_position, $x_labels_vertical, $x_plot_values, $y_plot_values,
|
||
|
|
$box_axis, $no_axes, $two_axes, $use_axis, $zero_axis, $zero_axis_only, $axis_space,
|
||
|
|
$text_space, $cumulate, $overwrite, $correct_width, $values_vertical, $values_space,
|
||
|
|
$values_format, $legend_placement, $legend_marker_width, $legend_marker_height, $lg_cols ) = @_ ;
|
||
|
|
# $colorscheme is a colon seperated string of colors.
|
||
|
|
my $HBI_Debug_Obj = 0 ;
|
||
|
|
my $Data_In_sublist ; my $Data_In_cnt = 0 ;
|
||
|
|
|
||
|
|
if ($HBI_Debug_Obj) {
|
||
|
|
warn "INFO: " . __FILE__ . " Legend array len is $#{$Legend}.\n" ;
|
||
|
|
foreach $Data_In_sublist (@{$Data_In}) {
|
||
|
|
warn "INFO: Data array len is $#{$Data_In_sublist}.\n" ;
|
||
|
|
$Data_In_cnt ++ ;
|
||
|
|
}
|
||
|
|
warn "INFO: Data array $Data_In_cnt elements.\n" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
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 @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) ] );
|
||
|
|
} elsif ($colorscheme) {
|
||
|
|
my @new_colors = split /:/ , $colorscheme ;
|
||
|
|
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 %opt = ('transparent' => 0,
|
||
|
|
'x_label_position' => 0.5,
|
||
|
|
'show_values' => 1,
|
||
|
|
'y_max_value' => 100,
|
||
|
|
'overwrite' => 0);
|
||
|
|
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;}
|
||
|
|
if ($bar_spacing) {$opt{'bar_spacing'} = $bar_spacing;}
|
||
|
|
if ($bargroup_spacing) {$opt{'bargroup_spacing'} = $bargroup_spacing;}
|
||
|
|
if ($show_values) {$opt{'show_values'} = $show_values;}
|
||
|
|
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position;}
|
||
|
|
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position;}
|
||
|
|
if ($transparent) {$opt{'transparent'} = $transparent;}
|
||
|
|
if ($overwrite) {$opt{'overwrite'} = $overwrite;}
|
||
|
|
if ($interlaced) {$opt{'interlaced'} = $interlaced;}
|
||
|
|
if ($bgclr) {$opt{'bgclr'} = $bgclr;}
|
||
|
|
if ($fgclr) {$opt{'fgclr'} = $fgclr;}
|
||
|
|
if ($boxclr) {$opt{'boxclr'} = $boxclr;}
|
||
|
|
if ($accentclr) {$opt{'accentclr'} = $accentclr;}
|
||
|
|
if ($shadowclr) {$opt{'shadowclr'} = $shadowclr;}
|
||
|
|
if ($shadow_depth) {$opt{'shadow_depth'} = $shadow_depth;}
|
||
|
|
if ($labelclr) {$opt{'labelclr'} = $labelclr ;}
|
||
|
|
if ($axislabelclr) {$opt{'axislabelclr'} = $axislabelclr ;}
|
||
|
|
if ($legendclr) {$opt{'legendclr'} = $legendclr ;}
|
||
|
|
if ($valuesclr) {$opt{'valuesclr'} = $valuesclr ;}
|
||
|
|
if ($textclr) {$opt{'textclr'} = $textclr ;}
|
||
|
|
if ($dclrs) {$opt{'dclrs'} = $dclrs ;}
|
||
|
|
if ($borderclrs) {$opt{'borderclrs'} = $borderclrs ;}
|
||
|
|
if ($cycle_clrs) {$opt{'cycle_clrs'} = $cycle_clrs ;}
|
||
|
|
if ($accent_treshold) {$opt{'accent_treshold'} = $accent_treshold ;}
|
||
|
|
if ($long_ticks) {$opt{'long_ticks'} = $long_ticks ;}
|
||
|
|
if ($tick_length) {$opt{'tick_length'} = $tick_length ;}
|
||
|
|
if ($x_ticks) {$opt{'x_ticks'} = $x_ticks ;}
|
||
|
|
if ($y_number_format) {$opt{'y_number_format'} = $y_number_format ;}
|
||
|
|
if ($x_label_skip) {$opt{'x_label_skip'} = $x_label_skip ;}
|
||
|
|
if ($y_label_skip) {$opt{'y_label_skip'} = $y_label_skip ;}
|
||
|
|
if ($x_last_label_skip) {$opt{'x_last_label_skip'} = $x_last_label_skip ;}
|
||
|
|
if ($x_tick_offset) {$opt{'x_tick_offset'} = $x_tick_offset ;}
|
||
|
|
if ($x_all_ticks) {$opt{'x_all_ticks'} = $x_all_ticks ;}
|
||
|
|
if ($x_label_position) {$opt{'x_label_position'} = $x_label_position ;}
|
||
|
|
if ($y_label_position) {$opt{'y_label_position'} = $y_label_position ;}
|
||
|
|
if ($x_labels_vertical) {$opt{'x_labels_vertical'} = $x_labels_vertical ;}
|
||
|
|
if ($x_plot_values) {$opt{'x_plot_values'} = $x_plot_values ;}
|
||
|
|
if ($y_plot_values) {$opt{'y_plot_values'} = $y_plot_values ;}
|
||
|
|
if ($box_axis) {$opt{'box_axis'} = $box_axis ;}
|
||
|
|
if ($no_axes) {$opt{'no_axes'} = $no_axes ;}
|
||
|
|
if ($two_axes) {$opt{'two_axes'} = $two_axes ;}
|
||
|
|
if ($use_axis) {$opt{'use_axis'} = $use_axis ;}
|
||
|
|
if ($zero_axis) {$opt{'zero_axis'} = $zero_axis ;}
|
||
|
|
if ($zero_axis_only) {$opt{'zero_axis_only'} = $zero_axis_only ;}
|
||
|
|
if ($axis_space) {$opt{'axis_space'} = $axis_space ;}
|
||
|
|
if ($text_space) {$opt{'text_space'} = $text_space ;}
|
||
|
|
if ($cumulate) {$opt{'cumulate'} = $cumulate ;}
|
||
|
|
if ($overwrite) {$opt{'overwrite'} = $overwrite ;}
|
||
|
|
if ($correct_width) {$opt{'correct_width'} = $correct_width ;}
|
||
|
|
if ($values_vertical) {$opt{'values_vertical'} = $values_vertical ;}
|
||
|
|
if ($values_space) {$opt{'values_space'} = $values_space ;}
|
||
|
|
if ($values_format) {$opt{'values_format'} = $values_format ;}
|
||
|
|
if ($legend_placement) {$opt{'legend_placement'} = $legend_placement ;}
|
||
|
|
if ($legend_marker_width) {$opt{'legend_marker_width'} = $legend_marker_width ;}
|
||
|
|
if ($legend_marker_height) {$opt{'legend_marker_height'} = $legend_marker_height ;}
|
||
|
|
if ($lg_cols) {$opt{'lg_cols'} = $lg_cols ;}
|
||
|
|
|
||
|
|
if ((defined $Legend) && (ref($Legend) eq "ARRAY") && ($#{${Legend}} >= 0)) {
|
||
|
|
$graph -> set_legend(@{$Legend}) ;
|
||
|
|
} else {
|
||
|
|
warn "ERROR: Empty Legend array passed to XXX." ;
|
||
|
|
}
|
||
|
|
|
||
|
|
$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);
|
||
|
|
$graph->set_legend_font(gdGiantFont);
|
||
|
|
|
||
|
|
my $gd = $graph->plot($Data_In) ;
|
||
|
|
|
||
|
|
return $gd
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
1 ;
|
||
|
|
|