Annotation of loncom/xml/lonplot.pm, revision 1.10
1.1 matthew 1: # The LearningOnline Network with CAPA
2: # Dynamic plot
3: #
1.10 ! matthew 4: # $Id: lonplot.pm,v 1.9 2001/12/19 22:14:20 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.10 ! matthew 29: # 12/18 12/19 12/20 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.2 matthew 37: use Digest::MD5 qw(md5 md5_hex 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
! 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: ##------------------------------------------------------------
1.1 matthew 67: ##
68: ## Tests used in checking the validitity of input
69: ##
70: my $int_test = sub {$_[0]=~/^\d+$/};
71: my $real_test = sub {$_[0]=~/^[+-]?\d*\.?\d*$/};
72: my $color_test = sub {$_[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)$/};
1.10 ! matthew 77: my $words_test = sub {$_[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.1 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 }
115: );
116:
117: my %curve_defaults =
118: (
1.10 ! matthew 119: color => {default => 'x000000', test => $color_test },
1.5 matthew 120: name => {default => 'x000000', test => sub {$_[0]=~/^[\w ]*$/} },
1.10 ! matthew 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.10 ! matthew 144: &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,$tagstack);
1.4 matthew 145: if ($target eq 'web') {
146: }
1.1 matthew 147: return '';
148: }
149:
150: sub end_plot {
151: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
152: pop @Apache::lonxml::namespace;
1.4 matthew 153: &Apache::lonxml::deregister('Apache::lonplot',
154: ('title','xlabel','ylabel','key','axis','label','curve'));
155: my $result = '';
156: if ($target eq 'web') {
1.6 matthew 157: ## Determine filename -- Need to use the 'id' thingy that Gerd
158: ## mentioned.
1.4 matthew 159: my $tmpdir = '/home/httpd/perl/tmp/';
160: my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
161: '_plot.data';
162: my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'});
1.10 ! matthew 163: # my $usersees=$filename.'_'.$ENV{'REMOTE_ADDR'};
1.4 matthew 164:
165: ## Write the plot description to the file
1.10 ! matthew 166: my $fh=Apache::File->new('/home/httpd/perl/tmp/'.$filename);
! 167: $result .= '<pre>';
! 168: $result .= &write_gnuplot_file($fh);
! 169: $result .= '</pre>';
1.4 matthew 170: ## return image tag for the plot
1.10 ! matthew 171: # $result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"';
1.4 matthew 172: }
1.1 matthew 173: return $result;
174: }
1.2 matthew 175:
1.1 matthew 176: ##----------------------------------------------------------------- key
177: sub start_key {
178: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
179: my $result='';
1.3 matthew 180: &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack);
1.4 matthew 181: if ($target eq 'web') {
182: # This routine should never return anything.
183: }
1.1 matthew 184: return $result;
185: }
186:
187: sub end_key {
188: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
189: my $result = '';
1.4 matthew 190: if ($target eq 'web') {
191: # This routine should never return anything.
192: }
1.1 matthew 193: return $result;
194: }
195: ##------------------------------------------------------------------- title
196: sub start_title {
197: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
198: $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
199: my $result='';
1.4 matthew 200: if ($target eq 'web') {
201: # This routine should never return anything.
202: }
1.1 matthew 203: return $result;
204: }
205:
206: sub end_title {
207: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
208: my $result = '';
1.4 matthew 209: if ($target eq 'web') {
210: # This routine should never return anything.
211: }
1.1 matthew 212: return $result;
213: }
214: ##------------------------------------------------------------------- xlabel
215: sub start_xlabel {
216: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
217: my $result='';
218: $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
1.4 matthew 219: if ($target eq 'web') {
220: # This routine should never return anything.
221: }
1.1 matthew 222: return $result;
223: }
224:
225: sub end_xlabel {
226: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
227: my $result = '';
1.4 matthew 228: if ($target eq 'web') {
229: # This routine should never return anything.
230: }
1.1 matthew 231: return $result;
232: }
233: ##------------------------------------------------------------------- ylabel
234: sub start_ylabel {
235: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
236: my $result='';
237: $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
1.4 matthew 238: if ($target eq 'web') {
239: # This routine should never return anything.
240: }
1.1 matthew 241: return $result;
242: }
243:
244: sub end_ylabel {
245: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
246: my $result = '';
1.4 matthew 247: if ($target eq 'web') {
248: # This routine should never return anything.
249: }
1.1 matthew 250: return $result;
251: }
252: ##------------------------------------------------------------------- label
253: sub start_label {
254: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
255: my $result='';
1.3 matthew 256: my %label;
1.10 ! matthew 257: &get_attributes(\%label,\%label_defaults,$parstack,$safeeval,$tagstack);
! 258: $label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
! 259: if (! &$words_test($label{'text'})) {
! 260: # I should probably warn about it, too.
! 261: $label{'text'} = 'Illegal text';
! 262: }
1.3 matthew 263: push(@labels,\%label);
1.4 matthew 264: if ($target eq 'web') {
265: # This routine should never return anything.
266: }
1.1 matthew 267: return $result;
268: }
269:
270: sub end_label {
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:
279: ##------------------------------------------------------------------- curve
280: sub start_curve {
281: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
282: my $result='';
1.3 matthew 283: my %curve;
1.10 ! matthew 284: &get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval,$tagstack);
! 285: push (@curves,\%curve);
1.4 matthew 286: &Apache::lonxml::register('Apache::lonplot',('function','data'));
1.1 matthew 287: push (@Apache::lonxml::namespace,'curve');
1.4 matthew 288: if ($target eq 'web') {
289: # This routine should never return anything.
290: }
1.1 matthew 291: return $result;
292: }
293:
294: sub end_curve {
295: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
296: my $result = '';
1.4 matthew 297: pop @Apache::lonxml::namespace;
298: &Apache::lonxml::deregister('Apache::lonplot',('function','data'));
299: if ($target eq 'web') {
300: # This routine should never return anything.
301: }
1.1 matthew 302: return $result;
303: }
304: ##------------------------------------------------------------ curve function
305: sub start_function {
306: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
307: my $result='';
1.10 ! matthew 308: if (exists($curves[-1]->{'data'})) {
1.4 matthew 309: &Apache::lonxml::warning('Use of <function> precludes use of <data>. The <data> will be omitted in favor of the <function> declaration.');
1.10 ! matthew 310: delete $curves[-1]->{'data'} ;
1.4 matthew 311: }
1.1 matthew 312: $curves[-1]->{'function'} =
313: &Apache::lonxml::get_all_text("/function",$$parser[-1]);
1.4 matthew 314: if ($target eq 'web') {
315: # This routine should never return anything.
316: }
1.1 matthew 317: return $result;
318: }
319:
320: sub end_function {
321: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
322: my $result = '';
1.4 matthew 323: if ($target eq 'web') {
324: # This routine should never return anything.
325: }
1.1 matthew 326: return $result;
327: }
328: ##------------------------------------------------------------ curve data
329: sub start_data {
330: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
331: my $result='';
1.4 matthew 332: if (exists($curves[-1]->{'function'})) {
1.10 ! matthew 333: &Apache::lonxml::warning('Use of <data> precludes use of <function>.'.
! 334: ' The <function> will be omitted in favor of the <data>'.
! 335: ' declaration.');
1.4 matthew 336: delete($curves[-1]->{'function'});
337: }
338: my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]);
1.10 ! matthew 339: $datatext =~ s/\s+//g; # No whitespace, numbers must be seperated
! 340: # by commas
1.4 matthew 341: if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) {
342: &Apache::lonxml::warning('Malformed data: '.$datatext);
343: $datatext = '';
344: }
1.6 matthew 345: # Need to do some error checking on the @data array -
346: # make sure it's all numbers and make sure each array
347: # is of the same length.
1.10 ! matthew 348: my @data = split /,/,$datatext;
! 349: for (my $i=0;$i<=$#data;$i++) {
! 350: # Check that it's non-empty
! 351: # Check that it's a number
! 352: # Maybe I need a 'debug=on' switch to list the data set
! 353: # out in a warning?
! 354: }
! 355: push @{$curves[-1]->{'data'}},\@data;
1.4 matthew 356: if ($target eq 'web') {
357: # This routine should never return anything.
358: }
1.1 matthew 359: return $result;
360: }
361:
362: sub end_data {
363: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
364: my $result = '';
1.4 matthew 365: if ($target eq 'web') {
366: # This routine should never return anything.
367: }
1.1 matthew 368: return $result;
369: }
370:
371: ##------------------------------------------------------------------- axis
372: sub start_axis {
373: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
374: my $result='';
1.3 matthew 375: &get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack);
1.4 matthew 376: if ($target eq 'web') {
377: # This routine should never return anything.
378: }
1.1 matthew 379: return $result;
380: }
381:
382: sub end_axis {
383: my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
384: my $result = '';
1.4 matthew 385: if ($target eq 'web') {
386: # This routine should never return anything.
387: }
1.1 matthew 388: return $result;
389: }
390:
391: ##------------------------------------------------------------------- misc
1.2 matthew 392: sub get_attributes{
1.10 ! matthew 393: my $values = shift;
! 394: my $defaults = shift;
! 395: my $parstack = shift;
! 396: my $safeeval = shift;
! 397: my $tag = shift;
1.2 matthew 398: my $attr;
1.10 ! matthew 399: foreach $attr (keys %{$defaults}) {
! 400: $values->{$attr} =
! 401: &Apache::lonxml::get_param($attr,$parstack,$safeeval);
! 402: if ($values->{$attr} eq '' | !defined($values->{$attr})) {
! 403: $values->{$attr} = $defaults->{$attr};
1.6 matthew 404: next;
405: }
1.10 ! matthew 406: my $test = $defaults->{$attr}->{'test'};
! 407: if (! &$test($values->{$attr})) {
1.6 matthew 408: &Apache::lonxml::warning
409: ($tag.':'.$attr.': Bad value.'.'Replacing your value with : '
1.10 ! matthew 410: .$defaults->{$attr} );
! 411: $values->{$attr} = $defaults->{$attr};
! 412: }
! 413: return ;
1.2 matthew 414: }
1.6 matthew 415: }
416:
417: sub write_gnuplot_file {
418: my $fh = shift;
419: my $gnuplot_input = '';
1.10 ! matthew 420: my $curve;
1.6 matthew 421: # Collect all the colors
422: my @Colors;
423: push @Colors, $plot{'bgcolor'};
424: push @Colors, $plot{'fgcolor'};
425: push @Colors, $axis{'color'};
426: push @Colors, $axis{'color'};
1.9 matthew 427: foreach $curve (@curves) {
428: push @Colors, ($curve->{'color'} ne '' ?
429: $curve->{'color'} :
1.6 matthew 430: $plot{'fgcolor'} );
431: }
432: # set term
433: $gnuplot_input .= 'set term gif ';
434: $gnuplot_input .= 'transparent ' if ($plot{'transparent'} eq 'on');
435: $gnuplot_input .= $plot{'font'} . ' ';
1.10 ! matthew 436: $gnuplot_input .= 'size '.$plot{'width'}.','.$plot{'height'}.' ';
1.6 matthew 437: $gnuplot_input .= "@Colors\n";
1.7 matthew 438: # grid
1.10 ! matthew 439: $gnuplot_input .= 'set grid'.$/ if ($plot{'grid'} eq 'on');
1.7 matthew 440: # border
1.9 matthew 441: $gnuplot_input .= ($plot{'border'} eq 'on'?
442: 'set border'.$/ :
443: 'set noborder'.$/ ); # title, xlabel, ylabel
1.6 matthew 444: {
1.9 matthew 445: $gnuplot_input .= <<"ENDLABELS";
1.10 ! matthew 446: set output "-"
1.9 matthew 447: set title "$title"
448: set xlabel "$xlabel"
449: set ylabel "$ylabel"
450: set xrange \[$axis{'xmin'}:$axis{'xmax'}\]
451: set yrange \[$axis{'ymin'}:$axis{'ymax'}\]
1.6 matthew 452: ENDLABELS
453: }
454: # Key
455: if (defined($key{'pos'})) {
1.9 matthew 456: $gnuplot_input .= 'set key '.$key{'pos'}.' ';
457: $gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ');
458: if ($key{'title'} ne '') {
459: $gnuplot_input .= 'title "'.$key{'title'}.'"'.$/;
1.6 matthew 460: } else {
1.9 matthew 461: $gnuplot_input .= $/;
1.6 matthew 462: }
463: } else {
1.9 matthew 464: $gnuplot_input .= 'set nokey'.$/;
1.6 matthew 465: }
466: # labels
1.10 ! matthew 467: my $label;
1.6 matthew 468: foreach $label (@labels) {
469: $gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
1.9 matthew 470: $label->{'xpos'}.','.$label->{'ypos'}.' '.$label->{'justify'}.$/ ;
1.6 matthew 471: }
472: # curves
473: $gnuplot_input .= 'plot ';
474: my $datatext = '';
1.9 matthew 475: for (my $i = 0;$i<=$#curves;$i++) {
476: $curve = $curves[$i];
477: $gnuplot_input.= ', ' if ($i > 0);
1.6 matthew 478: if (exists($curve->{'function'})) {
1.9 matthew 479: $gnuplot_input.=
480: $curve->{'function'}.' title "'.
481: $curve->{'name'}.'" with '.
482: $curve->{'linestyle'};
1.6 matthew 483: } elsif (exists($curve->{'data'})) {
1.9 matthew 484: $gnuplot_input.= '\'-\' title "'.
485: $curve->{'name'}.'" with '.
486: $curve->{'linestyle'};
1.6 matthew 487: my @Data = @{$curve->{'data'}};
1.9 matthew 488: my @Data0 = @{$Data[0]};
489: for (my $i =0; $i<=$#Data0; $i++) {
1.10 ! matthew 490: my $dataset;
1.6 matthew 491: foreach $dataset (@Data) {
1.9 matthew 492: $datatext .= $dataset->[$i] . ' ';
1.6 matthew 493: }
1.9 matthew 494: $datatext .= $/;
1.6 matthew 495: }
1.9 matthew 496: $datatext .=$/;
1.6 matthew 497: }
498: }
1.9 matthew 499: $gnuplot_input .= $/.$datatext;
1.10 ! matthew 500: return $gnuplot_input;
! 501: # print $fh $gnuplot_input;
1.2 matthew 502: }
1.1 matthew 503:
504: 1;
505: __END__
1.4 matthew 506:
507:
508:
509:
510:
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