loncom/xml/lonplot.pm - view

File: [LON-CAPA] / loncom / xml / lonplot.pm
Revision 1.13: download - view: text, annotated - select for diffs
Fri Dec 21 15:27:29 2001 UTC (22 years, 4 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

Now should handle missing information relatively cleanly.  I hope.

# The LearningOnline Network with CAPA # Dynamic plot # # $Id: lonplot.pm,v 1.13 2001/12/21 15:27:29 matthew Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # # 12/15/01 Matthew # 12/18 12/19 12/20 Matthew package Apache::lonplot; use strict; use Apache::File; use Apache::response; use Apache::lonxml; use Digest::MD5 qw(md5_base64); sub BEGIN { &Apache::lonxml::register('Apache::lonplot',('plot')); } ## ## Description of data structures: ## ## %plot %key %axis ## -------------------------- ## height title color ## width box xmin ## bgcolor pos xmax ## fgcolor ymin ## transparent ymax ## grid ## border ## font ## ## @labels: $labels[$i] = \%label ## %label: text, xpos, ypos, justify ## ## @curves: $curves[$i] = \%curve ## %curve: name, linestyle, ( function | data ) ## ## $curves[$i]->{'data'} = [ [x1,x2,x3,x4], ## [y1,y2,y3,y4] ] ## ##------------------------------------------------------------ ## ## Tests used in checking the validitity of input ## my $int_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^\d+$/}; my $real_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^[+-]?\d*\.?\d*$/}; my $color_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^x[\da-f]{6}$/}; my $onoff_test = sub {$_[0]=~/^(on|off)$/}; my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/}; my $sml_test = sub {$_[0]=~/^(small|medium|large)$/}; my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/}; my $words_test = sub {$_[0]=~s/\s+/ /g;$_[0]=~/^(\w+ ?)+$/}; ## ## Default values for attributes of elements ## my %plot_defaults = ( height => {default => 200, test => $int_test }, width => {default => 200, test => $int_test }, bgcolor => {default => 'xffffff', test => $color_test }, fgcolor => {default => 'x000000', test => $color_test }, transparent => {default => 'off', test => $onoff_test }, grid => {default => 'off', test => $onoff_test }, border => {default => 'on', test => $onoff_test }, font => {default => 'medium', test => $sml_test } ); my %key_defaults = ( title => { default => '', test => $words_test }, box => { default => 'off', test => $onoff_test }, pos => { default => 'top right', test => $key_pos_test } ); my %label_defaults = ( xpos => {default => 0, test => $real_test }, ypos => {default => 0, test => $real_test }, justify => {default => 'left', test => sub {$_[0]=~/^(left|right|center)$/} } ); my %axis_defaults = ( color => {default => 'x000000', test => $color_test}, xmin => {default => '-10.0', test => $real_test }, xmax => {default => ' 10.0', test => $real_test }, ymin => {default => '-10.0', test => $real_test }, ymax => {default => ' 10.0', test => $real_test } ); my %curve_defaults = ( color => {default => 'x000000', test => $color_test }, name => {default => '', test => $words_test }, linestyle => {default => 'lines', test => $linestyle_test } ); ## ## End of defaults ## my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves); sub start_plot { %plot = undef; %key = undef; %axis = undef; $title = undef; $xlabel = undef; $ylabel = undef; $#labels = -1; $#curves = -1; # my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; &Apache::lonxml::register('Apache::lonplot', ('title','xlabel','ylabel','key','axis','label','curve')); push (@Apache::lonxml::namespace,'plot'); ## Always evaluate the insides of the <plot></plot> tags my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]); $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]); &Apache::lonxml::newparser($parser,\$inside); ##------------------------------------------------------- &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval, $tagstack->[-1]); if ($target eq 'web') { } return ''; } sub end_plot { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; pop @Apache::lonxml::namespace; &Apache::lonxml::deregister('Apache::lonplot', ('title','xlabel','ylabel','key','axis','label','curve')); my $result = ''; if ($target eq 'web') { ## ## Make sure we have all the input we need: if (! defined(%plot )) { &set_defaults(\%plot,\%plot_defaults); } if (! defined(%key )) {} # No key for this plot if (! defined(%axis )) { &set_defaults(\%axis,\%axis_defaults); } if (! defined($title )) {} # No title for this plot if (! defined($xlabel)) {} # No xlabel for this plot if (! defined($ylabel)) {} # No ylabel for this plot if ($#labels < 0) { } # No labels for this plot if ($#curves < 0) { } # This is an error ## ## Determine filename my $tmpdir = '/home/httpd/perl/tmp/'; my $filename = $ENV{'user.name'}.'_'.$ENV{'user.domain'}. '_'.time.'_'.$$.'_plot.data'; ## Write the plot description to the file my $fh=Apache::File->new(">$tmpdir$filename"); $result .= '<pre>'; $result .= $filename.$/; print $fh &write_gnuplot_file(); $result .= '</pre>'.$/; ## return image tag for the plot $result .= <<"ENDIMAGE"; <img src = "/cgi-bin/plot.gif?$filename" alt = "/cgi-bin/plot.gif?$filename" /> ENDIMAGE } return $result; } ##----------------------------------------------------------------- key sub start_key { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; &get_attributes(\%key,\%key_defaults,$parstack,$safeeval, $tagstack->[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_key { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- title sub start_title { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]); my $result=''; if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_title { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- xlabel sub start_xlabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_xlabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- ylabel sub start_ylabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_ylabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- label sub start_label { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; my %label; &get_attributes(\%label,\%label_defaults,$parstack,$safeeval, $tagstack->[-1]); $label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]); if (! &$words_test($label{'text'})) { # I should probably warn about it, too. $label{'text'} = 'Illegal text'; } push(@labels,\%label); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_label { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- curve sub start_curve { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; my %curve; &get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval, $tagstack->[-1]); push (@curves,\%curve); &Apache::lonxml::register('Apache::lonplot',('function','data')); push (@Apache::lonxml::namespace,'curve'); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_curve { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; pop @Apache::lonxml::namespace; &Apache::lonxml::deregister('Apache::lonplot',('function','data')); if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------ curve function sub start_function { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; if (exists($curves[-1]->{'data'})) { &Apache::lonxml::warning('Use of <function> precludes use of <data>. The <data> will be omitted in favor of the <function> declaration.'); delete $curves[-1]->{'data'} ; } $curves[-1]->{'function'} = &Apache::lonxml::get_all_text("/function",$$parser[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_function { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------ curve data sub start_data { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; if (exists($curves[-1]->{'function'})) { &Apache::lonxml::warning('Use of <data> precludes use of <function>.'. ' The <function> will be omitted in favor of the <data>'. ' declaration.'); delete($curves[-1]->{'function'}); } my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]); $datatext =~ s/\s+//g; # No whitespace, numbers must be seperated # by commas if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) { &Apache::lonxml::warning('Malformed data: '.$datatext); $datatext = ''; } # Need to do some error checking on the @data array - # make sure it's all numbers and make sure each array # is of the same length. my @data = split /,/,$datatext; for (my $i=0;$i<=$#data;$i++) { # Check that it's non-empty # Check that it's a number # Maybe I need a 'debug=on' switch to list the data set # out in a warning? } push @{$curves[-1]->{'data'}},\@data; if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_data { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- axis sub start_axis { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; &get_attributes(\%axis,\%axis_defaults,$parstack,$safeeval, $tagstack->[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_axis { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##----------------------------------------------------------- set_defaults sub set_defaults { my $var = shift; my $defaults = shift; my $key; foreach $key (keys %$defaults) { $var->{$key} = $defaults->{$key}->{'default'}; } } ##------------------------------------------------------------------- misc sub get_attributes{ my $values = shift; my $defaults = shift; my $parstack = shift; my $safeeval = shift; my $tag = shift; my $attr; foreach $attr (keys %{$defaults}) { $values->{$attr} = &Apache::lonxml::get_param($attr,$parstack,$safeeval); if ($values->{$attr} eq '' | !defined($values->{$attr})) { $values->{$attr} = $defaults->{$attr}->{'default'}; next; } my $test = $defaults->{$attr}->{'test'}; if (! &$test($values->{$attr})) { &Apache::lonxml::warning ($tag.':'.$attr.': Bad value.'.'Replacing your value with : ' .$defaults->{$attr}->{'default'} ); $values->{$attr} = $defaults->{$attr}->{'default'}; } } return ; } sub write_gnuplot_file { my $gnuplot_input = ''; my $curve; # Collect all the colors my @Colors; push @Colors, $plot{'bgcolor'}; push @Colors, $plot{'fgcolor'}; push @Colors, (defined($axis{'color'})?$axis{'color'}:$plot{'fgcolor'}); push @Colors, $Colors[-1]; # Redundancy foreach $curve (@curves) { push @Colors, ($curve->{'color'} ne '' ? $curve->{'color'} : $plot{'fgcolor'} ); } # set term $gnuplot_input .= 'set term gif '; $gnuplot_input .= 'transparent ' if ($plot{'transparent'} eq 'on'); $gnuplot_input .= $plot{'font'} . ' '; $gnuplot_input .= 'size '.$plot{'width'}.','.$plot{'height'}.' '; $gnuplot_input .= "@Colors\n"; # grid $gnuplot_input .= 'set grid'.$/ if ($plot{'grid'} eq 'on'); # border $gnuplot_input .= ($plot{'border'} eq 'on'? 'set border'.$/ : 'set noborder'.$/ ); # title, xlabel, ylabel $gnuplot_input .= "set output\n"; $gnuplot_input .= "set title \"$title\"\n" if (defined($title)) ; $gnuplot_input .= "set xlabel \"$xlabel\"\n" if (defined($xlabel)); $gnuplot_input .= "set ylabel \"$ylabel\"\n" if (defined($ylabel)); if (defined(%axis)) { $gnuplot_input .= "set xrange \[$axis{'xmin'}:$axis{'xmax'}\]\n"; $gnuplot_input .= "set yrange \[$axis{'ymin'}:$axis{'ymax'}\]\n"; } # Key if (defined(%key)) { $gnuplot_input .= 'set key '.$key{'pos'}.' '; if ($key{'title'} ne '') { $gnuplot_input .= 'title "'.$key{'title'}.'" '; } $gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ').$/; } else { $gnuplot_input .= 'set nokey'.$/; } # labels my $label; foreach $label (@labels) { $gnuplot_input .= 'set label "'.$label->{'text'}.'" at '. $label->{'xpos'}.','.$label->{'ypos'}.' '.$label->{'justify'}.$/ ; } # curves $gnuplot_input .= 'plot '; my $datatext = ''; for (my $i = 0;$i<=$#curves;$i++) { $curve = $curves[$i]; $gnuplot_input.= ', ' if ($i > 0); if (exists($curve->{'function'})) { $gnuplot_input.= $curve->{'function'}.' title "'. $curve->{'name'}.'" with '. $curve->{'linestyle'}; } elsif (exists($curve->{'data'})) { $gnuplot_input.= '\'-\' title "'. $curve->{'name'}.'" with '. $curve->{'linestyle'}; my @Data = @{$curve->{'data'}}; my @Data0 = @{$Data[0]}; for (my $i =0; $i<=$#Data0; $i++) { my $dataset; foreach $dataset (@Data) { $datatext .= $dataset->[$i] . ' '; } $datatext .= $/; } $datatext .=$/; } } $gnuplot_input .= $/.$datatext; return $gnuplot_input; } 1; __END__