Annotation of loncom/xml/lonplot.pm, revision 1.14
1.1 matthew 1: # The LearningOnline Network with CAPA
2: # Dynamic plot
3: #
1.14 ! matthew 4: # $Id: lonplot.pm,v 1.13 2001/12/21 15:27:29 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)$/};
74: my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/};
75: my $sml_test = sub {$_[0]=~/^(small|medium|large)$/};
76: my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/};
1.11 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 },
90: font => {default => 'medium', test => $sml_test }
1.1 matthew 91: );
92:
93: my %key_defaults =
94: (
1.10 matthew 95: title => { default => '', test => $words_test },
96: box => { default => 'off', test => $onoff_test },
97: pos => { default => 'top right', test => $key_pos_test }
1.1 matthew 98: );
99:
100: my %label_defaults =
101: (
1.10 matthew 102: xpos => {default => 0, test => $real_test },
103: ypos => {default => 0, test => $real_test },
1.5 matthew 104: justify => {default => 'left',
1.10 matthew 105: test => sub {$_[0]=~/^(left|right|center)$/} }
1.1 matthew 106: );
107:
108: my %axis_defaults =
109: (
1.5 matthew 110: color => {default => 'x000000', test => $color_test},
1.11 matthew 111: xmin => {default => '-10.0', test => $real_test },
112: xmax => {default => ' 10.0', test => $real_test },
113: ymin => {default => '-10.0', test => $real_test },
114: ymax => {default => ' 10.0', test => $real_test }
1.1 matthew 115: );
116:
117: my %curve_defaults =
118: (
1.13 matthew 119: color => {default => 'x000000', test => $color_test },
120: name => {default => '', test => $words_test },
121: linestyle => {default => 'lines', test => $linestyle_test }
1.1 matthew 122: );
123:
124: ##
125: ## End of defaults
126: ##
127: my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves);
128:
129: sub start_plot {
1.10 matthew 130: %plot = undef; %key = undef; %axis = undef;
131: $title = undef; $xlabel = undef; $ylabel = undef;
132: $#labels = -1; $#curves = -1;
1.6 matthew 133: #
1.1 matthew 134: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
135: my $result='';
1.10 matthew 136: &Apache::lonxml::register('Apache::lonplot',
1.1 matthew 137: ('title','xlabel','ylabel','key','axis','label','curve'));
138: push (@Apache::lonxml::namespace,'plot');
1.4 matthew 139: ## Always evaluate the insides of the <plot></plot> tags
1.2 matthew 140: my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]);
1.4 matthew 141: $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]);
142: &Apache::lonxml::newparser($parser,\$inside);
1.2 matthew 143: ##-------------------------------------------------------
1.11 matthew 144: &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,
145: $tagstack->[-1]);
1.4 matthew 146: if ($target eq 'web') {
147: }
1.1 matthew 148: return '';
149: }
150:
151: sub end_plot {
152: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
153: pop @Apache::lonxml::namespace;
1.4 matthew 154: &Apache::lonxml::deregister('Apache::lonplot',
155: ('title','xlabel','ylabel','key','axis','label','curve'));
156: my $result = '';
157: if ($target eq 'web') {
1.13 matthew 158: ##
159: ## Make sure we have all the input we need:
160: if (! defined(%plot )) { &set_defaults(\%plot,\%plot_defaults); }
1.14 ! matthew 161: if (! defined(%key )) {} # No key for this plot
1.13 matthew 162: if (! defined(%axis )) { &set_defaults(\%axis,\%axis_defaults); }
1.14 ! matthew 163: if (! defined($title )) {} # No title for this plot
! 164: if (! defined($xlabel)) {} # No xlabel for this plot
! 165: if (! defined($ylabel)) {} # No ylabel for this plot
1.13 matthew 166: if ($#labels < 0) { } # No labels for this plot
1.14 ! matthew 167: if ($#curves < 0) {
! 168: &Apache::lonxml::warning("No curves specified for plot!!!!");
! 169: return '';
! 170: }
! 171: my $curve;
! 172: foreach $curve (@curves) {
! 173: if (!defined($curve->{'function'})&&!defined($curve->{'data'})){
! 174: &Apache::lonxml::warning("One of the curves specified did not contain any <data> or <function> declarations\n");
! 175: return '';
! 176: }
! 177: }
1.13 matthew 178: ##
179: ## Determine filename
1.4 matthew 180: my $tmpdir = '/home/httpd/perl/tmp/';
1.12 matthew 181: my $filename = $ENV{'user.name'}.'_'.$ENV{'user.domain'}.
1.13 matthew 182: '_'.time.'_'.$$.'_plot.data';
1.4 matthew 183: ## Write the plot description to the file
1.12 matthew 184: my $fh=Apache::File->new(">$tmpdir$filename");
185: print $fh &write_gnuplot_file();
1.14 ! matthew 186: close($fh);
1.4 matthew 187: ## return image tag for the plot
1.12 matthew 188: $result .= <<"ENDIMAGE";
189: <img src = "/cgi-bin/plot.gif?$filename"
190: alt = "/cgi-bin/plot.gif?$filename" />
191: ENDIMAGE
1.4 matthew 192: }
1.1 matthew 193: return $result;
194: }
1.2 matthew 195:
1.1 matthew 196: ##----------------------------------------------------------------- key
197: sub start_key {
198: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
199: my $result='';
1.11 matthew 200: &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,
201: $tagstack->[-1]);
1.4 matthew 202: if ($target eq 'web') {
203: # This routine should never return anything.
204: }
1.1 matthew 205: return $result;
206: }
207:
208: sub end_key {
209: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
210: my $result = '';
1.4 matthew 211: if ($target eq 'web') {
212: # This routine should never return anything.
213: }
1.1 matthew 214: return $result;
215: }
216: ##------------------------------------------------------------------- title
217: sub start_title {
218: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
219: $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
220: my $result='';
1.4 matthew 221: if ($target eq 'web') {
222: # This routine should never return anything.
223: }
1.1 matthew 224: return $result;
225: }
226:
227: sub end_title {
228: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
229: my $result = '';
1.4 matthew 230: if ($target eq 'web') {
231: # This routine should never return anything.
232: }
1.1 matthew 233: return $result;
234: }
235: ##------------------------------------------------------------------- xlabel
236: sub start_xlabel {
237: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
238: my $result='';
239: $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
1.4 matthew 240: if ($target eq 'web') {
241: # This routine should never return anything.
242: }
1.1 matthew 243: return $result;
244: }
245:
246: sub end_xlabel {
247: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
248: my $result = '';
1.4 matthew 249: if ($target eq 'web') {
250: # This routine should never return anything.
251: }
1.1 matthew 252: return $result;
253: }
254: ##------------------------------------------------------------------- ylabel
255: sub start_ylabel {
256: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
257: my $result='';
258: $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
1.4 matthew 259: if ($target eq 'web') {
260: # This routine should never return anything.
261: }
1.1 matthew 262: return $result;
263: }
264:
265: sub end_ylabel {
266: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
267: my $result = '';
1.4 matthew 268: if ($target eq 'web') {
269: # This routine should never return anything.
270: }
1.1 matthew 271: return $result;
272: }
273: ##------------------------------------------------------------------- label
274: sub start_label {
275: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
276: my $result='';
1.3 matthew 277: my %label;
1.11 matthew 278: &get_attributes(\%label,\%label_defaults,$parstack,$safeeval,
279: $tagstack->[-1]);
1.10 matthew 280: $label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
281: if (! &$words_test($label{'text'})) {
282: # I should probably warn about it, too.
283: $label{'text'} = 'Illegal text';
284: }
1.3 matthew 285: push(@labels,\%label);
1.4 matthew 286: if ($target eq 'web') {
287: # This routine should never return anything.
288: }
1.1 matthew 289: return $result;
290: }
291:
292: sub end_label {
293: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
294: my $result = '';
1.4 matthew 295: if ($target eq 'web') {
296: # This routine should never return anything.
297: }
1.1 matthew 298: return $result;
299: }
300:
301: ##------------------------------------------------------------------- curve
302: sub start_curve {
303: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
304: my $result='';
1.3 matthew 305: my %curve;
1.11 matthew 306: &get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval,
307: $tagstack->[-1]);
1.10 matthew 308: push (@curves,\%curve);
1.4 matthew 309: &Apache::lonxml::register('Apache::lonplot',('function','data'));
1.1 matthew 310: push (@Apache::lonxml::namespace,'curve');
1.4 matthew 311: if ($target eq 'web') {
312: # This routine should never return anything.
313: }
1.1 matthew 314: return $result;
315: }
316:
317: sub end_curve {
318: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
319: my $result = '';
1.4 matthew 320: pop @Apache::lonxml::namespace;
321: &Apache::lonxml::deregister('Apache::lonplot',('function','data'));
322: if ($target eq 'web') {
323: # This routine should never return anything.
324: }
1.1 matthew 325: return $result;
326: }
327: ##------------------------------------------------------------ curve function
328: sub start_function {
329: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
330: my $result='';
1.10 matthew 331: if (exists($curves[-1]->{'data'})) {
1.4 matthew 332: &Apache::lonxml::warning('Use of <function> precludes use of <data>. The <data> will be omitted in favor of the <function> declaration.');
1.10 matthew 333: delete $curves[-1]->{'data'} ;
1.4 matthew 334: }
1.1 matthew 335: $curves[-1]->{'function'} =
336: &Apache::lonxml::get_all_text("/function",$$parser[-1]);
1.4 matthew 337: if ($target eq 'web') {
338: # This routine should never return anything.
339: }
1.1 matthew 340: return $result;
341: }
342:
343: sub end_function {
344: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
345: my $result = '';
1.4 matthew 346: if ($target eq 'web') {
347: # This routine should never return anything.
348: }
1.1 matthew 349: return $result;
350: }
351: ##------------------------------------------------------------ curve data
352: sub start_data {
353: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
354: my $result='';
1.4 matthew 355: if (exists($curves[-1]->{'function'})) {
1.10 matthew 356: &Apache::lonxml::warning('Use of <data> precludes use of <function>.'.
357: ' The <function> will be omitted in favor of the <data>'.
358: ' declaration.');
1.4 matthew 359: delete($curves[-1]->{'function'});
360: }
361: my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]);
1.10 matthew 362: $datatext =~ s/\s+//g; # No whitespace, numbers must be seperated
363: # by commas
1.4 matthew 364: if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) {
365: &Apache::lonxml::warning('Malformed data: '.$datatext);
366: $datatext = '';
367: }
1.6 matthew 368: # Need to do some error checking on the @data array -
369: # make sure it's all numbers and make sure each array
370: # is of the same length.
1.10 matthew 371: my @data = split /,/,$datatext;
372: for (my $i=0;$i<=$#data;$i++) {
373: # Check that it's non-empty
374: # Check that it's a number
375: # Maybe I need a 'debug=on' switch to list the data set
376: # out in a warning?
377: }
378: push @{$curves[-1]->{'data'}},\@data;
1.4 matthew 379: if ($target eq 'web') {
380: # This routine should never return anything.
381: }
1.1 matthew 382: return $result;
383: }
384:
385: sub end_data {
386: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
387: my $result = '';
1.4 matthew 388: if ($target eq 'web') {
389: # This routine should never return anything.
390: }
1.1 matthew 391: return $result;
392: }
393:
394: ##------------------------------------------------------------------- axis
395: sub start_axis {
396: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
397: my $result='';
1.11 matthew 398: &get_attributes(\%axis,\%axis_defaults,$parstack,$safeeval,
399: $tagstack->[-1]);
1.4 matthew 400: if ($target eq 'web') {
401: # This routine should never return anything.
402: }
1.1 matthew 403: return $result;
404: }
405:
406: sub end_axis {
407: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
408: my $result = '';
1.4 matthew 409: if ($target eq 'web') {
410: # This routine should never return anything.
411: }
1.1 matthew 412: return $result;
413: }
414:
1.13 matthew 415: ##----------------------------------------------------------- set_defaults
416: sub set_defaults {
417: my $var = shift;
418: my $defaults = shift;
419: my $key;
420: foreach $key (keys %$defaults) {
421: $var->{$key} = $defaults->{$key}->{'default'};
422: }
423: }
424:
1.1 matthew 425: ##------------------------------------------------------------------- misc
1.2 matthew 426: sub get_attributes{
1.10 matthew 427: my $values = shift;
428: my $defaults = shift;
429: my $parstack = shift;
430: my $safeeval = shift;
431: my $tag = shift;
1.2 matthew 432: my $attr;
1.10 matthew 433: foreach $attr (keys %{$defaults}) {
434: $values->{$attr} =
435: &Apache::lonxml::get_param($attr,$parstack,$safeeval);
436: if ($values->{$attr} eq '' | !defined($values->{$attr})) {
1.11 matthew 437: $values->{$attr} = $defaults->{$attr}->{'default'};
1.6 matthew 438: next;
439: }
1.10 matthew 440: my $test = $defaults->{$attr}->{'test'};
441: if (! &$test($values->{$attr})) {
1.6 matthew 442: &Apache::lonxml::warning
443: ($tag.':'.$attr.': Bad value.'.'Replacing your value with : '
1.11 matthew 444: .$defaults->{$attr}->{'default'} );
445: $values->{$attr} = $defaults->{$attr}->{'default'};
1.10 matthew 446: }
1.2 matthew 447: }
1.11 matthew 448: return ;
1.6 matthew 449: }
450:
451: sub write_gnuplot_file {
452: my $gnuplot_input = '';
1.10 matthew 453: my $curve;
1.6 matthew 454: # Collect all the colors
455: my @Colors;
456: push @Colors, $plot{'bgcolor'};
457: push @Colors, $plot{'fgcolor'};
1.13 matthew 458: push @Colors, (defined($axis{'color'})?$axis{'color'}:$plot{'fgcolor'});
459: push @Colors, $Colors[-1]; # Redundancy
1.9 matthew 460: foreach $curve (@curves) {
461: push @Colors, ($curve->{'color'} ne '' ?
462: $curve->{'color'} :
1.13 matthew 463: $plot{'fgcolor'} );
1.6 matthew 464: }
465: # set term
466: $gnuplot_input .= 'set term gif ';
467: $gnuplot_input .= 'transparent ' if ($plot{'transparent'} eq 'on');
468: $gnuplot_input .= $plot{'font'} . ' ';
1.10 matthew 469: $gnuplot_input .= 'size '.$plot{'width'}.','.$plot{'height'}.' ';
1.6 matthew 470: $gnuplot_input .= "@Colors\n";
1.7 matthew 471: # grid
1.10 matthew 472: $gnuplot_input .= 'set grid'.$/ if ($plot{'grid'} eq 'on');
1.7 matthew 473: # border
1.9 matthew 474: $gnuplot_input .= ($plot{'border'} eq 'on'?
475: 'set border'.$/ :
476: 'set noborder'.$/ ); # title, xlabel, ylabel
1.13 matthew 477: $gnuplot_input .= "set output\n";
478: $gnuplot_input .= "set title \"$title\"\n" if (defined($title)) ;
479: $gnuplot_input .= "set xlabel \"$xlabel\"\n" if (defined($xlabel));
480: $gnuplot_input .= "set ylabel \"$ylabel\"\n" if (defined($ylabel));
481: if (defined(%axis)) {
482: $gnuplot_input .= "set xrange \[$axis{'xmin'}:$axis{'xmax'}\]\n";
483: $gnuplot_input .= "set yrange \[$axis{'ymin'}:$axis{'ymax'}\]\n";
1.6 matthew 484: }
485: # Key
1.13 matthew 486: if (defined(%key)) {
1.9 matthew 487: $gnuplot_input .= 'set key '.$key{'pos'}.' ';
488: if ($key{'title'} ne '') {
1.11 matthew 489: $gnuplot_input .= 'title "'.$key{'title'}.'" ';
490: }
491: $gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ').$/;
1.6 matthew 492: } else {
1.9 matthew 493: $gnuplot_input .= 'set nokey'.$/;
1.13 matthew 494: }
1.6 matthew 495: # labels
1.10 matthew 496: my $label;
1.6 matthew 497: foreach $label (@labels) {
498: $gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
1.9 matthew 499: $label->{'xpos'}.','.$label->{'ypos'}.' '.$label->{'justify'}.$/ ;
1.6 matthew 500: }
501: # curves
502: $gnuplot_input .= 'plot ';
503: my $datatext = '';
1.9 matthew 504: for (my $i = 0;$i<=$#curves;$i++) {
505: $curve = $curves[$i];
506: $gnuplot_input.= ', ' if ($i > 0);
1.6 matthew 507: if (exists($curve->{'function'})) {
1.9 matthew 508: $gnuplot_input.=
509: $curve->{'function'}.' title "'.
510: $curve->{'name'}.'" with '.
511: $curve->{'linestyle'};
1.6 matthew 512: } elsif (exists($curve->{'data'})) {
1.9 matthew 513: $gnuplot_input.= '\'-\' title "'.
514: $curve->{'name'}.'" with '.
515: $curve->{'linestyle'};
1.6 matthew 516: my @Data = @{$curve->{'data'}};
1.9 matthew 517: my @Data0 = @{$Data[0]};
518: for (my $i =0; $i<=$#Data0; $i++) {
1.10 matthew 519: my $dataset;
1.6 matthew 520: foreach $dataset (@Data) {
1.9 matthew 521: $datatext .= $dataset->[$i] . ' ';
1.6 matthew 522: }
1.9 matthew 523: $datatext .= $/;
1.6 matthew 524: }
1.9 matthew 525: $datatext .=$/;
1.6 matthew 526: }
527: }
1.9 matthew 528: $gnuplot_input .= $/.$datatext;
1.10 matthew 529: return $gnuplot_input;
1.2 matthew 530: }
1.1 matthew 531:
532: 1;
533: __END__
1.4 matthew 534:
535:
536:
537:
538:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonplot.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / xml