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