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