Annotation of loncom/xml/lonplot.pm, revision 1.7
1.1 matthew 1: # The LearningOnline Network with CAPA
2: # Dynamic plot
3: #
1.7 ! matthew 4: # $Id: lonplot.pm,v 1.6 2001/12/19 18:27:30 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
29: # 12/18 Matthew
1.1 matthew 30: package Apache::lonplot;
31: use strict;
32: use Apache::response;
1.2 matthew 33: use Apache::lonxml;
34: use Digest::MD5 qw(md5 md5_hex md5_base64);
1.1 matthew 35:
36: sub BEGIN {
37: &Apache::lonxml::register('Apache::lonplot',('plot'));
38: }
39:
40: ##
41: ## Tests used in checking the validitity of input
42: ##
43: my $int_test = sub {$_[0]=~/^\d+$/};
44: my $real_test = sub {$_[0]=~/^[+-]?\d*\.?\d*$/};
45: my $color_test = sub {$_[0]=~/^x[\da-f]{6}$/};
46: my $onoff_test = sub {$_[0]=~/^(on|off)$/};
47: my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/};
48: my $sml_test = sub {$_[0]=~/^(small|medium|large)$/};
49: my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/};
1.5 matthew 50: my $words_test = sub {$_[0]=~/^((\w+\b*)+$/};
1.1 matthew 51: ##
52: ## Default values for attributes of elements
53: ##
54: my %plot_defaults =
55: (
56: height => {default => 200, test => $int_test },
57: width => {default => 200, test => $int_test },
1.5 matthew 58: bgcolor => {default => 'xffffff', test => $color_test},
59: fgcolor => {default => 'x000000', test => $color_test},
60: transparent => {default => 'off', test => $onoff_test},
61: grid => {default => 'off', test => $onoff_test},
62: border => {default => 'on', test => $onoff_test},
63: font => {default => 'medium', test => $sml_test }
1.1 matthew 64: );
65:
66: my %key_defaults =
67: (
1.5 matthew 68: title => { default => '', test => $words_test },
69: box => { default => 'off', test => $onoff_test },
70: pos => { default => 'top right', test => $key_pos_test}
1.1 matthew 71: );
72:
73: my %label_defaults =
74: (
75: xpos => {default => 0, test => $real_test },
76: ypos => {default => 0, test => $real_test },
1.5 matthew 77: justify => {default => 'left',
1.1 matthew 78: test => sub {$_[0]=~/^(left|right|center)$/}}
79: );
80:
81: my %axis_defaults =
82: (
1.5 matthew 83: color => {default => 'x000000', test => $color_test},
1.6 matthew 84: # thickness => {default => 1, test => $int_test },
1.1 matthew 85: xmin => {default => -10.0, test => $real_test },
86: xmax => {default => 10.0, test => $real_test },
87: ymin => {default => -10.0, test => $real_test },
88: ymax => {default => 10.0, test => $real_test }
89: );
90:
91: my %curve_defaults =
92: (
1.5 matthew 93: color => {default => 'x000000', test => $color_test },
94: name => {default => 'x000000', test => sub {$_[0]=~/^[\w ]*$/} },
95: linestyle => {default => 'lines', test => $linestyle_test }
1.1 matthew 96: );
97:
98: ##
99: ## End of defaults
100: ##
101: my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves);
102:
103: sub start_plot {
104: %plot = ''; %key=''; %axis='';
105: $title=''; $xlabel=''; $ylabel='';
106: @labels = ''; @curves='';
1.6 matthew 107: #
1.1 matthew 108: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
109: my $result='';
110: &Apache::lonxml::register('Apache::plot',
111: ('title','xlabel','ylabel','key','axis','label','curve'));
112: push (@Apache::lonxml::namespace,'plot');
1.4 matthew 113: ## Always evaluate the insides of the <plot></plot> tags
1.2 matthew 114: my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]);
1.4 matthew 115: $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]);
116: &Apache::lonxml::newparser($parser,\$inside);
1.2 matthew 117: ##-------------------------------------------------------
118: &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,'plot');
1.4 matthew 119: if ($target eq 'web') {
120: }
1.1 matthew 121: return '';
122: }
123:
124: sub end_plot {
125: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
126: pop @Apache::lonxml::namespace;
1.4 matthew 127: &Apache::lonxml::deregister('Apache::lonplot',
128: ('title','xlabel','ylabel','key','axis','label','curve'));
129: my $result = '';
130: if ($target eq 'web') {
1.6 matthew 131: ## Determine filename -- Need to use the 'id' thingy that Gerd
132: ## mentioned.
1.4 matthew 133: my $tmpdir = '/home/httpd/perl/tmp/';
134: my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
135: '_plot.data';
136: my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'});
137:
138: ## Write the plot description to the file
139: my $fh=&Apache::File->new('/home/httpd/perl/tmp/'.$realname);
1.6 matthew 140: &write_gnuplot_file($fh);
1.4 matthew 141: ## return image tag for the plot
142: $result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"';
143: }
1.1 matthew 144: return $result;
145: }
1.2 matthew 146:
1.1 matthew 147: ##----------------------------------------------------------------- key
148: sub start_key {
149: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
150: my $result='';
1.3 matthew 151: &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack);
1.4 matthew 152: if ($target eq 'web') {
153: # This routine should never return anything.
154: }
1.1 matthew 155: return $result;
156: }
157:
158: sub end_key {
159: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
160: my $result = '';
1.4 matthew 161: if ($target eq 'web') {
162: # This routine should never return anything.
163: }
1.1 matthew 164: return $result;
165: }
166: ##------------------------------------------------------------------- title
167: sub start_title {
168: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
169: $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
170: my $result='';
1.4 matthew 171: if ($target eq 'web') {
172: # This routine should never return anything.
173: }
1.1 matthew 174: return $result;
175: }
176:
177: sub end_title {
178: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
179: my $result = '';
1.4 matthew 180: if ($target eq 'web') {
181: # This routine should never return anything.
182: }
1.1 matthew 183: return $result;
184: }
185: ##------------------------------------------------------------------- xlabel
186: sub start_xlabel {
187: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
188: my $result='';
189: $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
1.4 matthew 190: if ($target eq 'web') {
191: # This routine should never return anything.
192: }
1.1 matthew 193: return $result;
194: }
195:
196: sub end_xlabel {
197: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
198: my $result = '';
1.4 matthew 199: if ($target eq 'web') {
200: # This routine should never return anything.
201: }
1.1 matthew 202: return $result;
203: }
204: ##------------------------------------------------------------------- ylabel
205: sub start_ylabel {
206: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
207: my $result='';
208: $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
1.4 matthew 209: if ($target eq 'web') {
210: # This routine should never return anything.
211: }
1.1 matthew 212: return $result;
213: }
214:
215: sub end_ylabel {
216: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
217: my $result = '';
1.4 matthew 218: if ($target eq 'web') {
219: # This routine should never return anything.
220: }
1.1 matthew 221: return $result;
222: }
223: ##------------------------------------------------------------------- label
224: sub start_label {
225: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
226: my $result='';
1.3 matthew 227: my %label;
228: &get_attributes($label,\%label_defaults,$parstack,$safeeval,$tagstack);
1.1 matthew 229: $label->{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
1.3 matthew 230: push(@labels,\%label);
1.4 matthew 231: if ($target eq 'web') {
232: # This routine should never return anything.
233: }
1.1 matthew 234: return $result;
235: }
236:
237: sub end_label {
238: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
239: my $result = '';
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: ##------------------------------------------------------------------- curve
247: sub start_curve {
248: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
249: my $result='';
1.3 matthew 250: my %curve;
251: &get_attributes($curve,\%curve_defaults,$parstack,$safeeval,$tagstack);
1.1 matthew 252: push (@curves,$curve);
1.4 matthew 253: &Apache::lonxml::register('Apache::lonplot',('function','data'));
1.1 matthew 254: push (@Apache::lonxml::namespace,'curve');
1.4 matthew 255: if ($target eq 'web') {
256: # This routine should never return anything.
257: }
1.1 matthew 258: return $result;
259: }
260:
261: sub end_curve {
262: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
263: my $result = '';
1.4 matthew 264: pop @Apache::lonxml::namespace;
265: &Apache::lonxml::deregister('Apache::lonplot',('function','data'));
266: if ($target eq 'web') {
267: # This routine should never return anything.
268: }
1.1 matthew 269: return $result;
270: }
271: ##------------------------------------------------------------ curve function
272: sub start_function {
273: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
274: my $result='';
1.4 matthew 275: if (exists($curves[-1]->{'data'}) {
276: &Apache::lonxml::warning('Use of <function> precludes use of <data>. The <data> will be omitted in favor of the <function> declaration.');
277: delete($curves[-1]->{'data'});
278: }
1.1 matthew 279: $curves[-1]->{'function'} =
280: &Apache::lonxml::get_all_text("/function",$$parser[-1]);
1.4 matthew 281: if ($target eq 'web') {
282: # This routine should never return anything.
283: }
1.1 matthew 284: return $result;
285: }
286:
287: sub end_function {
288: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
289: my $result = '';
1.4 matthew 290: if ($target eq 'web') {
291: # This routine should never return anything.
292: }
1.1 matthew 293: return $result;
294: }
295: ##------------------------------------------------------------ curve data
296: sub start_data {
297: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
298: my $result='';
1.4 matthew 299: if (exists($curves[-1]->{'function'})) {
300: &Apache::lonxml::warning('Use of <data> precludes use of <function>. The <function> will be omitted in favor of the <data> declaration.');
301: delete($curves[-1]->{'function'});
302: }
303: my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]);
304: $datatext =~ s/(\s+$|^\s+)//g;
305: $datatext =~ s/\s+/ /g;
306: if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) {
307: &Apache::lonxml::warning('Malformed data: '.$datatext);
308: $datatext = '';
309: }
1.6 matthew 310: # Need to do some error checking on the @data array -
311: # make sure it's all numbers and make sure each array
312: # is of the same length.
313: my @data = split /[, ]/,$datatext;
314: push( @{$curves[-1]->{'data'}},\@data;
1.4 matthew 315: if ($target eq 'web') {
316: # This routine should never return anything.
317: }
1.1 matthew 318: return $result;
319: }
320:
321: sub end_data {
322: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
323: my $result = '';
1.4 matthew 324: if ($target eq 'web') {
325: # This routine should never return anything.
326: }
1.1 matthew 327: return $result;
328: }
329:
330: ##------------------------------------------------------------------- axis
331: sub start_axis {
332: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
333: my $result='';
1.3 matthew 334: &get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack);
1.4 matthew 335: if ($target eq 'web') {
336: # This routine should never return anything.
337: }
1.1 matthew 338: return $result;
339: }
340:
341: sub end_axis {
342: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
343: my $result = '';
1.4 matthew 344: if ($target eq 'web') {
345: # This routine should never return anything.
346: }
1.1 matthew 347: return $result;
348: }
349:
350: ##------------------------------------------------------------------- misc
1.2 matthew 351: sub get_attributes{
352: %values = %{shift};
353: %defaults = %{shift};
354: $parstack = shift;
355: $safeeval = shift;
356: $tag = shift;
357: my $attr;
358: foreach $attr (keys %defaults) {
359: $values{$attr} = &Apache::lonxml::get_param($attr,$parstack,$safeeval);
1.6 matthew 360: if ($values{$attr} eq '' | !defined($values{$attr})) {
361: $values{$attr} = $defaults{$attr};
362: next;
363: }
1.2 matthew 364: my $test = $defaults{$attr}->{'test'};
365: if (! &$test($values{$attr})) {
1.6 matthew 366: &Apache::lonxml::warning
367: ($tag.':'.$attr.': Bad value.'.'Replacing your value with : '
368: .$defaults{$attr} );
1.2 matthew 369: $values{$attr} = $defaults{$attr};
370: }
371: return ;
1.6 matthew 372: }
373:
374: sub write_gnuplot_file {
375: my $fh = shift;
376: my $gnuplot_input = '';
377: # Collect all the colors
378: my @Colors;
379: push @Colors, $plot{'bgcolor'};
380: push @Colors, $plot{'fgcolor'};
381: push @Colors, $axis{'color'};
382: push @Colors, $axis{'color'};
383: foreach $curve (@Curves) {
384: push @Colors, ($curve{'color'} ne '' ?
385: $curve{'color'} :
386: $plot{'fgcolor'} );
387: }
388: # set term
389: $gnuplot_input .= 'set term gif ';
390: $gnuplot_input .= 'transparent ' if ($plot{'transparent'} eq 'on');
391: $gnuplot_input .= $plot{'font'} . ' ';
392: $gnuplot_input .= 'size ' . $plot{'width'} . ' ';
393: $gnuplot_input .= $plot{'height'} . ' ';
394: $gnuplot_input .= "@Colors\n";
1.7 ! matthew 395: # grid
! 396: $gnuplot_input .= ($plot->{'grid'} eq 'on' ?
! 397: 'set grid\n' :
! 398: '' );
! 399: # border
! 400: $gnuplot_input .= ($plot->{'border'} eq 'on'?
! 401: 'set border\n' :
! 402: 'set noborder\n' ); # title, xlabel, ylabel
1.6 matthew 403: {
404: $gnuplot_input .<<"ENDLABELS";
405: set title $title->{'text'}
406: set xlabel $xlabel->{'text'}
407: set ylabel $ylabel->{'text'}
408: set xrange $axis->{'xmin'}:$axis->{'xmax'}
409: set yrange $axis->{'ymin'}:$axis->{'ymax'}
410: ENDLABELS
411: }
412: # Key
413: if (defined($key{'pos'})) {
414: $gnuplot_input .= 'set key '.$key->{'pos'}.' ';
415: $gnuplot_input .= ($key->{'box'} eq 'on' ? 'box ' : 'nobox ');
416: if ($key->{'title'} ne '') {
417: $gnuplot_input .= 'title "'$key->{'title'}.'"\n';
418: } else {
419: $gnuplot_input .= '\n';
420: }
421: } else {
1.7 ! matthew 422: $gnuGplot_input .= 'set nokey\n';
1.6 matthew 423: }
424: # axis
425: $gnuplot_input .= 'set xrange ['.$axis{'xmin'}.':'.$axis{'xmin'}.']\n';
426: $gnuplot_input .= 'set yrange ['.$axis{'ymin'}.':'.$axis{'ymin'}.']\n';
427: # labels
428: foreach $label (@labels) {
429: $gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
430: $label->{'x'}.','.$label->{'y'}.'\n';
431: }
432: # curves
433: $gnuplot_input .= 'plot ';
434: my $datatext = '';
435: foreach $curve (@curves) {
436: if (exists($curve->{'function'})) {
437: $gnuplot_input.= $curve->{'function'}.' with '.$curve->{'linestyle'};
438: } elsif (exists($curve->{'data'})) {
439: $gnuplot_input.= '\'-\' with '.$curve->{'linestyle'};
440: my @Data = @{$curve->{'data'}};
441: for ($i =0; $i<=$#Data; $i++) {
442: foreach $dataset (@Data) {
443: $datatext .= $dataset[$i] . ' ';
444: }
445: $datatext .='\n';
446: }
447: $datatext .='\n';
448: }
449: }
450: $gnuplot_input .= $datatext;
451: print $fh $gnuplot_input;
1.2 matthew 452: }
1.1 matthew 453:
454: 1;
455: __END__
1.4 matthew 456:
457:
458:
459:
460:
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