Annotation of loncom/xml/lonplot.pm, revision 1.18
1.1 matthew 1: # The LearningOnline Network with CAPA
2: # Dynamic plot
3: #
1.18 ! matthew 4: # $Id: lonplot.pm,v 1.17 2001/12/21 22:45:47 matthew Exp $
1.1 matthew 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.3 matthew 28: # 12/15/01 Matthew
1.14 matthew 29: # 12/17 12/18 12/19 12/20 12/21 Matthew
1.1 matthew 30: package Apache::lonplot;
1.10 matthew 31:
1.1 matthew 32: use strict;
1.10 matthew 33: use Apache::File;
1.1 matthew 34: use Apache::response;
1.2 matthew 35: use Apache::lonxml;
1.10 matthew 36:
1.12 matthew 37: use Digest::MD5 qw(md5_base64);
1.1 matthew 38:
39: sub BEGIN {
40: &Apache::lonxml::register('Apache::lonplot',('plot'));
41: }
42:
1.10 matthew 43: ##
44: ## Description of data structures:
45: ##
46: ## %plot %key %axis
47: ## --------------------------
48: ## height title color
49: ## width box xmin
50: ## bgcolor pos xmax
51: ## fgcolor ymin
52: ## transparent ymax
53: ## grid
54: ## border
55: ## font
56: ##
57: ## @labels: $labels[$i] = \%label
58: ## %label: text, xpos, ypos, justify
1.14 matthew 59: ##
1.10 matthew 60: ## @curves: $curves[$i] = \%curve
1.14 matthew 61: ## %curve: name, linestyle, ( function | data )
1.10 matthew 62: ##
63: ## $curves[$i]->{'data'} = [ [x1,x2,x3,x4],
64: ## [y1,y2,y3,y4] ]
65: ##
66: ##------------------------------------------------------------
1.1 matthew 67: ##
68: ## Tests used in checking the validitity of input
69: ##
1.11 matthew 70: my $int_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^\d+$/};
71: my $real_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^[+-]?\d*\.?\d*$/};
72: my $color_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^x[\da-f]{6}$/};
1.1 matthew 73: my $onoff_test = sub {$_[0]=~/^(on|off)$/};
1.15 matthew 74: my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below| )+$/};
1.1 matthew 75: my $sml_test = sub {$_[0]=~/^(small|medium|large)$/};
76: my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/};
1.15 matthew 77: my $words_test = sub {$_[0]=~s/\s+/ /g;$_[0]=~/^([\w\(\)]+ ?)+$/};
1.1 matthew 78: ##
79: ## Default values for attributes of elements
80: ##
81: my %plot_defaults =
82: (
1.10 matthew 83: height => {default => 200, test => $int_test },
84: width => {default => 200, test => $int_test },
85: bgcolor => {default => 'xffffff', test => $color_test },
86: fgcolor => {default => 'x000000', test => $color_test },
87: transparent => {default => 'off', test => $onoff_test },
88: grid => {default => 'off', test => $onoff_test },
89: border => {default => 'on', test => $onoff_test },
1.16 matthew 90: font => {default => 'medium', test => $sml_test },
91: align => {default => 'left', test => $words_test }
1.1 matthew 92: );
93:
94: my %key_defaults =
95: (
1.10 matthew 96: title => { default => '', test => $words_test },
97: box => { default => 'off', test => $onoff_test },
98: pos => { default => 'top right', test => $key_pos_test }
1.1 matthew 99: );
100:
101: my %label_defaults =
102: (
1.10 matthew 103: xpos => {default => 0, test => $real_test },
104: ypos => {default => 0, test => $real_test },
1.5 matthew 105: justify => {default => 'left',
1.10 matthew 106: test => sub {$_[0]=~/^(left|right|center)$/} }
1.1 matthew 107: );
108:
109: my %axis_defaults =
110: (
1.5 matthew 111: color => {default => 'x000000', test => $color_test},
1.11 matthew 112: xmin => {default => '-10.0', test => $real_test },
113: xmax => {default => ' 10.0', test => $real_test },
114: ymin => {default => '-10.0', test => $real_test },
1.15 matthew 115: ymax => {default => ' 10.0', test => $real_test },
116: linestyle => {default => 'points', test => $linestyle_test}
1.1 matthew 117: );
118:
119: my %curve_defaults =
120: (
1.13 matthew 121: color => {default => 'x000000', test => $color_test },
122: name => {default => '', test => $words_test },
123: linestyle => {default => 'lines', test => $linestyle_test }
1.1 matthew 124: );
125:
126: ##
127: ## End of defaults
128: ##
129: my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves);
130:
131: sub start_plot {
1.10 matthew 132: %plot = undef; %key = undef; %axis = undef;
133: $title = undef; $xlabel = undef; $ylabel = undef;
134: $#labels = -1; $#curves = -1;
1.6 matthew 135: #
1.1 matthew 136: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
137: my $result='';
1.4 matthew 138: if ($target eq 'web') {
1.17 matthew 139: &Apache::lonxml::register('Apache::lonplot',
140: ('title','xlabel','ylabel','key','axis','label','curve'));
141: push (@Apache::lonxml::namespace,'plot');
142: ## Always evaluate the insides of the <plot></plot> tags
143: my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]);
144: $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]);
145: &Apache::lonxml::newparser($parser,\$inside);
146: ##-------------------------------------------------------
147: &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,
148: $tagstack->[-1]);
1.4 matthew 149: }
1.1 matthew 150: return '';
151: }
152:
153: sub end_plot {
154: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
155: pop @Apache::lonxml::namespace;
1.4 matthew 156: &Apache::lonxml::deregister('Apache::lonplot',
157: ('title','xlabel','ylabel','key','axis','label','curve'));
158: my $result = '';
159: if ($target eq 'web') {
1.13 matthew 160: ##
161: ## Make sure we have all the input we need:
162: if (! defined(%plot )) { &set_defaults(\%plot,\%plot_defaults); }
1.14 matthew 163: if (! defined(%key )) {} # No key for this plot
1.13 matthew 164: if (! defined(%axis )) { &set_defaults(\%axis,\%axis_defaults); }
1.14 matthew 165: if (! defined($title )) {} # No title for this plot
166: if (! defined($xlabel)) {} # No xlabel for this plot
167: if (! defined($ylabel)) {} # No ylabel for this plot
1.13 matthew 168: if ($#labels < 0) { } # No labels for this plot
1.14 matthew 169: if ($#curves < 0) {
170: &Apache::lonxml::warning("No curves specified for plot!!!!");
171: return '';
172: }
173: my $curve;
174: foreach $curve (@curves) {
175: if (!defined($curve->{'function'})&&!defined($curve->{'data'})){
176: &Apache::lonxml::warning("One of the curves specified did not contain any <data> or <function> declarations\n");
177: return '';
178: }
179: }
1.13 matthew 180: ##
181: ## Determine filename
1.4 matthew 182: my $tmpdir = '/home/httpd/perl/tmp/';
1.12 matthew 183: my $filename = $ENV{'user.name'}.'_'.$ENV{'user.domain'}.
1.13 matthew 184: '_'.time.'_'.$$.'_plot.data';
1.4 matthew 185: ## Write the plot description to the file
1.12 matthew 186: my $fh=Apache::File->new(">$tmpdir$filename");
187: print $fh &write_gnuplot_file();
1.14 matthew 188: close($fh);
1.4 matthew 189: ## return image tag for the plot
1.12 matthew 190: $result .= <<"ENDIMAGE";
1.16 matthew 191: <img src = "/cgi-bin/plot.gif?$filename"
192: width = "$plot{'width'}"
193: height = "$plot{'height'}"
194: align = "$plot{'align'}"
195: alt = "/cgi-bin/plot.gif?$filename" />
1.12 matthew 196: ENDIMAGE
1.4 matthew 197: }
1.1 matthew 198: return $result;
199: }
1.2 matthew 200:
1.1 matthew 201: ##----------------------------------------------------------------- key
202: sub start_key {
203: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
204: my $result='';
1.17 matthew 205: if ($target eq 'web') {
206: &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,
1.11 matthew 207: $tagstack->[-1]);
1.4 matthew 208: # This routine should never return anything.
209: }
1.1 matthew 210: return $result;
211: }
212:
213: sub end_key {
214: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
215: my $result = '';
1.4 matthew 216: if ($target eq 'web') {
217: # This routine should never return anything.
218: }
1.1 matthew 219: return $result;
220: }
221: ##------------------------------------------------------------------- title
222: sub start_title {
223: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
224: my $result='';
1.4 matthew 225: if ($target eq 'web') {
1.17 matthew 226: $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
1.4 matthew 227: # This routine should never return anything.
228: }
1.1 matthew 229: return $result;
230: }
231:
232: sub end_title {
233: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
234: my $result = '';
1.4 matthew 235: if ($target eq 'web') {
236: # This routine should never return anything.
237: }
1.1 matthew 238: return $result;
239: }
240: ##------------------------------------------------------------------- xlabel
241: sub start_xlabel {
242: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
243: my $result='';
1.4 matthew 244: if ($target eq 'web') {
1.17 matthew 245: $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
1.4 matthew 246: # This routine should never return anything.
247: }
1.1 matthew 248: return $result;
249: }
250:
251: sub end_xlabel {
252: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
253: my $result = '';
1.4 matthew 254: if ($target eq 'web') {
255: # This routine should never return anything.
256: }
1.1 matthew 257: return $result;
258: }
259: ##------------------------------------------------------------------- ylabel
260: sub start_ylabel {
261: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
262: my $result='';
1.4 matthew 263: if ($target eq 'web') {
1.17 matthew 264: $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
1.4 matthew 265: # This routine should never return anything.
266: }
1.1 matthew 267: return $result;
268: }
269:
270: sub end_ylabel {
271: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
272: my $result = '';
1.4 matthew 273: if ($target eq 'web') {
274: # This routine should never return anything.
275: }
1.1 matthew 276: return $result;
277: }
278: ##------------------------------------------------------------------- label
279: sub start_label {
280: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
281: my $result='';
1.17 matthew 282: if ($target eq 'web') {
283: my %label;
284: &get_attributes(\%label,\%label_defaults,$parstack,$safeeval,
1.11 matthew 285: $tagstack->[-1]);
1.17 matthew 286: $label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
287: if (! &$words_test($label{'text'})) {
288: # I should probably warn about it, too.
289: $label{'text'} = 'Illegal text';
290: }
291: push(@labels,\%label);
1.4 matthew 292: }
1.17 matthew 293: # This routine should never return anything.
1.1 matthew 294: return $result;
295: }
296:
297: sub end_label {
298: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
299: my $result = '';
1.4 matthew 300: if ($target eq 'web') {
301: # This routine should never return anything.
302: }
1.1 matthew 303: return $result;
304: }
305:
306: ##------------------------------------------------------------------- curve
307: sub start_curve {
308: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
309: my $result='';
1.17 matthew 310: if ($target eq 'web') {
311: my %curve;
312: &get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval,
1.11 matthew 313: $tagstack->[-1]);
1.17 matthew 314: push (@curves,\%curve);
315: &Apache::lonxml::register('Apache::lonplot',('function','data'));
316: push (@Apache::lonxml::namespace,'curve');
1.4 matthew 317: # This routine should never return anything.
318: }
1.1 matthew 319: return $result;
320: }
321:
322: sub end_curve {
323: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
324: my $result = '';
1.4 matthew 325: if ($target eq 'web') {
1.17 matthew 326: pop @Apache::lonxml::namespace;
327: &Apache::lonxml::deregister('Apache::lonplot',('function','data'));
1.4 matthew 328: # This routine should never return anything.
329: }
1.1 matthew 330: return $result;
331: }
332: ##------------------------------------------------------------ curve function
333: sub start_function {
334: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
335: my $result='';
1.4 matthew 336: if ($target eq 'web') {
1.17 matthew 337: if (exists($curves[-1]->{'data'})) {
338: &Apache::lonxml::warning('Use of <function> precludes use of <data>. The <data> will be omitted in favor of the <function> declaration.');
339: delete $curves[-1]->{'data'} ;
340: }
341: $curves[-1]->{'function'} =
342: &Apache::lonxml::get_all_text("/function",$$parser[-1]);
1.4 matthew 343: # This routine should never return anything.
344: }
1.1 matthew 345: return $result;
346: }
347:
348: sub end_function {
349: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
350: my $result = '';
1.4 matthew 351: if ($target eq 'web') {
352: # This routine should never return anything.
353: }
1.1 matthew 354: return $result;
355: }
356: ##------------------------------------------------------------ curve data
357: sub start_data {
358: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
359: my $result='';
1.4 matthew 360: if ($target eq 'web') {
1.17 matthew 361: if (exists($curves[-1]->{'function'})) {
362: &Apache::lonxml::warning('Use of <data> precludes use of .'.
363: '<function>. The <function> will be omitted in favor of '.
364: 'the <data> declaration.');
365: delete($curves[-1]->{'function'});
366: }
367: my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]);
368: &Apache::lonxml::warning(
1.18 ! matthew 369: ' Length of data string: '.length($datatext));
1.17 matthew 370: $datatext =~ s/\s+/ /g;
371: # Need to do some error checking on the @data array -
372: # make sure it's all numbers and make sure each array
373: # is of the same length.
374: my @data;
375: if ($datatext =~ /,/) {
376: @data = split /,/,$datatext;
377: } else { # Assume it's space seperated.
378: @data = split / /,$datatext;
379: }
380: &Apache::lonxml::warning(' Data Points: '.$#data);
381: for (my $i=0;$i<=$#data;$i++) {
382: # Check that it's non-empty
383: # Check that it's a number
384: # Maybe I need a 'debug=on' switch to list the data set
385: # out in a warning?
386: }
387: push @{$curves[-1]->{'data'}},\@data;
1.4 matthew 388: # This routine should never return anything.
389: }
1.1 matthew 390: return $result;
391: }
392:
393: sub end_data {
394: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
395: my $result = '';
1.4 matthew 396: if ($target eq 'web') {
397: # This routine should never return anything.
398: }
1.1 matthew 399: return $result;
400: }
401:
402: ##------------------------------------------------------------------- axis
403: sub start_axis {
404: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
405: my $result='';
1.4 matthew 406: if ($target eq 'web') {
1.17 matthew 407: &get_attributes(\%axis,\%axis_defaults,$parstack,$safeeval,
408: $tagstack->[-1]);
1.4 matthew 409: # This routine should never return anything.
410: }
1.1 matthew 411: return $result;
412: }
413:
414: sub end_axis {
415: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
416: my $result = '';
1.4 matthew 417: if ($target eq 'web') {
418: # This routine should never return anything.
419: }
1.1 matthew 420: return $result;
421: }
422:
1.13 matthew 423: ##----------------------------------------------------------- set_defaults
424: sub set_defaults {
425: my $var = shift;
426: my $defaults = shift;
427: my $key;
428: foreach $key (keys %$defaults) {
429: $var->{$key} = $defaults->{$key}->{'default'};
430: }
431: }
432:
1.1 matthew 433: ##------------------------------------------------------------------- misc
1.2 matthew 434: sub get_attributes{
1.10 matthew 435: my $values = shift;
436: my $defaults = shift;
437: my $parstack = shift;
438: my $safeeval = shift;
439: my $tag = shift;
1.2 matthew 440: my $attr;
1.10 matthew 441: foreach $attr (keys %{$defaults}) {
442: $values->{$attr} =
1.15 matthew 443: &Apache::lonxml::get_param($attr,$parstack,$safeeval);
1.10 matthew 444: if ($values->{$attr} eq '' | !defined($values->{$attr})) {
1.11 matthew 445: $values->{$attr} = $defaults->{$attr}->{'default'};
1.6 matthew 446: next;
447: }
1.10 matthew 448: my $test = $defaults->{$attr}->{'test'};
449: if (! &$test($values->{$attr})) {
1.6 matthew 450: &Apache::lonxml::warning
451: ($tag.':'.$attr.': Bad value.'.'Replacing your value with : '
1.11 matthew 452: .$defaults->{$attr}->{'default'} );
453: $values->{$attr} = $defaults->{$attr}->{'default'};
1.10 matthew 454: }
1.2 matthew 455: }
1.11 matthew 456: return ;
1.6 matthew 457: }
1.15 matthew 458: ##------------------------------------------------------- write_gnuplot_file
1.6 matthew 459: sub write_gnuplot_file {
460: my $gnuplot_input = '';
1.10 matthew 461: my $curve;
1.6 matthew 462: # Collect all the colors
463: my @Colors;
464: push @Colors, $plot{'bgcolor'};
465: push @Colors, $plot{'fgcolor'};
1.13 matthew 466: push @Colors, (defined($axis{'color'})?$axis{'color'}:$plot{'fgcolor'});
1.9 matthew 467: foreach $curve (@curves) {
468: push @Colors, ($curve->{'color'} ne '' ?
469: $curve->{'color'} :
1.13 matthew 470: $plot{'fgcolor'} );
1.6 matthew 471: }
472: # set term
473: $gnuplot_input .= 'set term gif ';
474: $gnuplot_input .= 'transparent ' if ($plot{'transparent'} eq 'on');
475: $gnuplot_input .= $plot{'font'} . ' ';
1.10 matthew 476: $gnuplot_input .= 'size '.$plot{'width'}.','.$plot{'height'}.' ';
1.6 matthew 477: $gnuplot_input .= "@Colors\n";
1.7 matthew 478: # grid
1.10 matthew 479: $gnuplot_input .= 'set grid'.$/ if ($plot{'grid'} eq 'on');
1.7 matthew 480: # border
1.9 matthew 481: $gnuplot_input .= ($plot{'border'} eq 'on'?
482: 'set border'.$/ :
483: 'set noborder'.$/ ); # title, xlabel, ylabel
1.13 matthew 484: $gnuplot_input .= "set output\n";
485: $gnuplot_input .= "set title \"$title\"\n" if (defined($title)) ;
486: $gnuplot_input .= "set xlabel \"$xlabel\"\n" if (defined($xlabel));
487: $gnuplot_input .= "set ylabel \"$ylabel\"\n" if (defined($ylabel));
488: if (defined(%axis)) {
489: $gnuplot_input .= "set xrange \[$axis{'xmin'}:$axis{'xmax'}\]\n";
490: $gnuplot_input .= "set yrange \[$axis{'ymin'}:$axis{'ymax'}\]\n";
1.6 matthew 491: }
492: # Key
1.13 matthew 493: if (defined(%key)) {
1.9 matthew 494: $gnuplot_input .= 'set key '.$key{'pos'}.' ';
495: if ($key{'title'} ne '') {
1.11 matthew 496: $gnuplot_input .= 'title "'.$key{'title'}.'" ';
497: }
498: $gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ').$/;
1.6 matthew 499: } else {
1.9 matthew 500: $gnuplot_input .= 'set nokey'.$/;
1.13 matthew 501: }
1.6 matthew 502: # labels
1.10 matthew 503: my $label;
1.6 matthew 504: foreach $label (@labels) {
505: $gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
1.9 matthew 506: $label->{'xpos'}.','.$label->{'ypos'}.' '.$label->{'justify'}.$/ ;
1.6 matthew 507: }
508: # curves
509: $gnuplot_input .= 'plot ';
510: my $datatext = '';
1.9 matthew 511: for (my $i = 0;$i<=$#curves;$i++) {
512: $curve = $curves[$i];
513: $gnuplot_input.= ', ' if ($i > 0);
1.6 matthew 514: if (exists($curve->{'function'})) {
1.9 matthew 515: $gnuplot_input.=
516: $curve->{'function'}.' title "'.
517: $curve->{'name'}.'" with '.
518: $curve->{'linestyle'};
1.6 matthew 519: } elsif (exists($curve->{'data'})) {
1.9 matthew 520: $gnuplot_input.= '\'-\' title "'.
521: $curve->{'name'}.'" with '.
522: $curve->{'linestyle'};
1.6 matthew 523: my @Data = @{$curve->{'data'}};
1.9 matthew 524: my @Data0 = @{$Data[0]};
525: for (my $i =0; $i<=$#Data0; $i++) {
1.10 matthew 526: my $dataset;
1.6 matthew 527: foreach $dataset (@Data) {
1.9 matthew 528: $datatext .= $dataset->[$i] . ' ';
1.6 matthew 529: }
1.9 matthew 530: $datatext .= $/;
1.6 matthew 531: }
1.9 matthew 532: $datatext .=$/;
1.6 matthew 533: }
534: }
1.9 matthew 535: $gnuplot_input .= $/.$datatext;
1.10 matthew 536: return $gnuplot_input;
1.2 matthew 537: }
1.1 matthew 538:
539: 1;
540: __END__
1.4 matthew 541:
542:
543:
544:
545:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>