loncom/xml/lonplot.pm - diff

Return to lonplot.pm CVS log

Up to [LON-CAPA] / loncom / xml

Diff for /loncom/xml/lonplot.pm between versions 1.1 and 1.6

version 1.1, 2001/12/17 21:43:12	version 1.6, 2001/12/19 18:27:30
Line 25	Line 25
#	#
# http://www.lon-capa.org/	# http://www.lon-capa.org/
#	#
# 2/21 Guy	# 12/15/01 Matthew
	# 12/18 Matthew
package Apache::lonplot;	package Apache::lonplot;
use strict;	use strict;
use Apache::response;	use Apache::response;
	use Apache::lonxml;
	use Digest::MD5 qw(md5 md5_hex md5_base64);

sub BEGIN {	sub BEGIN {
&Apache::lonxml::register('Apache::lonplot',('plot'));	&Apache::lonxml::register('Apache::lonplot',('plot'));
}	}


##	##
## Tests used in checking the validitity of input	## Tests used in checking the validitity of input
##	##
Line 45 my $onoff_test = sub {$_[0]=~/^(on\|o	Line 47 my $onoff_test = sub {$_[0]=~/^(on\|o
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]=~/^((\w+\b*)+$/};
##	##
## Default values for attributes of elements	## Default values for attributes of elements
##	##
Line 53 my %plot_defaults =	Line 55 my %plot_defaults =
(	(
height => {default => 200, test => $int_test },	height => {default => 200, test => $int_test },
width => {default => 200, test => $int_test },	width => {default => 200, test => $int_test },
bgcolor => {default => "xffffff", test => $color_test},	bgcolor => {default => 'xffffff', test => $color_test},
fgcolor => {default => "x000000", test => $color_test},	fgcolor => {default => 'x000000', test => $color_test},
transparent => {default => "off", test => $onoff_test},	transparent => {default => 'off', test => $onoff_test},
grid => {default => "off", test => $onoff_test},	grid => {default => 'off', test => $onoff_test},
border => {default => "on" , test => $onoff_test},	border => {default => 'on', test => $onoff_test},
font => {default => "medium", test => $sml_test }	font => {default => 'medium', test => $sml_test }
);	);

my %key_defaults =	my %key_defaults =
(	(
title => { default => "on" , test => $onoff_test },	title => { default => '', test => $words_test },
box => { default => "off" , test => $onoff_test },	box => { default => 'off', test => $onoff_test },
pos => { default => "top right" , test => $key_pos_test}	pos => { default => 'top right', test => $key_pos_test}
);	);

my %label_defaults =	my %label_defaults =
(	(
xpos => {default => 0, test => $real_test },	xpos => {default => 0, test => $real_test },
ypos => {default => 0, test => $real_test },	ypos => {default => 0, test => $real_test },
color => {default => "x000000", test => $color_test },	justify => {default => 'left',
justify => {default => "left",
test => sub {$_[0]=~/^(left\|right\|center)$/}}	test => sub {$_[0]=~/^(left\|right\|center)$/}}
);	);

my %axis_defaults =	my %axis_defaults =
(	(
color => {default => "x000000", test => $color_test},	color => {default => 'x000000', test => $color_test},
thickness => {default => 1, test => $int_test },	# thickness => {default => 1, test => $int_test },
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 },
Line 89 my %axis_defaults =	Line 90 my %axis_defaults =

my %curve_defaults =	my %curve_defaults =
(	(
color => {default => "x000000", test => $color_test },	color => {default => 'x000000', test => $color_test },
name => {default => "x000000", test => sub {$_[0]=~/^[\w ]*$/} },	name => {default => 'x000000', test => sub {$_[0]=~/^[\w ]*$/} },
linestyle => {default => "lines", test => $linestyle_test }	linestyle => {default => 'lines', test => $linestyle_test }
);	);

##	##
Line 103 sub start_plot {	Line 104 sub start_plot {
%plot = ''; %key=''; %axis='';	%plot = ''; %key=''; %axis='';
$title=''; $xlabel=''; $ylabel='';	$title=''; $xlabel=''; $ylabel='';
@labels = ''; @curves='';	@labels = ''; @curves='';
	#
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
#
&Apache::lonxml::register('Apache::plot',	&Apache::lonxml::register('Apache::plot',
('title','xlabel','ylabel','key','axis','label','curve'));	('title','xlabel','ylabel','key','axis','label','curve'));
push (@Apache::lonxml::namespace,'plot');	push (@Apache::lonxml::namespace,'plot');
&get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval);	## Always evaluate the insides of the <plot></plot> tags
return '';	my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]);
}	$inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]);
	&Apache::lonxml::newparser($parser,\$inside);
sub get_attributes{	##-------------------------------------------------------
%values = %{$_[0]};	&get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,'plot');
%defaults = %{$_[1]};	if ($target eq 'web') {
$parstack = $_[2];
$safeeval = $_[3];
my $attr;
foreach $attr (keys %defaults) {
$values{$attr} = &Apache::lonxml::get_param($attr,$parstack,$safeeval);
my $test = $defaults{$attr}->{'test'};
$values{$attr} = (&$test($values{$attr}) ?
$values{$attr} :
$defaults{$attr} );
}	}
return ;	return '';
}	}

sub end_plot {	sub end_plot {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
pop @Apache::lonxml::namespace;	pop @Apache::lonxml::namespace;
my $result;	&Apache::lonxml::deregister('Apache::lonplot',
## Determine filename	('title','xlabel','ylabel','key','axis','label','curve'));
my $filename =	my $result = '';
## Write the plot description to the file	if ($target eq 'web') {
## return image tag for the plot	## Determine filename -- Need to use the 'id' thingy that Gerd
	## mentioned.
	my $tmpdir = '/home/httpd/perl/tmp/';
	my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
	'_plot.data';
	my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'});

	## Write the plot description to the file
	my $fh=&Apache::File->new('/home/httpd/perl/tmp/'.$realname);
	&write_gnuplot_file($fh);
	## return image tag for the plot
	$result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"';
	}
return $result;	return $result;
}	}

##----------------------------------------------------------------- key	##----------------------------------------------------------------- key
sub start_key {	sub start_key {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
&get_attributes(\%key,\%key_defaults,$parstack,$safeeval);	&get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack);
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_key {	sub end_key {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}
##------------------------------------------------------------------- title	##------------------------------------------------------------------- title
Line 157 sub start_title {	Line 168 sub start_title {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
$title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);	$title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
my $result='';	my $result='';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_title {	sub end_title {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}
##------------------------------------------------------------------- xlabel	##------------------------------------------------------------------- xlabel
Line 170 sub start_xlabel {	Line 187 sub start_xlabel {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
$xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);	$xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_xlabel {	sub end_xlabel {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}
##------------------------------------------------------------------- ylabel	##------------------------------------------------------------------- ylabel
Line 183 sub start_ylabel {	Line 206 sub start_ylabel {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
$ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);	$ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_ylabel {	sub end_ylabel {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}
##------------------------------------------------------------------- label	##------------------------------------------------------------------- label
sub start_label {	sub start_label {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
my $label = &newhashref();	my %label;
&get_attributes($label,\%label_defaults,$parstack,$safeeval);	&get_attributes($label,\%label_defaults,$parstack,$safeeval,$tagstack);
$label->{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);	$label->{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
push(@labels,$label);	push(@labels,\%label);
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_label {	sub end_label {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

Line 212 sub end_label {	Line 247 sub end_label {
sub start_curve {	sub start_curve {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
my $curve = &newhashref();	my %curve;
&get_attributes($curve,\%curve_defaults,$parstack,$safeeval);	&get_attributes($curve,\%curve_defaults,$parstack,$safeeval,$tagstack);
push (@curves,$curve);	push (@curves,$curve);
	&Apache::lonxml::register('Apache::lonplot',('function','data'));
&Apache::lonxml::register('Apache::plot',('function','data'));
push (@Apache::lonxml::namespace,'curve');	push (@Apache::lonxml::namespace,'curve');
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_curve {	sub end_curve {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	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;	return $result;
}	}

##------------------------------------------------------------ curve function	##------------------------------------------------------------ curve function
sub start_function {	sub start_function {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	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'} =	$curves[-1]->{'function'} =
&Apache::lonxml::get_all_text("/function",$$parser[-1]);	&Apache::lonxml::get_all_text("/function",$$parser[-1]);
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_function {	sub end_function {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

##------------------------------------------------------------ curve data	##------------------------------------------------------------ curve data
sub start_data {	sub start_data {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
push( @{$curves[-1]->{'data'}},	if (exists($curves[-1]->{'function'})) {
&Apache::lonxml::get_all_text("/data",$$parser[-1]));	&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+$\|^\s+)//g;
	$datatext =~ s/\s+/ /g;
	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;
	push( @{$curves[-1]->{'data'}},\@data;
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_data {	sub end_data {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

Line 263 sub end_data {	Line 331 sub end_data {
sub start_axis {	sub start_axis {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result='';	my $result='';
&get_attributes(\%axis,\%label_defaults,$parstack,$safeeval);	&get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack);
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

sub end_axis {	sub end_axis {
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;	my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
my $result = '';	my $result = '';
	if ($target eq 'web') {
	# This routine should never return anything.
	}
return $result;	return $result;
}	}

##------------------------------------------------------------------- misc	##------------------------------------------------------------------- misc
sub newhashref{	sub get_attributes{
my %hash;	%values = %{shift};
return \%hash;	%defaults = %{shift};
	$parstack = shift;
	$safeeval = shift;
	$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};
	next;
	}
	my $test = $defaults{$attr}->{'test'};
	if (! &$test($values{$attr})) {
	&Apache::lonxml::warning
	($tag.':'.$attr.': Bad value.'.'Replacing your value with : '
	.$defaults{$attr} );
	$values{$attr} = $defaults{$attr};
	}
	return ;
}	}

	sub write_gnuplot_file {
	my $fh = shift;
	my $gnuplot_input = '';
	# Collect all the colors
	my @Colors;
	push @Colors, $plot{'bgcolor'};
	push @Colors, $plot{'fgcolor'};
	push @Colors, $axis{'color'};
	push @Colors, $axis{'color'};
	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'} . ' ';
	$gnuplot_input .= $plot{'height'} . ' ';
	$gnuplot_input .= "@Colors\n";
	# title, xlabel, ylabel
	{
	$gnuplot_input .<<"ENDLABELS";
	set title $title->{'text'}
	set xlabel $xlabel->{'text'}
	set ylabel $ylabel->{'text'}
	set xrange $axis->{'xmin'}:$axis->{'xmax'}
	set yrange $axis->{'ymin'}:$axis->{'ymax'}
	ENDLABELS
	}
	# Key
	if (defined($key{'pos'})) {
	$gnuplot_input .= 'set key '.$key->{'pos'}.' ';
	$gnuplot_input .= ($key->{'box'} eq 'on' ? 'box ' : 'nobox ');
	if ($key->{'title'} ne '') {
	$gnuplot_input .= 'title "'$key->{'title'}.'"\n';
	} else {
	$gnuplot_input .= '\n';
	}
	} else {
	$gnuplot_input .= 'set nokey\n';
	}
	# axis
	$gnuplot_input .= 'set xrange ['.$axis{'xmin'}.':'.$axis{'xmin'}.']\n';
	$gnuplot_input .= 'set yrange ['.$axis{'ymin'}.':'.$axis{'ymin'}.']\n';
	# labels
	foreach $label (@labels) {
	$gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
	$label->{'x'}.','.$label->{'y'}.'\n';
	}
	# curves
	$gnuplot_input .= 'plot ';
	my $datatext = '';
	foreach $curve (@curves) {
	if (exists($curve->{'function'})) {
	$gnuplot_input.= $curve->{'function'}.' with '.$curve->{'linestyle'};
	} elsif (exists($curve->{'data'})) {
	$gnuplot_input.= '\'-\' with '.$curve->{'linestyle'};
	my @Data = @{$curve->{'data'}};
	for ($i =0; $i<=$#Data; $i++) {
	foreach $dataset (@Data) {
	$datatext .= $dataset[$i] . ' ';
	}
	$datatext .='\n';
	}
	$datatext .='\n';
	}
	}
	$gnuplot_input .= $datatext;
	print $fh $gnuplot_input;
	}

1;	1;
__END__	__END__

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

Removed from v.1.1
changed lines
	Added in v.1.6