Annotation of loncom/xml/lonplot.pm, revision 1.9

1.1       matthew     1: # The LearningOnline Network with CAPA
                      2: # Dynamic plot
                      3: #
1.9     ! matthew     4: # $Id: lonplot.pm,v 1.8 2001/12/19 19:22:52 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'}; 
1.9     ! matthew   383:     foreach $curve (@curves) {
        !           384: 	push @Colors, ($curve->{'color'} ne '' ? 
        !           385: 		       $curve->{'color'}       : 
1.6       matthew   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'} . ' ';
1.9     ! matthew   392:     $gnuplot_input .= 'size ' . $plot{'width'} . ',';
1.6       matthew   393:     $gnuplot_input .= $plot{'height'} . ' ';
                    394:     $gnuplot_input .= "@Colors\n";
1.7       matthew   395:     # grid
1.9     ! matthew   396:     $gnuplot_input .= ($plot{'grid'} eq 'on' ?
        !           397: 		       'set grid'.$/            :
1.7       matthew   398: 		       ''                      );
                    399:     # border
1.9     ! matthew   400:     $gnuplot_input .= ($plot{'border'} eq 'on'?
        !           401: 		       'set border'.$/           :
        !           402: 		       'set noborder'.$/         );    # title, xlabel, ylabel
1.6       matthew   403:     {
1.9     ! matthew   404:     $gnuplot_input .= <<"ENDLABELS";
        !           405: set output "tmp.gif"
        !           406: set title  "$title"
        !           407: set xlabel "$xlabel"
        !           408: set ylabel "$ylabel"
        !           409: set xrange \[$axis{'xmin'}:$axis{'xmax'}\]
        !           410: set yrange \[$axis{'ymin'}:$axis{'ymax'}\]
1.6       matthew   411: ENDLABELS
                    412:     }
                    413:     # Key
                    414:     if (defined($key{'pos'})) {
1.9     ! matthew   415: 	$gnuplot_input .= 'set key '.$key{'pos'}.' ';
        !           416: 	$gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ');
        !           417: 	if ($key{'title'} ne '') {
        !           418: 	    $gnuplot_input .= 'title "'.$key{'title'}.'"'.$/;
1.6       matthew   419: 	} else {
1.9     ! matthew   420: 	    $gnuplot_input .= $/;
1.6       matthew   421: 	}
                    422:     } else {
1.9     ! matthew   423: 	$gnuplot_input .= 'set nokey'.$/;
1.6       matthew   424:     }    
                    425:     # labels
                    426:     foreach $label (@labels) {
                    427: 	$gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
1.9     ! matthew   428: 	    $label->{'xpos'}.','.$label->{'ypos'}.' '.$label->{'justify'}.$/ ;
1.6       matthew   429:     }
                    430:     # curves
                    431:     $gnuplot_input .= 'plot ';
                    432:     my $datatext = '';
1.9     ! matthew   433:     for (my $i = 0;$i<=$#curves;$i++) {
        !           434: 	$curve = $curves[$i];
        !           435: 	$gnuplot_input.= ', ' if ($i > 0);
1.6       matthew   436: 	if (exists($curve->{'function'})) {
1.9     ! matthew   437: 	    $gnuplot_input.= 
        !           438: 		$curve->{'function'}.' title "'.
        !           439: 		$curve->{'name'}.'" with '.
        !           440: 		$curve->{'linestyle'};
1.6       matthew   441: 	} elsif (exists($curve->{'data'})) {
1.9     ! matthew   442: 	    $gnuplot_input.= '\'-\' title "'.
        !           443: 		$curve->{'name'}.'" with '.
        !           444: 		$curve->{'linestyle'};
1.6       matthew   445: 	    my @Data = @{$curve->{'data'}};
1.9     ! matthew   446: 	    my @Data0 = @{$Data[0]};
        !           447: 	    for (my $i =0; $i<=$#Data0; $i++) {
1.6       matthew   448: 		foreach $dataset (@Data) {
1.9     ! matthew   449: 		    $datatext .= $dataset->[$i] . ' ';
1.6       matthew   450: 		}
1.9     ! matthew   451: 		$datatext .= $/;
1.6       matthew   452: 	    }
1.9     ! matthew   453: 	    $datatext .=$/;
1.6       matthew   454: 	}
                    455:     }
1.9     ! matthew   456:     $gnuplot_input .= $/.$datatext;
1.6       matthew   457:     print $fh $gnuplot_input;
1.2       matthew   458: }
1.1       matthew   459: 
                    460: 1;
                    461: __END__
1.4       matthew   462: 
                    463: 
                    464: 
                    465: 
                    466: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>