[LON-CAPA-cvs] cvs: loncom / lonr /homework default_homework.lcpm lonr.pm /homework/templates Rnumerical.problem /xml lonxml.pm
www
www@source.lon-capa.org
Tue, 23 Jun 2009 03:01:26 -0000
This is a MIME encoded message
--www1245726086
Content-Type: text/plain
www Tue Jun 23 03:01:26 2009 EDT
Modified files:
/loncom lonr
/loncom/homework default_homework.lcpm lonr.pm
/loncom/homework/templates Rnumerical.problem
/loncom/xml lonxml.pm
Log:
Paul Rubin's interface to R.
Works now. However, it needs additional Perl libraries, which are currently
commented out. Also, an R-package needs to be installed.
--www1245726086
Content-Type: text/plain
Content-Disposition: attachment; filename="www-20090623030126.txt"
Index: loncom/lonr
diff -u loncom/lonr:1.5 loncom/lonr:1.6
--- loncom/lonr:1.5 Sat Apr 18 23:43:47 2009
+++ loncom/lonr Tue Jun 23 03:01:09 2009
@@ -3,7 +3,7 @@
# The LearningOnline Network with CAPA
# Connect to R CAS
#
-# $Id: lonr,v 1.5 2009/04/18 23:43:47 www Exp $
+# $Id: lonr,v 1.6 2009/06/23 03:01:09 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -275,9 +275,9 @@
&status('Accepting connections');
my $client = $server->accept() or last;
&sync($command);
-# print $command ("display2d:false;simp:true;kill(all);\n");
-# &getroutput($command,2);
-# &sync($command);
+ print $command ("library(phpSerialize);\n");
+ &getroutput($command);
+ &sync($command);
my $syntaxerr = 0;
while (my $cmd=<$client>) {
&status('Processing command');
Index: loncom/homework/default_homework.lcpm
diff -u loncom/homework/default_homework.lcpm:1.144 loncom/homework/default_homework.lcpm:1.145
--- loncom/homework/default_homework.lcpm:1.144 Fri Apr 17 01:00:15 2009
+++ loncom/homework/default_homework.lcpm Tue Jun 23 03:01:15 2009
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# used by lonxml::xmlparse() as input variable $safeinit to Apache::run::run()
#
-# $Id: default_homework.lcpm,v 1.144 2009/04/17 01:00:15 www Exp $
+# $Id: default_homework.lcpm,v 1.145 2009/06/23 03:01:15 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -434,16 +434,47 @@
sub cas {
my ($system,$input,$library)=@_;
my $output;
+ my $dump;
if ($system eq 'maxima') {
$output=&maxima_eval($input,$library);
} elsif ($system eq 'R') {
- $output=&r_eval($input,$library);
+ ($output,$dump)=&r_eval($input,$library,0);
} else {
$output='Error: unrecognized CAS';
}
return $output;
}
+sub cas_hashref {
+ my ($system,$input,$library)=@_;
+ if ($system eq 'maxima') {
+ return 'Error: unsupported CAS';
+ } elsif ($system eq 'R') {
+ return &r_eval($input,$library,1);
+ } else {
+ return 'Error: unrecognized CAS';
+ }
+}
+
+#
+# cas_hashref_entry takes a list of indices and gets the entry in a hash generated by Rreturn.
+# Call: cas_hashref_entry(Rvalue, index1, index2, ...) where Rvalue is a hash returned by Rreturn.
+# Rentry will return the first scalar value it encounters (ignoring excess indices).
+# If an invalid key is given, it returns undef.
+#
+sub cas_hashref_entry {
+ return &Rentry(@_);
+}
+
+#
+# cas_hashref_array takes a list of indices and gets a column array from a hash generated by Rreturn.
+# Call: cas_hashref_array(Rvalue, index1, index2, ...) where Rvalue is a hash returned by Rreturn.
+# If an invalid key is given, it returns undef.
+#
+sub cas_hashref_array {
+ return &Rarray(@_);
+}
+
sub tex {
if ( $external::target eq "tex" ) {
return $_[0];
Index: loncom/homework/lonr.pm
diff -u loncom/homework/lonr.pm:1.5 loncom/homework/lonr.pm:1.6
--- loncom/homework/lonr.pm:1.5 Fri Jun 19 14:03:19 2009
+++ loncom/homework/lonr.pm Tue Jun 23 03:01:15 2009
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Interface routines to R CAS
#
-# $Id: lonr.pm,v 1.5 2009/06/19 14:03:19 www Exp $
+# $Id: lonr.pm,v 1.6 2009/06/23 03:01:15 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -33,7 +33,11 @@
use Apache::lonnet;
use Apache::response();
use LONCAPA;
-### Commented out for now: use Tie::IxHash::Easy; # autoties all subhashes to keep index order
+
+### You need to install the libraries below for this to work!
+
+###use Tie::IxHash::Easy; # autoties all subhashes to keep index order
+###use Data::Dumper; # used to output hash contents
my $errormsg='';
@@ -101,82 +105,101 @@
# Rreturn accepts a string containing a serialized R object
# and returns either the object's value (if it is scalar) or a reference
# to a hash containing the contents of the object. Any null keys in the hash
-# are replaced by 'capaNNN' where NNN is the index of the entry in the original
+# are replaced by 'resultNNN' where NNN is the index of the entry in the original
# R array.
#
sub Rreturn {
- my $x = $_[0]; # the string containing the serialized R object(s)
- $errormsg='';
- if ($x =~ /^(?:i|d):(.+?);$/) {
- return $1; # return the value of the number
- } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {
- # string -- verify the length
- if (length($2) eq $1) {
- return $2; # return the string
- } else {
- return 'mismatch in string length';
- }
- } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {
- # array
- my $dim = $1; # array size
- $x = $2; # array contents
- tie(my %h,'Tie::IxHash::Easy'); # start a hash
- keys(%h) = $dim; # allocate space for the hash
- my $key;
- my $y;
- for (my $i = 0; $i < $dim; $i++) {
- ($y, $x) = &Rpeel($x); # strip off the entry for the key
- if ($y eq '') {
- &Rcroak('ran out of keys');
- }
- $key = &Rreturn($y);
- if ($key eq '') {
- $key = "capa$i"; # correct null key
- }
- ($y, $x) = &Rpeel($x); # strip off the value
- if ($y eq '') {
- &Rcroak('ran out of values');
- }
- if ($y =~ /^a:/) {
- $h{$key} = \&Rreturn($y); # array value: store as reference
- } else {
- $h{$key} = &Rreturn($y); # scalar value: store the entry in the hash
- }
- }
- if ($errormsg) { return $errormsg; }
- return \%h; # return a reference to the hash
+ my $x = $_[0]; # the string containing the serialized R object(s)
+ $x=~s/^\"//;
+ $x=~s/\"$//;
+ $x=~s/\\\"/\"/g;
+ $errormsg='';
+ if ($x =~ /^(?:i|d):(.+?);$/) {
+ return $1; # return the value of the number
+ } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {
+ # string -- verify the length
+ if (length($2) eq $1) {
+ return $2; # return the string
+ } else {
+ return 'mismatch in string length';
+ }
+ } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {
+ # array
+ my $dim = $1; # array size
+ $x = $2; # array contents
+ tie(my %h,'Tie::IxHash::Easy'); # start a hash
+ keys(%h) = $dim; # allocate space for the hash
+ my $key;
+ my $y;
+ for (my $i = 0; $i < $dim; $i++) {
+ ($y, $x) = &Rpeel($x); # strip off the entry for the key
+ if ($y eq '') {
+ &Rcroak('ran out of keys');
+ }
+ $key = &Rreturn($y);
+ if ($key eq '') {
+ $key = "result$i"; # correct null key
+ }
+ ($y, $x) = &Rpeel($x); # strip off the value
+ if ($y eq '') {
+ &Rcroak('ran out of values');
+ }
+ if ($y =~ /^a:/) {
+ $h{$key} = \&Rreturn($y); # array value: store as reference
+ } else {
+ $h{$key} = &Rreturn($y); # scalar value: store the entry in the hash
+ }
}
+ if ($errormsg) { return $errormsg; }
+ return \%h; # return a reference to the hash
+ } else {
+ return 'Unrecognized output';
+ }
}
# --- end Rreturn ---
-#
-# Rentry takes a list of indices and gets the entry in a hash generated by Rreturn.
-# Call: Rentry(Rvalue, index1, index2, ...) where Rvalue is a hash returned by Rreturn.
-# Rentry will return the first scalar value it encounters (ignoring excess indices).
-# If an invalid key is given, Rentry returns undef.
-#
sub Rentry {
- my $hash = shift; # pointer to hash
- my $x;
- my $i;
- if (ref($hash) ne 'HASH') {
- &Rcroak('argument to Rentry is not a hash');
- }
- while ($i = shift) {
- if (exists $hash->{$i}) {
- $hash = $hash->{$i};
- } else {
- return undef;
- }
- if (ref($hash) eq 'REF') {
- $hash = $$hash; # dereference one layer
- } elsif (ref($hash) ne 'HASH') {
- return $hash; # drilled down to a scalar
- }
- }
+ my $hash = shift; # pointer to tied hash
+ my $i;
+ if (ref($hash) ne 'HASH') {
+ return 'Argument to cas_hashref_entry is not a hash!';
+ }
+ while ($i = shift) {
+ if (exists($hash->{$i})) {
+ $hash = $hash->{$i};
+ } else {
+ return undef;
+ }
+ if (ref($hash) eq 'REF') {
+ $hash = $$hash; # dereference one layer
+ } elsif (ref($hash) ne 'HASH') {
+ return $hash; # drilled down to a scalar
+ }
+ }
}
-# --- end Rentry ---
+sub Rarray {
+ my $hash = shift; # pointer to tied hash
+ my $i;
+ if (ref($hash) ne 'HASH') {
+ return 'Argument to cas_hashref_array is not a hash!';
+ }
+ while ($i = shift) {
+ if (exists($hash->{$i})) {
+ $hash = $hash->{$i};
+ } else {
+ return undef;
+ }
+ if (ref($hash) eq 'REF') {
+ $hash = $$hash; # dereference one layer
+ }
+ }
+ my @returnarray=();
+ foreach my $key (keys(%{$hash})) {
+ $returnarray[$key-1]=$$hash{$key};
+ }
+ return @returnarray;
+}
sub connect {
return IO::Socket::UNIX->new(Peer => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
@@ -260,6 +283,35 @@
return $reply;
}
+sub runserializedscript {
+ my ($socket,$fullscript,$libraries)=@_;
+ if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
+ my $reply;
+ $fullscript=~s/[\n\r\l]//gs;
+ if ($libraries) {
+ foreach my $library (split(/\s*\,\s*/,$libraries)) {
+ unless ($library=~/\w/) { next; }
+ if (&r_is_allowed_library($library)) {
+ $reply=&rreply($socket,'library('.$library.');'."\n");
+ if ($reply=~/^Error\:/) { return($reply,$reply); }
+ } else {
+ return 'Error: blacklisted';
+ }
+ }
+ }
+ my @actuallines=();
+ foreach my $line (split(/\;/s,$fullscript)) {
+ if ($line=~/\w/) { push (@actuallines,$line); }
+ }
+ for (my $i=0; $i<$#actuallines; $i++) {
+ $reply=&rreply($socket,$actuallines[$i].";\n");
+ if ($reply=~/^Error\:/) { return($reply,$reply); }
+ }
+# The last line needs to be serialized
+ $reply=&Rreturn(&rreply($socket,"phpSerialize($actuallines[-1]);\n"));
+ return($reply,&Dumper($reply));
+}
+
sub r_cas_formula_fix {
my ($expression)=@_;
return &Apache::response::implicit_multiplication($expression);
@@ -288,11 +340,17 @@
}
sub r_eval {
- my ($script,$libraries) = @_;
+ my ($script,$libraries,$hashflag) = @_;
my $socket=&connect();
- my $reply=&runscript($socket,$script,$libraries);
+ my $reply;
+ my $dump='';
+ if ($hashflag) {
+ ($reply,$dump)=&runserializedscript($socket,$script,$libraries);
+ } else {
+ $reply=&runscript($socket,$script,$libraries);
+ }
&disconnect($socket);
- return $reply;
+ return ($reply,$dump);
}
Index: loncom/homework/templates/Rnumerical.problem
diff -u loncom/homework/templates/Rnumerical.problem:1.1 loncom/homework/templates/Rnumerical.problem:1.2
--- loncom/homework/templates/Rnumerical.problem:1.1 Sat Apr 18 23:43:54 2009
+++ loncom/homework/templates/Rnumerical.problem Tue Jun 23 03:01:20 2009
@@ -5,20 +5,21 @@
$offset=&random(2,5,0.1);
$slope=&random(0.6,2.5,0.1);
# construct a data set using R
-$data=&cas('R',"set.seed($seed);x<-1:$n;w<-1+sqrt(x)/2;data.frame(x=x,y=$offset+$slope*x+rnorm(x)*w);");
-# separate into an x and a y vector
-@datatable=split(/\s+/gs,$data);
-for ($i=0;$i<2*$n;$i+=2) {
- push(@x,$datatable[$i]);
- push(@y,$datatable[$i+1]);
-}
+# dump is for debugging, print to screen to see data structure
+($data,$dump)=&cas_hashref('R',"set.seed($seed);x<-1:$n;w<-1+sqrt(x)/2;data.frame(x=x,y=$offset+$slope*x+rnorm(x)*w);");
+@x=&cas_hashref_array($data,'x');
+@y=&cas_hashref_array($data,'y');
$datax=join(',',@x);
$datay=join(',',@y);
# calculate the right answer using R
-($intercept,$slope)=split(/\s+/,&cas('R',"x<-c($datax);y<-c($datay);dataset<-data.frame(x=x,y=y);fm<-lm(y~x,data=dataset);array(coef(fm),dim=2);"));
-$answer="$slope*x+$intercept";
+($answerdata,$dump)=&cas_hashref('R',"x<-c($datax);y<-c($datay);dataset<-data.frame(x=x,y=y);fm<-lm(y~x,data=dataset);");
+$answer=&cas_hashref_entry($answerdata,'coefficients','x').'*x+'.&cas_hashref_entry($answerdata,'coefficients','(Intercept)');
</script>
-<gnuplot width="400" solid="0" plotcolor="monochrome" gridlayer="off" bmargin="default" font="9" alttag="dynamically generated plot" bgcolor="xffffff" texfont="22" transparent="off" plottype="Cartesian" rmargin="default" gridtype="Cartesian" minor_ticscale="0.5" fontface="sans-serif" grid="on" align="right" texwidth="93" height="300" border="on" samples="100" fgcolor="x000000" major_ticscale="1" tmargin="default" lmargin="default" fillstyle="empty">
+
+<startouttext />
+Consider the plotted data set.<br />
+<endouttext />
+<gnuplot width="400" solid="0" plotcolor="monochrome" gridlayer="off" bmargin="default" font="9" alttag="dynamically generated plot" bgcolor="xffffff" texfont="22" transparent="off" plottype="Cartesian" rmargin="default" gridtype="Cartesian" minor_ticscale="0.5" fontface="sans-serif" grid="on" align="left" texwidth="93" height="300" border="on" samples="100" fgcolor="x000000" major_ticscale="1" tmargin="default" lmargin="default" fillstyle="empty">
<curve linestyle="points" linetype="solid" color="x000000" pointtype="3" limit="closed" pointsize="2" linewidth="1">
<data>@x</data>
<data>@y</data>
@@ -27,13 +28,11 @@
</gnuplot>
<startouttext />
-Consider the data set
-<pre>$data</pre>
-
+<br />
Give a linear function approximating the data.<br />
<tt>y(x)=</tt>
<endouttext />
-<formularesponse answer="$answer" samples="x@1:$n#20">
+<formularesponse id="11" answer="$answer" samples="x@1:$n#20">
<responseparam name="tol" default="2%" description="Numerical Tolerance" type="tolerance" />
<textline size="25" readonly="no" />
Index: loncom/xml/lonxml.pm
diff -u loncom/xml/lonxml.pm:1.496 loncom/xml/lonxml.pm:1.497
--- loncom/xml/lonxml.pm:1.496 Thu May 28 17:08:43 2009
+++ loncom/xml/lonxml.pm Tue Jun 23 03:01:26 2009
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# XML Parser Module
#
-# $Id: lonxml.pm,v 1.496 2009/05/28 17:08:43 bisitz Exp $
+# $Id: lonxml.pm,v 1.497 2009/06/23 03:01:26 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -757,6 +757,8 @@
'&maxima_cas_formula_fix');
$safehole->wrap(\&Apache::lonr::r_eval,$safeeval,'&r_eval');
+ $safehole->wrap(\&Apache::lonr::Rentry,$safeeval,'&Rentry');
+ $safehole->wrap(\&Apache::lonr::Rarray,$safeeval,'&Rarray');
$safehole->wrap(\&Apache::lonr::r_check,$safeeval,'&r_check');
$safehole->wrap(\&Apache::lonr::r_cas_formula_fix,$safeeval,
'&r_cas_formula_fix');
--www1245726086--