version 1.13, 2001/12/21 15:27:29
|
version 1.15, 2001/12/21 20:06:25
|
Line 26
|
Line 26
|
# http://www.lon-capa.org/ |
# http://www.lon-capa.org/ |
# |
# |
# 12/15/01 Matthew |
# 12/15/01 Matthew |
# 12/18 12/19 12/20 Matthew |
# 12/17 12/18 12/19 12/20 12/21 Matthew |
package Apache::lonplot; |
package Apache::lonplot; |
|
|
use strict; |
use strict; |
Line 56 sub BEGIN {
|
Line 56 sub BEGIN {
|
## |
## |
## @labels: $labels[$i] = \%label |
## @labels: $labels[$i] = \%label |
## %label: text, xpos, ypos, justify |
## %label: text, xpos, ypos, justify |
## |
## |
## @curves: $curves[$i] = \%curve |
## @curves: $curves[$i] = \%curve |
## %curve: name, linestyle, ( function | data ) |
## %curve: name, linestyle, ( function | data ) |
## |
## |
## $curves[$i]->{'data'} = [ [x1,x2,x3,x4], |
## $curves[$i]->{'data'} = [ [x1,x2,x3,x4], |
## [y1,y2,y3,y4] ] |
## [y1,y2,y3,y4] ] |
Line 71 my $int_test = sub {$_[0]=~s/\s+//
|
Line 71 my $int_test = sub {$_[0]=~s/\s+//
|
my $real_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^[+-]?\d*\.?\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 $color_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^x[\da-f]{6}$/}; |
my $onoff_test = sub {$_[0]=~/^(on|off)$/}; |
my $onoff_test = sub {$_[0]=~/^(on|off)$/}; |
my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/}; |
my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below| )+$/}; |
my $sml_test = sub {$_[0]=~/^(small|medium|large)$/}; |
my $sml_test = sub {$_[0]=~/^(small|medium|large)$/}; |
my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/}; |
my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/}; |
my $words_test = sub {$_[0]=~s/\s+/ /g;$_[0]=~/^(\w+ ?)+$/}; |
my $words_test = sub {$_[0]=~s/\s+/ /g;$_[0]=~/^([\w\(\)]+ ?)+$/}; |
## |
## |
## Default values for attributes of elements |
## Default values for attributes of elements |
## |
## |
Line 111 my %axis_defaults =
|
Line 111 my %axis_defaults =
|
xmin => {default => '-10.0', test => $real_test }, |
xmin => {default => '-10.0', test => $real_test }, |
xmax => {default => ' 10.0', test => $real_test }, |
xmax => {default => ' 10.0', test => $real_test }, |
ymin => {default => '-10.0', test => $real_test }, |
ymin => {default => '-10.0', test => $real_test }, |
ymax => {default => ' 10.0', test => $real_test } |
ymax => {default => ' 10.0', test => $real_test }, |
|
linestyle => {default => 'points', test => $linestyle_test} |
); |
); |
|
|
my %curve_defaults = |
my %curve_defaults = |
Line 158 sub end_plot {
|
Line 159 sub end_plot {
|
## |
## |
## Make sure we have all the input we need: |
## Make sure we have all the input we need: |
if (! defined(%plot )) { &set_defaults(\%plot,\%plot_defaults); } |
if (! defined(%plot )) { &set_defaults(\%plot,\%plot_defaults); } |
if (! defined(%key )) {} # No key for this plot |
if (! defined(%key )) {} # No key for this plot |
if (! defined(%axis )) { &set_defaults(\%axis,\%axis_defaults); } |
if (! defined(%axis )) { &set_defaults(\%axis,\%axis_defaults); } |
if (! defined($title )) {} # No title for this plot |
if (! defined($title )) {} # No title for this plot |
if (! defined($xlabel)) {} # No xlabel for this plot |
if (! defined($xlabel)) {} # No xlabel for this plot |
if (! defined($ylabel)) {} # No ylabel for this plot |
if (! defined($ylabel)) {} # No ylabel for this plot |
if ($#labels < 0) { } # No labels for this plot |
if ($#labels < 0) { } # No labels for this plot |
if ($#curves < 0) { } # This is an error |
if ($#curves < 0) { |
|
&Apache::lonxml::warning("No curves specified for plot!!!!"); |
|
return ''; |
|
} |
|
my $curve; |
|
foreach $curve (@curves) { |
|
if (!defined($curve->{'function'})&&!defined($curve->{'data'})){ |
|
&Apache::lonxml::warning("One of the curves specified did not contain any <data> or <function> declarations\n"); |
|
return ''; |
|
} |
|
} |
## |
## |
## Determine filename |
## Determine filename |
my $tmpdir = '/home/httpd/perl/tmp/'; |
my $tmpdir = '/home/httpd/perl/tmp/'; |
Line 172 sub end_plot {
|
Line 183 sub end_plot {
|
'_'.time.'_'.$$.'_plot.data'; |
'_'.time.'_'.$$.'_plot.data'; |
## Write the plot description to the file |
## Write the plot description to the file |
my $fh=Apache::File->new(">$tmpdir$filename"); |
my $fh=Apache::File->new(">$tmpdir$filename"); |
$result .= '<pre>'; |
|
$result .= $filename.$/; |
|
print $fh &write_gnuplot_file(); |
print $fh &write_gnuplot_file(); |
$result .= '</pre>'.$/; |
close($fh); |
## return image tag for the plot |
## return image tag for the plot |
$result .= <<"ENDIMAGE"; |
$result .= <<"ENDIMAGE"; |
<img src = "/cgi-bin/plot.gif?$filename" |
<img src = "/cgi-bin/plot.gif?$filename" |
Line 424 sub get_attributes{
|
Line 433 sub get_attributes{
|
my $attr; |
my $attr; |
foreach $attr (keys %{$defaults}) { |
foreach $attr (keys %{$defaults}) { |
$values->{$attr} = |
$values->{$attr} = |
&Apache::lonxml::get_param($attr,$parstack,$safeeval); |
&Apache::lonxml::get_param($attr,$parstack,$safeeval); |
if ($values->{$attr} eq '' | !defined($values->{$attr})) { |
if ($values->{$attr} eq '' | !defined($values->{$attr})) { |
$values->{$attr} = $defaults->{$attr}->{'default'}; |
$values->{$attr} = $defaults->{$attr}->{'default'}; |
next; |
next; |
Line 439 sub get_attributes{
|
Line 448 sub get_attributes{
|
} |
} |
return ; |
return ; |
} |
} |
|
##------------------------------------------------------- write_gnuplot_file |
sub write_gnuplot_file { |
sub write_gnuplot_file { |
my $gnuplot_input = ''; |
my $gnuplot_input = ''; |
my $curve; |
my $curve; |
Line 448 sub write_gnuplot_file {
|
Line 457 sub write_gnuplot_file {
|
push @Colors, $plot{'bgcolor'}; |
push @Colors, $plot{'bgcolor'}; |
push @Colors, $plot{'fgcolor'}; |
push @Colors, $plot{'fgcolor'}; |
push @Colors, (defined($axis{'color'})?$axis{'color'}:$plot{'fgcolor'}); |
push @Colors, (defined($axis{'color'})?$axis{'color'}:$plot{'fgcolor'}); |
push @Colors, $Colors[-1]; # Redundancy |
|
foreach $curve (@curves) { |
foreach $curve (@curves) { |
push @Colors, ($curve->{'color'} ne '' ? |
push @Colors, ($curve->{'color'} ne '' ? |
$curve->{'color'} : |
$curve->{'color'} : |