| 1 | use strict; use warnings;
|
|---|
| 2 |
|
|---|
| 3 | # This class manages all functions of the open flash chart api.
|
|---|
| 4 | package chart;
|
|---|
| 5 |
|
|---|
| 6 | my $open_flash_chart_seqno = 0;
|
|---|
| 7 | my $BOOTSTRAP_COMPLETED = 0;
|
|---|
| 8 |
|
|---|
| 9 | sub new() {
|
|---|
| 10 | # Constructer for the open_flash_chart_api
|
|---|
| 11 | # Sets our default variables
|
|---|
| 12 | my ($proto) = @_;
|
|---|
| 13 | my $class = ref($proto) || $proto;
|
|---|
| 14 | my $self = {};
|
|---|
| 15 | bless $self, $class;
|
|---|
| 16 |
|
|---|
| 17 | $self->{'open_flash_chart_seqno'} = $open_flash_chart_seqno++;
|
|---|
| 18 | $self->{'data_load_type'} = 'inline_js'; # or 'url_callback' not sure if we still need both
|
|---|
| 19 |
|
|---|
| 20 | $self->{'chart_props'} = {
|
|---|
| 21 |
|
|---|
| 22 | "title"=>{
|
|---|
| 23 | "text"=>"Default Chart Title",
|
|---|
| 24 | "style"=>"{font-size:20px; font-family:Verdana; text-align:center;}"
|
|---|
| 25 | },
|
|---|
| 26 | "x_legend"=>{
|
|---|
| 27 | "text" => "1983 to 2008",
|
|---|
| 28 | "style"=> "{font-size: 20px; color: #778877;}"
|
|---|
| 29 | },
|
|---|
| 30 | };
|
|---|
| 31 |
|
|---|
| 32 | #setup default axis
|
|---|
| 33 | my $x = $self->get_axis('x_axis');
|
|---|
| 34 | $x->set_labels({"labels"=>["January","February","March","April","May"]});
|
|---|
| 35 | my $y = $self->get_axis('y_axis');
|
|---|
| 36 |
|
|---|
| 37 | $self->{'elements'} = [];
|
|---|
| 38 |
|
|---|
| 39 | return $self;
|
|---|
| 40 | }
|
|---|
| 41 |
|
|---|
| 42 | sub bootstrap_completed {
|
|---|
| 43 | my ($self, $value) = @_;
|
|---|
| 44 | $BOOTSTRAP_COMPLETED = $value if defined($value);
|
|---|
| 45 | return $BOOTSTRAP_COMPLETED;
|
|---|
| 46 | }
|
|---|
| 47 |
|
|---|
| 48 | sub get_axis {
|
|---|
| 49 | my ($self, $axis_name) = @_;
|
|---|
| 50 | if ( !defined($self->{'axis'}->{$axis_name}) ) {
|
|---|
| 51 | $self->{'axis'}->{$axis_name} = axis->new($axis_name);
|
|---|
| 52 | }
|
|---|
| 53 | return $self->{'axis'}->{$axis_name}
|
|---|
| 54 | }
|
|---|
| 55 |
|
|---|
| 56 | sub set_axis() {
|
|---|
| 57 | my ($self, $axis) = @_;
|
|---|
| 58 | $self->{'axis'}->{$axis->{'name'}} = $axis;
|
|---|
| 59 | }
|
|---|
| 60 |
|
|---|
| 61 | # elements are the data series items, usually containing values to plot
|
|---|
| 62 | sub get_element() {
|
|---|
| 63 | my ($self, $element_name) = @_;
|
|---|
| 64 |
|
|---|
| 65 | my $e=undef;
|
|---|
| 66 | eval("\$e = ${element_name}->new();");
|
|---|
| 67 | if ( defined($e) ) {
|
|---|
| 68 | return $e;
|
|---|
| 69 | }
|
|---|
| 70 | }
|
|---|
| 71 |
|
|---|
| 72 | # Should be not used for single value elements
|
|---|
| 73 | # Your axis min/max will not be set
|
|---|
| 74 | sub add_element() {
|
|---|
| 75 | my ($self, $element) = @_;
|
|---|
| 76 | push(@{$self->{'elements'}}, $element);
|
|---|
| 77 | }
|
|---|
| 78 |
|
|---|
| 79 |
|
|---|
| 80 | sub render_chart_data() {
|
|---|
| 81 | my ($self) = @_;
|
|---|
| 82 |
|
|---|
| 83 | my $tmp = '';
|
|---|
| 84 |
|
|---|
| 85 | $tmp .= "{";
|
|---|
| 86 | $tmp .= main::to_json($self->{'chart_props'});
|
|---|
| 87 |
|
|---|
| 88 | #render axis data
|
|---|
| 89 | for ( keys %{$self->{'axis'}} ) {
|
|---|
| 90 | $tmp .= $self->{'axis'}->{$_}->to_json();
|
|---|
| 91 |
|
|---|
| 92 | for my $element ( @{$self->{'axis'}->{$_}->{'elements'}} ) {
|
|---|
| 93 | #$main::Response->write($element);
|
|---|
| 94 | $self->add_element($element);
|
|---|
| 95 | }
|
|---|
| 96 | }
|
|---|
| 97 |
|
|---|
| 98 | if ( @{$self->{'elements'}} > 0 ) {
|
|---|
| 99 | $tmp .= "\n".'"elements" : [';
|
|---|
| 100 | for my $s ( @{$self->{'elements'}} ) {
|
|---|
| 101 | #$main::Response->write($s);
|
|---|
| 102 | $tmp .= $s->to_json() . ',';
|
|---|
| 103 | }
|
|---|
| 104 | $tmp =~ s/,$//g;
|
|---|
| 105 | $tmp .= ']';
|
|---|
| 106 | }
|
|---|
| 107 | $tmp =~ s/,$//g;
|
|---|
| 108 | $tmp .= "\n}";
|
|---|
| 109 |
|
|---|
| 110 | return $tmp;
|
|---|
| 111 | }
|
|---|
| 112 |
|
|---|
| 113 | #
|
|---|
| 114 | #
|
|---|
| 115 | #
|
|---|
| 116 | sub render_swf {
|
|---|
| 117 | my ($self, $props) = @_;
|
|---|
| 118 | #my ($self, $width, $height, $data) = @_;
|
|---|
| 119 |
|
|---|
| 120 | $props->{'height'} = '300px' if !defined($props->{'height'});
|
|---|
| 121 | $props->{'width'} = '400px' if !defined($props->{'width'});
|
|---|
| 122 | $props->{'data'} = '' if !defined($props->{'data'});
|
|---|
| 123 | $props->{'class'} = 'ofc-chart' if !defined($props->{'class'});
|
|---|
| 124 |
|
|---|
| 125 | my $open_flash_chart_seqno = $self->{'open_flash_chart_seqno'};
|
|---|
| 126 |
|
|---|
| 127 | my $html = '';
|
|---|
| 128 | if ( $self->{'data_load_type'} eq 'inline_js' ) {
|
|---|
| 129 | my $data = $self->render_chart_data();
|
|---|
| 130 | if ($BOOTSTRAP_COMPLETED == 0 ) {
|
|---|
| 131 | $html .= '<script type="text/javascript" src="jquery-1.2.6.min.js" ></script>';
|
|---|
| 132 | $html .= '<script type="text/javascript" src="json/json2.js"></script>';
|
|---|
| 133 | $html .= '<script type="text/javascript" src="swfobject.js"></script>';
|
|---|
| 134 | $html .= qq^
|
|---|
| 135 | <script type="text/javascript">
|
|---|
| 136 | OFC = {};
|
|---|
| 137 | OFC.jquery = {
|
|---|
| 138 | name: "jQuery",
|
|---|
| 139 | version: function(src) { return \$('#'+ src)[0].get_version() },
|
|---|
| 140 | rasterize: function (src, dst) { \$('#'+ dst).replaceWith(OFC.jquery.image(src)) },
|
|---|
| 141 | image: function(src) { return "<img src='data:image/png;base64," + \$('#'+src)[0].get_img_binary() + "' />"},
|
|---|
| 142 | popup: function(src) {
|
|---|
| 143 | var img_win = window.open('', 'Charts: Export as Image')
|
|---|
| 144 | with(img_win.document) {
|
|---|
| 145 | write('<html><head><title>Charts: Export as Image<\/title><\/head><body>' + OFC.jquery.image(src) + '<\/body><\/html>') }
|
|---|
| 146 | close();
|
|---|
| 147 | }
|
|---|
| 148 | }
|
|---|
| 149 | // Using an object as namespaces is JS Best Practice. I like the Control.XXX style.
|
|---|
| 150 | //if (!Control) {var Control = {}}
|
|---|
| 151 | //if (typeof(Control == "undefined")) {var Control = {}}
|
|---|
| 152 | if (typeof(Control == "undefined")) {var Control = {OFC: OFC.jquery}}
|
|---|
| 153 |
|
|---|
| 154 |
|
|---|
| 155 | // By default, right-clicking on OFC and choosing "save image locally" calls this function.
|
|---|
| 156 | // You are free to change the code in OFC and call my wrapper (Control.OFC.your_favorite_save_method)
|
|---|
| 157 | // function save_image() { alert(1); Control.OFC.popup('my_chart') }
|
|---|
| 158 | function save_image() { OFC.jquery.popup('ofc_div_1') }
|
|---|
| 159 | function moo() { alert(99); };
|
|---|
| 160 | </script>
|
|---|
| 161 | ^;
|
|---|
| 162 | $BOOTSTRAP_COMPLETED = 1;
|
|---|
| 163 | }
|
|---|
| 164 | $html .= qq^
|
|---|
| 165 | <script type="text/javascript">
|
|---|
| 166 | swfobject.embedSWF("open-flash-chart.swf", "ofc_div_$open_flash_chart_seqno", "$props->{'width'}", "$props->{'height'}", "9.0.0", "expressInstall.swf", {"get-data":"get_data_$open_flash_chart_seqno","loading":"loading..."} );
|
|---|
| 167 | function get_data_$open_flash_chart_seqno() {
|
|---|
| 168 | return JSON.stringify(data_$open_flash_chart_seqno);
|
|---|
| 169 | }
|
|---|
| 170 | var data_$open_flash_chart_seqno = $data;
|
|---|
| 171 | </script>
|
|---|
| 172 | <div id="ofc_div_$open_flash_chart_seqno" class="$props->{'class'}"></div>
|
|---|
| 173 | ^;
|
|---|
| 174 | } else {
|
|---|
| 175 | $html .= qq^
|
|---|
| 176 | <object
|
|---|
| 177 | classid="clsid:d27cdb6e-ae6d-11cf-96b8-444553540000"
|
|---|
| 178 | codebase="http://fpdownload.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=8,0,0,0"
|
|---|
| 179 | width="$props->{'width'}"
|
|---|
| 180 | height="$props->{'height'}"
|
|---|
| 181 | id="ofc_div_$open_flash_chart_seqno"
|
|---|
| 182 | align="middle">
|
|---|
| 183 | <param name="allowScriptAccess" value="sameDomain" />
|
|---|
| 184 | <param name="movie" value="open-flash-chart.swf?width=$props->{'width'}&height=$props->{'height'}&data=$props->{'data'}"/>
|
|---|
| 185 | <param name="quality" value="high" />
|
|---|
| 186 | <param name="bgcolor" value="#FFFFFF" />
|
|---|
| 187 | <embed
|
|---|
| 188 | src="open-flash-chart.swf?width=$props->{'width'}&height=$props->{'height'}&data=$props->{'data'}"
|
|---|
| 189 | quality="high"
|
|---|
| 190 | bgcolor="#FFFFFF"
|
|---|
| 191 | width="$props->{'width'}"
|
|---|
| 192 | height="$props->{'height'}"
|
|---|
| 193 | name="open-flash-chart"
|
|---|
| 194 | align="middle"
|
|---|
| 195 | allowScriptAccess="sameDomain"
|
|---|
| 196 | type="application/x-shockwave-flash"
|
|---|
| 197 | pluginspage="http://www.macromedia.com/go/getflashplayer"
|
|---|
| 198 | />
|
|---|
| 199 | </object>
|
|---|
| 200 | ^;
|
|---|
| 201 | }
|
|---|
| 202 |
|
|---|
| 203 | return $html;
|
|---|
| 204 | }
|
|---|
| 205 |
|
|---|
| 206 |
|
|---|
| 207 |
|
|---|
| 208 |
|
|---|
| 209 |
|
|---|
| 210 |
|
|---|
| 211 |
|
|---|
| 212 |
|
|---|
| 213 |
|
|---|
| 214 |
|
|---|
| 215 |
|
|---|
| 216 |
|
|---|
| 217 | #Not Yet Supported
|
|---|
| 218 | #"hbar",
|
|---|
| 219 |
|
|---|
| 220 |
|
|---|
| 221 |
|
|---|
| 222 | #############################
|
|---|
| 223 | sub _____ELEMENT_OBJECTS_____(){}
|
|---|
| 224 | #############################
|
|---|
| 225 | package element;
|
|---|
| 226 | use Carp qw(cluck);
|
|---|
| 227 |
|
|---|
| 228 | our $AUTOLOAD;
|
|---|
| 229 | sub new() {
|
|---|
| 230 | my ($proto) = @_;
|
|---|
| 231 | my $class = ref($proto) || $proto;
|
|---|
| 232 | my $self = {};
|
|---|
| 233 |
|
|---|
| 234 | $self->{'min_value'} = undef;
|
|---|
| 235 | $self->{'max_value'} = undef;
|
|---|
| 236 |
|
|---|
| 237 | $self->{'element_props'} = {
|
|---|
| 238 | 'type' => '',
|
|---|
| 239 | 'values' => [1.5,1.69,1.88,2.06,2.21],
|
|---|
| 240 | };
|
|---|
| 241 | return bless $self, $class;
|
|---|
| 242 | }
|
|---|
| 243 |
|
|---|
| 244 | sub set_values {
|
|---|
| 245 | my ($self, $values_arg, $min, $max) = @_;
|
|---|
| 246 |
|
|---|
| 247 | $self->{'element_props'}->{'values'} = $values_arg if defined($values_arg);
|
|---|
| 248 | $self->set_min_max($min, $max);
|
|---|
| 249 | }
|
|---|
| 250 |
|
|---|
| 251 | sub set_min_max {
|
|---|
| 252 | my ($self, $min, $max) = @_;
|
|---|
| 253 |
|
|---|
| 254 | $self->{'max_value'} = $max if defined($max);
|
|---|
| 255 | $self->{'min_value'} = $min if defined($min);
|
|---|
| 256 |
|
|---|
| 257 | for ( @{$self->{'element_props'}->{'values'}} ) {
|
|---|
| 258 | if ( ref($_) eq 'HASH' || ref($_) eq 'ARRAY' ) {
|
|---|
| 259 | #multi value/axis chart
|
|---|
| 260 | return undef;
|
|---|
| 261 | }
|
|---|
| 262 |
|
|---|
| 263 | #standard single value chart, could be y, y-right, etc.
|
|---|
| 264 | if ( !defined($max) ) {
|
|---|
| 265 | $self->{'max_value'} = $_ if ( !defined($self->{'max_value'}) || $_ > $self->{'max_value'} );
|
|---|
| 266 | }
|
|---|
| 267 | if ( !defined($min) ) {
|
|---|
| 268 | $self->{'min_value'} = $_ if ( !defined($self->{'min_value'}) || $_ < $self->{'min_value'} ); }
|
|---|
| 269 | }
|
|---|
| 270 |
|
|---|
| 271 | return 1;
|
|---|
| 272 | }
|
|---|
| 273 |
|
|---|
| 274 | sub to_json() {
|
|---|
| 275 | my ($self) = @_;
|
|---|
| 276 | my $json = main::to_json($self->{'element_props'});
|
|---|
| 277 | $json =~ s/,$//g;
|
|---|
| 278 | return '{' . $json . '}';
|
|---|
| 279 | }
|
|---|
| 280 | sub AUTOLOAD {
|
|---|
| 281 | my $self = shift;
|
|---|
| 282 | my $type = ref($self) or warn "$self is not an object";
|
|---|
| 283 |
|
|---|
| 284 | my $name = $AUTOLOAD;
|
|---|
| 285 | $name =~ s/.*://; # strip fully-qualified portion
|
|---|
| 286 |
|
|---|
| 287 | if ( $name eq 'values' ) {
|
|---|
| 288 | $self->{'element_props'}->{'values'} = [];
|
|---|
| 289 | cluck "You need to call set_values() instead of plain values().";
|
|---|
| 290 | return undef;
|
|---|
| 291 | }
|
|---|
| 292 |
|
|---|
| 293 | $name =~ s/^set_//; # strip set_
|
|---|
| 294 | $name =~ s/^get_//; # strip get_
|
|---|
| 295 | $name =~ s/_/-/gi;
|
|---|
| 296 |
|
|---|
| 297 | unless (exists $self->{'element_props'}->{$name} ) {
|
|---|
| 298 | cluck "'$name' is not a valid property in class $type";
|
|---|
| 299 | return undef;
|
|---|
| 300 | }
|
|---|
| 301 |
|
|---|
| 302 | if (@_) {
|
|---|
| 303 | return $self->{'element_props'}->{"$name"} = shift;
|
|---|
| 304 | } else {
|
|---|
| 305 | return $self->{'element_props'}->{"$name"};
|
|---|
| 306 | }
|
|---|
| 307 | }
|
|---|
| 308 | sub DESTROY { }
|
|---|
| 309 |
|
|---|
| 310 |
|
|---|
| 311 | package bar_and_line_base;
|
|---|
| 312 | our @ISA = qw(element);
|
|---|
| 313 | sub new() {
|
|---|
| 314 | my ($proto) = @_;
|
|---|
| 315 | my $class = ref($proto) || $proto;
|
|---|
| 316 | my $self = {};
|
|---|
| 317 | bless $self, $class;
|
|---|
| 318 | $self = $self->SUPER::new();
|
|---|
| 319 | $self->{'element_props'}->{'colour'} = main::random_color();
|
|---|
| 320 | $self->{'element_props'}->{'text'} = 'text';
|
|---|
| 321 | $self->{'element_props'}->{'font-size'} = 10;
|
|---|
| 322 | $self->{'element_props'}->{'axis'} = undef;
|
|---|
| 323 |
|
|---|
| 324 | return $self;
|
|---|
| 325 | }
|
|---|
| 326 |
|
|---|
| 327 |
|
|---|
| 328 |
|
|---|
| 329 |
|
|---|
| 330 |
|
|---|
| 331 | #
|
|---|
| 332 | #
|
|---|
| 333 | # LINE TYPES
|
|---|
| 334 | #
|
|---|
| 335 | #
|
|---|
| 336 | package line;
|
|---|
| 337 | our @ISA = qw(bar_and_line_base);
|
|---|
| 338 | sub new() {
|
|---|
| 339 | my ($proto) = @_;
|
|---|
| 340 | my $class = ref($proto) || $proto;
|
|---|
| 341 | my $self = {};
|
|---|
| 342 | bless $self, $class;
|
|---|
| 343 | $self = $self->SUPER::new();
|
|---|
| 344 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 345 | $self->{'element_props'}->{'width'} = 2;
|
|---|
| 346 | $self->{'element_props'}->{'dot-style'} = {}; #{'type'=>'solid-dot', 'colour'=>'#a44a80', 'dot-size'=>6, 'tip'=>'#val#<br>#x_label#'};
|
|---|
| 347 | return $self;
|
|---|
| 348 | }
|
|---|
| 349 |
|
|---|
| 350 | package area;
|
|---|
| 351 | our @ISA = qw(bar_and_line_base);
|
|---|
| 352 | sub new() {
|
|---|
| 353 | my ($proto) = @_;
|
|---|
| 354 | my $class = ref($proto) || $proto;
|
|---|
| 355 | my $self = {};
|
|---|
| 356 | bless $self, $class;
|
|---|
| 357 | $self = $self->SUPER::new();
|
|---|
| 358 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 359 | $self->{'element_props'}->{'width'} = 2;
|
|---|
| 360 | $self->{'element_props'}->{'fill'} = '';
|
|---|
| 361 | $self->{'element_props'}->{'text'} = '';
|
|---|
| 362 | $self->{'element_props'}->{'dot-style'} = {};
|
|---|
| 363 | $self->{'element_props'}->{'halo-size'} = 2;
|
|---|
| 364 | $self->{'element_props'}->{'fill-alpha'} = 0.6;
|
|---|
| 365 | return $self;
|
|---|
| 366 | }
|
|---|
| 367 |
|
|---|
| 368 |
|
|---|
| 369 | #
|
|---|
| 370 | #
|
|---|
| 371 | # BAR TYPES
|
|---|
| 372 | #
|
|---|
| 373 | #
|
|---|
| 374 | package bar;
|
|---|
| 375 | our @ISA = qw(bar_and_line_base);
|
|---|
| 376 | sub new() {
|
|---|
| 377 | my ($proto) = @_;
|
|---|
| 378 | my $class = ref($proto) || $proto;
|
|---|
| 379 | my $self = {};
|
|---|
| 380 | bless $self, $class;
|
|---|
| 381 | $self = $self->SUPER::new();
|
|---|
| 382 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 383 | $self->{'element_props'}->{'alpha'} = 0.5;
|
|---|
| 384 | return $self;
|
|---|
| 385 | }
|
|---|
| 386 |
|
|---|
| 387 | package bar_3d;
|
|---|
| 388 | our @ISA = qw(bar);
|
|---|
| 389 | sub new() {
|
|---|
| 390 | my ($proto) = @_;
|
|---|
| 391 | my $class = ref($proto) || $proto;
|
|---|
| 392 | my $self = {};
|
|---|
| 393 | bless $self, $class;
|
|---|
| 394 | $self = $self->SUPER::new();
|
|---|
| 395 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 396 | return $self;
|
|---|
| 397 | }
|
|---|
| 398 |
|
|---|
| 399 | package bar_fade;
|
|---|
| 400 | our @ISA = qw(bar);
|
|---|
| 401 | sub new() {
|
|---|
| 402 | my ($proto) = @_;
|
|---|
| 403 | my $class = ref($proto) || $proto;
|
|---|
| 404 | my $self = {};
|
|---|
| 405 | bless $self, $class;
|
|---|
| 406 | $self = $self->SUPER::new();
|
|---|
| 407 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 408 | return $self;
|
|---|
| 409 | }
|
|---|
| 410 |
|
|---|
| 411 | package bar_glass;
|
|---|
| 412 | our @ISA = qw(bar);
|
|---|
| 413 | sub new() {
|
|---|
| 414 | my ($proto) = @_;
|
|---|
| 415 | my $class = ref($proto) || $proto;
|
|---|
| 416 | my $self = {};
|
|---|
| 417 | bless $self, $class;
|
|---|
| 418 | $self = $self->SUPER::new();
|
|---|
| 419 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 420 | return $self;
|
|---|
| 421 | }
|
|---|
| 422 |
|
|---|
| 423 | package bar_sketch;
|
|---|
| 424 | our @ISA = qw(bar);
|
|---|
| 425 | sub new() {
|
|---|
| 426 | my ($proto) = @_;
|
|---|
| 427 | my $class = ref($proto) || $proto;
|
|---|
| 428 | my $self = {};
|
|---|
| 429 | bless $self, $class;
|
|---|
| 430 | $self = $self->SUPER::new();
|
|---|
| 431 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 432 | return $self;
|
|---|
| 433 | }
|
|---|
| 434 |
|
|---|
| 435 | package bar_filled;
|
|---|
| 436 | our @ISA = qw(bar);
|
|---|
| 437 | sub new() {
|
|---|
| 438 | my ($proto) = @_;
|
|---|
| 439 | my $class = ref($proto) || $proto;
|
|---|
| 440 | my $self = {};
|
|---|
| 441 | bless $self, $class;
|
|---|
| 442 | $self = $self->SUPER::new();
|
|---|
| 443 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 444 | $self->{'element_props'}->{'outline-colour'} = main::random_color();
|
|---|
| 445 | return $self;
|
|---|
| 446 | }
|
|---|
| 447 |
|
|---|
| 448 | package bar_stack;
|
|---|
| 449 | our @ISA = qw(bar);
|
|---|
| 450 | sub new() {
|
|---|
| 451 | my ($proto) = @_;
|
|---|
| 452 | my $class = ref($proto) || $proto;
|
|---|
| 453 | my $self = {};
|
|---|
| 454 | bless $self, $class;
|
|---|
| 455 | $self = $self->SUPER::new();
|
|---|
| 456 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 457 | $self->{'element_props'}->{'text'} = __PACKAGE__ . ' ' . $self->{'element_props'}->{'text'};
|
|---|
| 458 | $self->{'element_props'}->{'values'} = [
|
|---|
| 459 | [{"val"=>1},{"val"=>3}],
|
|---|
| 460 | [{"val"=>1},{"val"=>1},{"val"=>2.5}],
|
|---|
| 461 | [{"val"=>5},{"val"=>5},{"val"=>2},{"val"=>2},{"val"=>2,"colour"=>main::random_color()},{"val"=>2},{"val"=>2}]
|
|---|
| 462 | ];
|
|---|
| 463 |
|
|---|
| 464 | return $self;
|
|---|
| 465 | }
|
|---|
| 466 |
|
|---|
| 467 | #stackbar must override set_min_max() because of nested value list
|
|---|
| 468 | sub set_min_max {
|
|---|
| 469 | my ($self, $min, $max) = @_;
|
|---|
| 470 |
|
|---|
| 471 | my $max_bar_val;
|
|---|
| 472 | for my $v ( @{$self->{'element_props'}->{'values'}} ) {
|
|---|
| 473 | #each bar
|
|---|
| 474 | my $this_bar_val;
|
|---|
| 475 | if ( ref($v) eq 'ARRAY' ) {
|
|---|
| 476 | #multi value/axis chart
|
|---|
| 477 | for ( @$v ) {
|
|---|
| 478 | #each bar piece
|
|---|
| 479 | next if !defined($_->{'val'});
|
|---|
| 480 |
|
|---|
| 481 | if ( !defined($this_bar_val) ) {
|
|---|
| 482 | $this_bar_val = $_->{'val'};
|
|---|
| 483 | } else {
|
|---|
| 484 | $this_bar_val += $_->{'val'};
|
|---|
| 485 | }
|
|---|
| 486 | }
|
|---|
| 487 | }
|
|---|
| 488 | $max_bar_val = $this_bar_val if ( !defined($max_bar_val) || $max_bar_val < $this_bar_val );
|
|---|
| 489 | }
|
|---|
| 490 |
|
|---|
| 491 | $self->{'max_value'} = $max if defined($max);
|
|---|
| 492 | $self->{'min_value'} = $min if defined($min);
|
|---|
| 493 | if ( !defined($max) ) {
|
|---|
| 494 | $self->{'max_value'} = $max_bar_val;
|
|---|
| 495 | }
|
|---|
| 496 | if ( !defined($min) ) {
|
|---|
| 497 | $self->{'min_value'} = 0;
|
|---|
| 498 | }
|
|---|
| 499 |
|
|---|
| 500 | return 1;
|
|---|
| 501 | }
|
|---|
| 502 |
|
|---|
| 503 |
|
|---|
| 504 | package pie;
|
|---|
| 505 | our @ISA = qw(element);
|
|---|
| 506 | sub new() {
|
|---|
| 507 | my ($proto) = @_;
|
|---|
| 508 | my $class = ref($proto) || $proto;
|
|---|
| 509 | my $self = {};
|
|---|
| 510 | bless $self, $class;
|
|---|
| 511 | $self = $self->SUPER::new();
|
|---|
| 512 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 513 | $self->{'element_props'}->{'alpha'} = 0.5;
|
|---|
| 514 | $self->{'element_props'}->{'colours'} = [main::random_color(), main::random_color(), main::random_color(), main::random_color(), main::random_color()];
|
|---|
| 515 | $self->{'element_props'}->{'border'} = 2;
|
|---|
| 516 | $self->{'element_props'}->{'animate'} = 1;
|
|---|
| 517 | $self->{'element_props'}->{'start-angle'} = 0;
|
|---|
| 518 | $self->{'element_props'}->{'radius'} = 200;
|
|---|
| 519 | $self->{'element_props'}->{'tip'} = '#val#';
|
|---|
| 520 | $self->{'element_props'}->{'label-colour'} = '#000';
|
|---|
| 521 | $self->{'element_props'}->{'values'} = [ {'value'=>rand(255), 'label'=>'linux'}, {'value'=>rand(255), 'label'=>'windows'}, {'value'=>rand(255), 'label'=>'vax'}, {'value'=>rand(255), 'label'=>'NexT'}, {'value'=>rand(255), 'label'=>'solaris'}];
|
|---|
| 522 |
|
|---|
| 523 | return $self;
|
|---|
| 524 | }
|
|---|
| 525 | sub set_pie_values() {
|
|---|
| 526 | my ($self, $values, $labels, $links ) = @_;
|
|---|
| 527 |
|
|---|
| 528 | $self->{'element_props'}->{'values'} = [];
|
|---|
| 529 |
|
|---|
| 530 | my @l_values = @$values if defined($values) || ();
|
|---|
| 531 | my @l_labels = @$labels if defined($labels) || ();
|
|---|
| 532 | my @l_links = @$links if defined($links) || ();
|
|---|
| 533 |
|
|---|
| 534 | while ( @l_labels < @l_values ) {
|
|---|
| 535 | push(@l_labels, '');
|
|---|
| 536 | }
|
|---|
| 537 | while ( @l_links < @l_values ) {
|
|---|
| 538 | push(@l_links, '');
|
|---|
| 539 | }
|
|---|
| 540 |
|
|---|
| 541 | my $total=0;
|
|---|
| 542 | for my $v ( @l_values ) {
|
|---|
| 543 | $total=$total + $v;
|
|---|
| 544 | }
|
|---|
| 545 | if ( $total == 0 ) {
|
|---|
| 546 | return undef;
|
|---|
| 547 | }
|
|---|
| 548 |
|
|---|
| 549 | my $pie_total = 0;
|
|---|
| 550 | my $biggest_pie_slice = 0;
|
|---|
| 551 | my $too_small_value = 0;
|
|---|
| 552 | my $too_small_label = '';
|
|---|
| 553 | for ( my $i=0; $i < @l_values; $i++) {
|
|---|
| 554 | $l_values[$i] = sprintf("%.1f", ($l_values[$i] / $total) * 100.0);
|
|---|
| 555 | # you can't have a zero pie slice
|
|---|
| 556 | if ( $l_values[$i] == 0.0 ) {
|
|---|
| 557 | splice(@l_values, $i, 1);
|
|---|
| 558 | splice(@l_labels, $i, 1);
|
|---|
| 559 | splice(@l_links, $i, 1);
|
|---|
| 560 | $i--;
|
|---|
| 561 | next;
|
|---|
| 562 | } elsif ($l_values[$i] < 3.0) {
|
|---|
| 563 | $pie_total += $l_values[$i];
|
|---|
| 564 | $too_small_value = $too_small_value + $l_values[$i];
|
|---|
| 565 | $too_small_label = $l_labels[$i] . '/' . $too_small_label;
|
|---|
| 566 | splice(@l_values, $i, 1);
|
|---|
| 567 | splice(@l_labels, $i, 1);
|
|---|
| 568 | splice(@l_links, $i, 1);
|
|---|
| 569 | $i--;
|
|---|
| 570 | next;
|
|---|
| 571 | }
|
|---|
| 572 |
|
|---|
| 573 | $pie_total += $l_values[$i];
|
|---|
| 574 | if ( $l_values[$i] > $l_values[$biggest_pie_slice] ) {
|
|---|
| 575 | $biggest_pie_slice = $i;
|
|---|
| 576 | }
|
|---|
| 577 | }
|
|---|
| 578 |
|
|---|
| 579 | #adjust for rounding errors, and fill to 100% on biggest pie slice
|
|---|
| 580 | $l_values[$biggest_pie_slice] += (100.0 - $pie_total);
|
|---|
| 581 |
|
|---|
| 582 | #get rid of the tailing / from the too small label
|
|---|
| 583 | $too_small_label =~ s/\/$//;
|
|---|
| 584 | if (length($too_small_label) > 20 ) {
|
|---|
| 585 | $too_small_label = substr($too_small_label,0,25) . "...";
|
|---|
| 586 | }
|
|---|
| 587 |
|
|---|
| 588 | if ( $too_small_value > 0 ) {
|
|---|
| 589 | push(@l_values, $too_small_value);
|
|---|
| 590 | $too_small_label =~ s/ $//;
|
|---|
| 591 | push(@l_labels, $too_small_label);
|
|---|
| 592 | push(@l_links,'');
|
|---|
| 593 | }
|
|---|
| 594 |
|
|---|
| 595 | #$self->{pie_values} = join(',',@l_values);
|
|---|
| 596 | #$self->{pie_labels} = join(',',@l_labels);
|
|---|
| 597 | #$self->{pie_links} = join(',',@l_links);
|
|---|
| 598 |
|
|---|
| 599 | for ( my $i=0; $i < @l_values; $i++ ) {
|
|---|
| 600 | # push( @$plist, {'value'=>$s->{'values'}->[$i], 'label'=>$self->{'x_ticks'}->[$i], 'font-size'=>12, } );
|
|---|
| 601 | push(@{$self->{'element_props'}->{'values'}}, {'value'=>$l_values[$i], 'label'=>$l_labels[$i]});
|
|---|
| 602 |
|
|---|
| 603 | }
|
|---|
| 604 | }
|
|---|
| 605 |
|
|---|
| 606 |
|
|---|
| 607 |
|
|---|
| 608 | package scatter;
|
|---|
| 609 | our @ISA = qw(element);
|
|---|
| 610 | sub new() {
|
|---|
| 611 | my ($proto) = @_;
|
|---|
| 612 | my $class = ref($proto) || $proto;
|
|---|
| 613 | my $self = {};
|
|---|
| 614 | bless $self, $class;
|
|---|
| 615 | $self = $self->SUPER::new();
|
|---|
| 616 | $self->{'element_props'}->{'type'} = __PACKAGE__;
|
|---|
| 617 | $self->{'element_props'}->{'values'} = [
|
|---|
| 618 | {"x"=>-5, "y"=>-5 },
|
|---|
| 619 | {"x"=>0, "y"=>0 },
|
|---|
| 620 | {"x"=>5, "y"=>5, "dot-size"=>20},
|
|---|
| 621 | {"x"=>5, "y"=>-5, "dot-size"=>5},
|
|---|
| 622 | {"x"=>-5, "y"=>5, "dot-size"=>5},
|
|---|
| 623 | {"x"=>0.5, "y"=>1, "dot-size"=>15}
|
|---|
| 624 | ];
|
|---|
| 625 | $self->{"element_props"}->{"dot-style"} = {"type"=>"solid-dot"};
|
|---|
| 626 |
|
|---|
| 627 | return $self;
|
|---|
| 628 | }
|
|---|
| 629 | sub set_min_max {
|
|---|
| 630 | my ($self, $min, $max) = @_;
|
|---|
| 631 |
|
|---|
| 632 | my $max_calc;
|
|---|
| 633 | my $min_calc;
|
|---|
| 634 | for ( @{$self->{'element_props'}->{'values'}} ) {
|
|---|
| 635 | $max_calc = $_->{'y'} if !defined($max_calc);
|
|---|
| 636 | if ( $_->{'y'} > $max_calc ) {
|
|---|
| 637 | $max_calc = $_->{'y'};
|
|---|
| 638 | }
|
|---|
| 639 | $min_calc = $_->{'y'} if !defined($min_calc);
|
|---|
| 640 | if ( $_->{'y'} < $min_calc ) {
|
|---|
| 641 | $min_calc = $_->{'y'};
|
|---|
| 642 | }
|
|---|
| 643 | }
|
|---|
| 644 |
|
|---|
| 645 | $self->{'max_value'} = $max if defined($max);
|
|---|
| 646 | $self->{'min_value'} = $min if defined($min);
|
|---|
| 647 | if ( !defined($max) ) {
|
|---|
| 648 | $self->{'max_value'} = $max_calc;
|
|---|
| 649 | }
|
|---|
| 650 | if ( !defined($min) ) {
|
|---|
| 651 | $self->{'min_value'} = $min_calc;
|
|---|
| 652 | }
|
|---|
| 653 |
|
|---|
| 654 | return 1;
|
|---|
| 655 |
|
|---|
| 656 |
|
|---|
| 657 | }
|
|---|
| 658 |
|
|---|
| 659 | #############################
|
|---|
| 660 | sub _____AXIS_OBJECT_____(){}
|
|---|
| 661 | #############################
|
|---|
| 662 | package axis;
|
|---|
| 663 | use Carp qw(cluck);
|
|---|
| 664 |
|
|---|
| 665 | our $AUTOLOAD;
|
|---|
| 666 | our $defaults = {
|
|---|
| 667 | 'labels' => undef,
|
|---|
| 668 | 'stroke' => undef,
|
|---|
| 669 | 'tick-length' => undef,
|
|---|
| 670 | 'colour' => undef,
|
|---|
| 671 | 'offset' => undef,
|
|---|
| 672 | 'grid-colour' => undef,
|
|---|
| 673 | '3d' => undef,
|
|---|
| 674 | 'steps' => undef,
|
|---|
| 675 | 'visible' => undef,
|
|---|
| 676 | 'min' => undef,
|
|---|
| 677 | 'max' => undef,
|
|---|
| 678 | };
|
|---|
| 679 |
|
|---|
| 680 | sub new() {
|
|---|
| 681 | my ($proto, $name) = @_;
|
|---|
| 682 | my $class = ref($proto) || $proto;
|
|---|
| 683 | my $self = {};
|
|---|
| 684 | $self->{'name'} = $name; # x_axis | y_axis | y_axis_right
|
|---|
| 685 | $self->{'elements'} = [];
|
|---|
| 686 |
|
|---|
| 687 | #props are rendered into json
|
|---|
| 688 | %{$self->{'props'}} = %$defaults;
|
|---|
| 689 |
|
|---|
| 690 | return bless $self, $class;
|
|---|
| 691 | }
|
|---|
| 692 |
|
|---|
| 693 | sub add_element() {
|
|---|
| 694 | my ($self, $element) = @_;
|
|---|
| 695 |
|
|---|
| 696 | push(@{$self->{'elements'}}, $element);
|
|---|
| 697 | $self->set_min_max();
|
|---|
| 698 | }
|
|---|
| 699 |
|
|---|
| 700 | sub set_min_max {
|
|---|
| 701 | my ($self) = @_;
|
|---|
| 702 |
|
|---|
| 703 | for my $e ( @{$self->{'elements'}} ) {
|
|---|
| 704 | $self->{'props'}->{'max'} = $e->{'max_value'} if ( !defined($self->{'props'}->{'max'}) || $self->{'props'}->{'max'} < $e->{'max_value'} );
|
|---|
| 705 | $self->{'props'}->{'min'} = $e->{'min_value'} if ( !defined($self->{'props'}->{'min'}) || $self->{'props'}->{'min'} > $e->{'min_value'} );
|
|---|
| 706 | }
|
|---|
| 707 |
|
|---|
| 708 | $self->{'props'}->{'max'} = main::smooth_max($self->{'props'}->{'max'});
|
|---|
| 709 | $self->{'props'}->{'steps'} = $self->{'props'}->{'max'} / 10;
|
|---|
| 710 |
|
|---|
| 711 | return 1;
|
|---|
| 712 | }
|
|---|
| 713 |
|
|---|
| 714 | sub to_json() {
|
|---|
| 715 | my ($self) = @_;
|
|---|
| 716 | my $json = main::to_json($self->{'props'}, $self->{'name'}, __PACKAGE__);
|
|---|
| 717 | #$json =~ s/,$//g;
|
|---|
| 718 | return $json;
|
|---|
| 719 | }
|
|---|
| 720 | sub AUTOLOAD {
|
|---|
| 721 | my $self = shift;
|
|---|
| 722 | my $type = ref($self) or warn "$self is not an object";
|
|---|
| 723 |
|
|---|
| 724 | my $name = $AUTOLOAD;
|
|---|
| 725 | $name =~ s/.*://; # strip fully-qualified portion
|
|---|
| 726 | $name =~ s/^set_//; # strip set_
|
|---|
| 727 | $name =~ s/^get_//; # strip get_
|
|---|
| 728 |
|
|---|
| 729 | unless (exists $self->{'props'}->{$name} ) {
|
|---|
| 730 | cluck "'$name' is not a valid property in class $type";
|
|---|
| 731 | return undef;
|
|---|
| 732 | }
|
|---|
| 733 |
|
|---|
| 734 | if (@_) {
|
|---|
| 735 | return $self->{'props'}->{"$name"} = shift;
|
|---|
| 736 | } else {
|
|---|
| 737 | return $self->{'props'}->{"$name"};
|
|---|
| 738 | }
|
|---|
| 739 | }
|
|---|
| 740 | sub DESTROY { }
|
|---|
| 741 |
|
|---|
| 742 |
|
|---|
| 743 |
|
|---|
| 744 |
|
|---|
| 745 |
|
|---|
| 746 |
|
|---|
| 747 |
|
|---|
| 748 |
|
|---|
| 749 |
|
|---|
| 750 |
|
|---|
| 751 | #
|
|---|
| 752 | #
|
|---|
| 753 | # GENERAL HELPERS
|
|---|
| 754 | #
|
|---|
| 755 | #
|
|---|
| 756 | package main;
|
|---|
| 757 | sub to_json {
|
|---|
| 758 | my ($data_structure, $name) = @_;
|
|---|
| 759 |
|
|---|
| 760 | my $tmp='';
|
|---|
| 761 |
|
|---|
| 762 | if ( defined($name) && $name ne '' ) {
|
|---|
| 763 | $name =~ s/\"/\'/gi;
|
|---|
| 764 | $tmp.= "\n\"$name\" : ";
|
|---|
| 765 | }
|
|---|
| 766 |
|
|---|
| 767 | if ( ref $data_structure eq 'ARRAY' ) {
|
|---|
| 768 | $tmp.= "[";
|
|---|
| 769 | for (@$data_structure) {
|
|---|
| 770 | $tmp.= to_json($_,'');
|
|---|
| 771 | }
|
|---|
| 772 | $tmp =~ s/,$//g;
|
|---|
| 773 | $tmp.= "]";
|
|---|
| 774 | } elsif ( ref $data_structure eq 'HASH' ) {
|
|---|
| 775 | $tmp.= "{" if defined($name);
|
|---|
| 776 | for (keys %{$data_structure}) {
|
|---|
| 777 | if ( defined($data_structure->{$_}) ) {
|
|---|
| 778 | $tmp.= to_json($data_structure->{$_}, $_ || '');
|
|---|
| 779 | }
|
|---|
| 780 | }
|
|---|
| 781 | $tmp =~ s/,$//g;
|
|---|
| 782 | $tmp.= "}" if defined($name);
|
|---|
| 783 |
|
|---|
| 784 | } else {
|
|---|
| 785 |
|
|---|
| 786 | if ( !defined($data_structure) ) {
|
|---|
| 787 | return;
|
|---|
| 788 | }
|
|---|
| 789 |
|
|---|
| 790 | if ( $data_structure =~ /^-{0,1}[\d.]+$/ || $data_structure eq 'null') {
|
|---|
| 791 | #number
|
|---|
| 792 | $tmp.= $data_structure;
|
|---|
| 793 | } else {
|
|---|
| 794 | #not number
|
|---|
| 795 | $data_structure =~ s/\"/\'/gi;
|
|---|
| 796 | $tmp.= "\"$data_structure\"";
|
|---|
| 797 | }
|
|---|
| 798 | }
|
|---|
| 799 |
|
|---|
| 800 | return $tmp.',';
|
|---|
| 801 | }
|
|---|
| 802 |
|
|---|
| 803 | sub get_random_colors {
|
|---|
| 804 | my $how_many = shift;
|
|---|
| 805 | my $ret = [];
|
|---|
| 806 | for ( my $i = 0; $i < $how_many; $i++ ) {
|
|---|
| 807 | push(@$ret,random_color());
|
|---|
| 808 | }
|
|---|
| 809 | return $ret;
|
|---|
| 810 | }
|
|---|
| 811 |
|
|---|
| 812 | sub random_color {
|
|---|
| 813 | my @hex;
|
|---|
| 814 | for (my $i = 0; $i < 64; $i++) {
|
|---|
| 815 | my ($rand,$x);
|
|---|
| 816 | for ($x = 0; $x < 3; $x++) {
|
|---|
| 817 | $rand = rand(255);
|
|---|
| 818 | $hex[$x] = sprintf ("%x", $rand);
|
|---|
| 819 | if ($rand < 9) {
|
|---|
| 820 | $hex[$x] = "0" . $hex[$x];
|
|---|
| 821 | }
|
|---|
| 822 | if ($rand > 9 && $rand < 16) {
|
|---|
| 823 | $hex[$x] = "0" . $hex[$x];
|
|---|
| 824 | }
|
|---|
| 825 | }
|
|---|
| 826 | }
|
|---|
| 827 | return "\#" . $hex[0] . $hex[1] . $hex[2];
|
|---|
| 828 | }
|
|---|
| 829 |
|
|---|
| 830 | # URL-encode string
|
|---|
| 831 | sub url_escape {
|
|---|
| 832 | my($toencode) = @_;
|
|---|
| 833 | $toencode=~s/([^a-zA-Z0-9_\-. ])/uc sprintf("%%%02x",ord($1))/eg;
|
|---|
| 834 | $toencode =~ tr/ /+/; # spaces become pluses
|
|---|
| 835 | return $toencode;
|
|---|
| 836 | }
|
|---|
| 837 |
|
|---|
| 838 |
|
|---|
| 839 | # round the number up a bit to a nice round number
|
|---|
| 840 | # also changes number to an int
|
|---|
| 841 | sub smoother {
|
|---|
| 842 | my $number = shift;
|
|---|
| 843 | my $min_max = shift;
|
|---|
| 844 | my $n = $number;
|
|---|
| 845 |
|
|---|
| 846 | #$n = $n + $n % 10;
|
|---|
| 847 | #return $n;
|
|---|
| 848 |
|
|---|
| 849 | if ( $min_max eq 'max' ) {
|
|---|
| 850 | $n = int($n + 0.99 * ($n <=> 0));
|
|---|
| 851 | } else {
|
|---|
| 852 | $n = int($n - 0.99 * ($n <=> 0));
|
|---|
| 853 | }
|
|---|
| 854 |
|
|---|
| 855 | if ( $n <= 1 ) { $n = 1 }
|
|---|
| 856 | elsif ( $n < 10 ) { $n = $n }
|
|---|
| 857 | elsif ( $n < 30 ) { $n = $n + (-$n % 5) }
|
|---|
| 858 | elsif ( $n < 100 ) { $n = $n + (-$n % 10) }
|
|---|
| 859 | elsif ( $n < 500 ) { $n = $n + (-$n % 50) }
|
|---|
| 860 | elsif ( $n < 1000 ) { $n = $n + (-$n % 100) }
|
|---|
| 861 | elsif ( $n < 10000 ) { $n = $n + (-$n % 200) }
|
|---|
| 862 | else { $n = $n + (-$n % 500) }
|
|---|
| 863 | return int($n);
|
|---|
| 864 | }
|
|---|
| 865 | sub smooth_max {
|
|---|
| 866 | my $number = shift;
|
|---|
| 867 | return smoother($number, 'max');
|
|---|
| 868 | }
|
|---|
| 869 | sub smooth_min {
|
|---|
| 870 | my $number = shift;
|
|---|
| 871 | return smoother($number, 'min');
|
|---|
| 872 | }
|
|---|
| 873 |
|
|---|
| 874 | 1;
|
|---|
