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