--- loncom/homework/grades.pm 2002/07/30 19:59:58 1.43
+++ loncom/homework/grades.pm 2004/09/27 20:59:21 1.216
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# The LON-CAPA Grading handler
#
-# $Id: grades.pm,v 1.43 2002/07/30 19:59:58 ng Exp $
+# $Id: grades.pm,v 1.216 2004/09/27 20:59:21 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -25,13 +25,7 @@
#
# http://www.lon-capa.org/
#
-# 2/9,2/13 Guy Albertelli
-# 6/8 Gerd Kortemeyer
-# 7/26 H.K. Ng
-# 8/20 Gerd Kortemeyer
-# Year 2002
-# June, July 2002 H.K. Ng
-#
+###
package Apache::grades;
use strict;
@@ -39,338 +33,1431 @@ use Apache::style;
use Apache::lonxml;
use Apache::lonnet;
use Apache::loncommon;
+use Apache::lonhtmlcommon;
+use Apache::lonnavmaps;
use Apache::lonhomework;
+use Apache::loncoursedata;
use Apache::lonmsg qw(:user_normal_msg);
use Apache::Constants qw(:common);
-#use Time::HiRes qw( gettimeofday tv_interval );
+use Apache::lonlocal;
+use String::Similarity;
-sub moreinfo {
- my ($request,$reason) = @_;
- $request->print("Unable to process request: $reason");
- if ( $Apache::grades::viewgrades eq 'F' ) {
- $request->print('');
- }
- return '';
-}
+my %oldessays=();
+my %perm=();
-sub verifyreceipt {
- my $request=shift;
- my $courseid=$ENV{'request.course.id'};
-# my $cdom=$ENV{"course.$courseid.domain"};
-# my $cnum=$ENV{"course.$courseid.num"};
- my $receipt=unpack("%32C*",$Apache::lonnet::perlvar{'lonHostID'}).'-'.
- $ENV{'form.receipt'};
- $receipt=~s/[^\-\d]//g;
- my $symb=$ENV{'form.symb'};
- unless ($symb) {
- $symb=&Apache::lonnet::symbread($ENV{'form.url'});
+# ----- These first few routines are general use routines.----
+#
+# --- Retrieve the parts from the metadata file.---
+sub getpartlist {
+ my ($url,$symb) = @_;
+ my $partorder = &Apache::lonnet::metadata($url, 'partorder');
+ my @parts;
+ if ($partorder) {
+ for my $part (split (/,/,$partorder)) {
+ if (!&Apache::loncommon::check_if_partid_hidden($part,$symb)) {
+ push(@parts, $part);
+ }
+ }
+ } else {
+ my $metadata = &Apache::lonnet::metadata($url, 'packages');
+ foreach (split(/\,/,$metadata)) {
+ if ($_ =~ /^part_(.*)$/) {
+ if (!&Apache::loncommon::check_if_partid_hidden($1,$symb)) {
+ push(@parts, $1);
+ }
+ }
+ }
}
- if ((&Apache::lonnet::allowed('mgr',$courseid)) && ($symb)) {
- $request->print('
Verifying Submission Receipt '.$receipt.'
');
- my $matches=0;
- my ($classlist) = &getclasslist('all','0');
- foreach my $student ( sort(@{ $$classlist{'all'} }) ) {
- my ($uname,$udom)=split(/\:/,$student);
- if ($receipt eq
- &Apache::lonnet::ireceipt($uname,$udom,$courseid,$symb)) {
- $request->print('Matching '.$student.' ');
- $matches++;
- }
- }
- $request->printf('
'.$matches." match%s
",$matches <= 1 ? '' : 'es');
-# needs to print who is matched
+ my @stores;
+ foreach my $part (@parts) {
+ my (@metakeys) = split(/,/,&Apache::lonnet::metadata($url,'keys'));
+ foreach my $key (@metakeys) {
+ if ($key =~ m/^stores_\Q$part\E_/) { push(@stores,$key); }
+ }
}
- return '';
+ return @stores;
}
-sub student_gradeStatus {
- my ($url,$udom,$uname,$partlist) = @_;
+# --- Get the symbolic name of a problem and the url
+sub get_symb_and_url {
+ my ($request,$silent) = @_;
+ (my $url=$ENV{'form.url'}) =~ s-^http://($ENV{'SERVER_NAME'}|$ENV{'HTTP_HOST'})--;
my $symb=($ENV{'form.symb'} ne '' ? $ENV{'form.symb'} : (&Apache::lonnet::symbread($url)));
- my %record= &Apache::lonnet::restore($symb,$ENV{'request.course.id'},$udom,$uname);
- my %partstatus = ();
- foreach (@$partlist) {
- my ($status,$foo)=split(/_/,$record{"resource.$_.solved"},2);
- $status = 'nothing' if ($status eq '');
- $partstatus{$_} = $status;
- $partstatus{"resource.$_.submitted_by"} = $record{"resource.$_.submitted_by"}
- if ($record{"resource.$_.submitted_by"} ne '');
+ if ($symb eq '') {
+ if (!$silent) {
+ $request->print("Unable to handle ambiguous references:$url:.");
+ return ();
+ }
}
- return %partstatus;
+ return ($symb,$url);
}
+# --- Retrieve the fullname for a user. Return lastname, first middle ---
+# --- Generation is attached next to the lastname if it exists. ---
sub get_fullname {
my ($uname,$udom) = @_;
my %name=&Apache::lonnet::get('environment', ['lastname','generation',
- 'firstname','middlename'],$udom,$uname);
+ 'firstname','middlename'],
+ $udom,$uname);
my $fullname;
my ($tmp) = keys(%name);
if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
- $fullname=$name{'lastname'}.$name{'generation'};
- if ($fullname =~ /[^\s]+/) { $fullname.=', '; }
- $fullname.=$name{'firstname'}.' '.$name{'middlename'};
+ $fullname = &Apache::loncoursedata::ProcessFullName
+ (@name{qw/lastname generation firstname middlename/});
+ } else {
+ &Apache::lonnet::logthis('grades.pm: no name data for '.$uname.
+ '@'.$udom.':'.$tmp);
}
return $fullname;
}
+#--- Format fullname, username:domain if different for display
+#--- Use anywhere where the student names are listed
+sub nameUserString {
+ my ($type,$fullname,$uname,$udom) = @_;
+ if ($type eq 'header') {
+ return ' Fullname (Username) ';
+ } else {
+ return ' '.$fullname.' ('.$uname.
+ ($ENV{'user.domain'} eq $udom ? '' : ' ('.$udom.')').')';
+ }
+}
+
+#--- Get the partlist and the response type for a given problem. ---
+#--- Indicate if a response type is coded handgraded or not. ---
sub response_type {
- my ($url) = shift;
+ my ($url,$symb) = shift;
+ $symb=($ENV{'form.symb'} ne '' ? $ENV{'form.symb'} : (&Apache::lonnet::symbread($url))) if ($symb eq '');
my $allkeys = &Apache::lonnet::metadata($url,'keys');
-# print "allkeys=>$allkeys ";
+ my %vPart;
+ foreach my $partid (&Apache::loncommon::get_env_multiple('form.vPart')) {
+ $vPart{$partid}=1;
+ }
my %seen = ();
- my (@partlist,%handgrade);
+ my (@partlist,%handgrade,%responseType);
foreach (split(/,/,&Apache::lonnet::metadata($url,'packages'))) {
- if (/^\w+response_\d+.*/) {
+ if (/^\w+response_.*/) {
my ($responsetype,$part) = split(/_/,$_,2);
my ($partid,$respid) = split(/_/,$part);
- $handgrade{$part} = $responsetype.':'.($allkeys =~ /parameter_$part\_handgrade/ ? 'yes' : 'no');
+ if (&Apache::loncommon::check_if_partid_hidden($partid,$symb)) {
+ next;
+ }
+ if (%vPart && !exists($vPart{$partid})) {
+ next;
+ }
+ $responsetype =~ s/response$//; # make it compatible w/ navmaps - should move to that!!
+ my ($value) = &Apache::lonnet::EXT('resource.'.$part.'.handgrade',$symb);
+ $handgrade{$part} = ($value eq 'yes' ? 'yes' : 'no');
+ if (!exists($responseType{$partid})) { $responseType{$partid}={}; }
+ $responseType{$partid}->{$respid}=$responsetype;
next if ($seen{$partid} > 0);
$seen{$partid}++;
push @partlist,$partid;
}
}
- return \@partlist,\%handgrade;
+ return \@partlist,\%handgrade,\%responseType;
}
+sub get_display_part {
+ my ($partID,$url,$symb)=@_;
+ if (!defined($symb) || $symb eq '') {
+ $symb=$ENV{'form.symb'};
+ if ($symb eq '') { $symb=&Apache::lonnet::symbread($url) }
+ }
+ my $display=&Apache::lonnet::EXT('resource.'.$partID.'.display',$symb);
+ if (defined($display) and $display ne '') {
+ $display.= " (id $partID)";
+ } else {
+ $display=$partID;
+ }
+ return $display;
+}
+#--- Show resource title
+#--- and parts and response type
+sub showResourceInfo {
+ my ($url,$probTitle,$checkboxes) = @_;
+ my $col=3;
+ if ($checkboxes) { $col=4; }
+ my $result ='
'.
+ '
'.&mt('Current Resource').': '.
+ $probTitle.'
'."\n";
+ my ($partlist,$handgrade,$responseType) = &response_type($url);
+ my %resptype = ();
+ my $hdgrade='no';
+ my %partsseen;
+ for my $part_resID (sort keys(%$handgrade)) {
+ my $handgrade=$$handgrade{$part_resID};
+ my ($partID,$resID) = split(/_/,$part_resID);
+ my $responsetype = $responseType->{$partID}->{$resID};
+ $hdgrade = $handgrade if ($handgrade eq 'yes');
+ $result.='
';
+ if ($checkboxes) {
+ if (exists($partsseen{$partID})) {
+ $result.="
'."\n";
+ return $result,$responseType,$hdgrade,$partlist,$handgrade;
+}
+
+
+sub get_order {
+ my ($partid,$respid,$symb,$uname,$udom)=@_;
+ my (undef,undef,$url)=&Apache::lonnet::decode_symb($symb);
+ $url=&Apache::lonnet::clutter($url);
+ my $subresult=&Apache::lonnet::ssi($url,
+ ('grade_target' => 'analyze'),
+ ('grade_domain' => $udom),
+ ('grade_symb' => $symb),
+ ('grade_courseid' =>
+ $ENV{'request.course.id'}),
+ ('grade_username' => $uname));
+ (undef,$subresult)=split(/_HASH_REF__/,$subresult,2);
+ my %analyze=&Apache::lonnet::str2hash($subresult);
+ return ($analyze{"$partid.$respid.shown"});
+}
+#--- Clean response type for display
+#--- Currently filters option/rank/radiobutton/match/essay response types only.
+sub cleanRecord {
+ my ($answer,$response,$symb,$partid,$respid,$record,$order,$version) = @_;
+ my $grayFont = '';
+ if ($response =~ /^(option|rank)$/) {
+ my %answer=&Apache::lonnet::str2hash($answer);
+ my %grading=&Apache::lonnet::str2hash($record->{$version."resource.$partid.$respid.submissiongrading"});
+ my ($toprow,$bottomrow);
+ foreach my $foil (@$order) {
+ if ($grading{$foil} == 1) {
+ $toprow.='
'.$answer{$foil}.'
';
+ } else {
+ $toprow.='
'.$answer{$foil}.'
';
+ }
+ $bottomrow.='
'.$grayFont.$foil.'
';
+ }
+ return '
'.
+ '
Answer
'.$toprow.'
'.
+ '
'.$grayFont.'Option ID
'.
+ $grayFont.$bottomrow.'
'.'
';
+ } elsif ($response eq 'match') {
+ my %answer=&Apache::lonnet::str2hash($answer);
+ my %grading=&Apache::lonnet::str2hash($record->{$version."resource.$partid.$respid.submissiongrading"});
+ my @items=&Apache::lonnet::str2array($record->{$version."resource.$partid.$respid.submissionitems"});
+ my ($toprow,$middlerow,$bottomrow);
+ foreach my $foil (@$order) {
+ my $item=shift(@items);
+ if ($grading{$foil} == 1) {
+ $toprow.='
'.$item.'
';
+ $middlerow.='
'.$grayFont.$answer{$foil}.'
';
+ } else {
+ $toprow.='
'.$item.'
';
+ $middlerow.='
'.$grayFont.$answer{$foil}.'
';
+ }
+ $bottomrow.='
'.$grayFont.$foil.'
';
+ }
+ return '
'.
+ '
Answer
'.$toprow.'
'.
+ '
'.$grayFont.'Item ID
'.
+ $middlerow.'
'.
+ '
'.$grayFont.'Option ID
'.
+ $bottomrow.'
'.'
';
+ } elsif ($response eq 'radiobutton') {
+ my %answer=&Apache::lonnet::str2hash($answer);
+ my ($toprow,$bottomrow);
+ my $correct=($order->[0])+1;
+ for (my $i=1;$i<=$#$order;$i++) {
+ my $foil=$order->[$i];
+ if (exists($answer{$foil})) {
+ if ($i == $correct) {
+ $toprow.='
true
';
+ } else {
+ $toprow.='
true
';
+ }
+ } else {
+ $toprow.='
false
';
+ }
+ $bottomrow.='
'.$grayFont.$foil.'
';
+ }
+ return '
'.
+ '
Answer
'.$toprow.'
'.
+ '
'.$grayFont.'Option ID
'.
+ $grayFont.$bottomrow.'
'.'
';
+ } elsif ($response eq 'essay') {
+ if (! exists ($ENV{'form.'.$symb})) {
+ my (%keyhash) = &Apache::lonnet::dump('nohist_handgrade',
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'});
+
+ my $loginuser = $ENV{'user.name'}.':'.$ENV{'user.domain'};
+ $ENV{'form.keywords'} = $keyhash{$symb.'_keywords'} ne '' ? $keyhash{$symb.'_keywords'} : '';
+ $ENV{'form.kwclr'} = $keyhash{$loginuser.'_kwclr'} ne '' ? $keyhash{$loginuser.'_kwclr'} : 'red';
+ $ENV{'form.kwsize'} = $keyhash{$loginuser.'_kwsize'} ne '' ? $keyhash{$loginuser.'_kwsize'} : '0';
+ $ENV{'form.kwstyle'} = $keyhash{$loginuser.'_kwstyle'} ne '' ? $keyhash{$loginuser.'_kwstyle'} : '';
+ $ENV{'form.'.$symb} = 1; # so that we don't have to read it from disk for multiple sub of the same prob.
+ }
+ $answer =~ s-\n- -g;
+ return '
'.&keywords_highlight($answer).'
';
+ }
+ return $answer;
+}
+
+#-- A couple of common js functions
+sub commonJSfunctions {
+ my $request = shift;
+ $request->print(<
+ function radioSelection(radioButton) {
+ var selection=null;
+ if (radioButton.length > 1) {
+ for (var i=0; i 1) {
+ for (var i=0; i
+COMMONJSFUNCTIONS
+}
+
+#--- Dumps the class list with usernames,list of sections,
+#--- section, ids and fullnames for each user.
+sub getclasslist {
+ my ($getsec,$filterlist) = @_;
+ $getsec = $getsec eq '' ? 'all' : $getsec;
+ my $classlist=&Apache::loncoursedata::get_classlist();
+ # Bail out if we were unable to get the classlist
+ return if (! defined($classlist));
+ #
+ my %sections;
+ my %fullnames;
+ foreach my $student (keys(%$classlist)) {
+ my $end =
+ $classlist->{$student}->[&Apache::loncoursedata::CL_END()];
+ my $start =
+ $classlist->{$student}->[&Apache::loncoursedata::CL_START()];
+ my $id =
+ $classlist->{$student}->[&Apache::loncoursedata::CL_ID()];
+ my $section =
+ $classlist->{$student}->[&Apache::loncoursedata::CL_SECTION()];
+ my $fullname =
+ $classlist->{$student}->[&Apache::loncoursedata::CL_FULLNAME()];
+ my $status =
+ $classlist->{$student}->[&Apache::loncoursedata::CL_STATUS()];
+ # filter students according to status selected
+ if ($filterlist && $ENV{'form.Status'} ne 'Any') {
+ if ($ENV{'form.Status'} ne $status) {
+ delete ($classlist->{$student});
+ next;
+ }
+ }
+ $section = ($section ne '' ? $section : 'none');
+ if (&canview($section)) {
+ if ($getsec eq 'all' || $getsec eq $section) {
+ $sections{$section}++;
+ $fullnames{$student}=$fullname;
+ } else {
+ delete($classlist->{$student});
+ }
+ } else {
+ delete($classlist->{$student});
+ }
+ }
+ my %seen = ();
+ my @sections = sort(keys(%sections));
+ return ($classlist,\@sections,\%fullnames);
+}
+
+sub canmodify {
+ my ($sec)=@_;
+ if ($perm{'mgr'}) {
+ if (!defined($perm{'mgr_section'})) {
+ # can modify whole class
+ return 1;
+ } else {
+ if ($sec eq $perm{'mgr_section'}) {
+ #can modify the requested section
+ return 1;
+ } else {
+ # can't modify the request section
+ return 0;
+ }
+ }
+ }
+ #can't modify
+ return 0;
+}
+
+sub canview {
+ my ($sec)=@_;
+ if ($perm{'vgr'}) {
+ if (!defined($perm{'vgr_section'})) {
+ # can modify whole class
+ return 1;
+ } else {
+ if ($sec eq $perm{'vgr_section'}) {
+ #can modify the requested section
+ return 1;
+ } else {
+ # can't modify the request section
+ return 0;
+ }
+ }
+ }
+ #can't modify
+ return 0;
+}
+
+#--- Retrieve the grade status of a student for all the parts
+sub student_gradeStatus {
+ my ($url,$symb,$udom,$uname,$partlist) = @_;
+ my %record = &Apache::lonnet::restore($symb,$ENV{'request.course.id'},$udom,$uname);
+ my %partstatus = ();
+ foreach (@$partlist) {
+ my ($status,undef) = split(/_/,$record{"resource.$_.solved"},2);
+ $status = 'nothing' if ($status eq '');
+ $partstatus{$_} = $status;
+ my $subkey = "resource.$_.submitted_by";
+ $partstatus{$subkey} = $record{$subkey} if ($record{$subkey} ne '');
+ }
+ return %partstatus;
+}
+
+# hidden form and javascript that calls the form
+# Use by verifyscript and viewgrades
+# Shows a student's view of problem and submission
+sub jscriptNform {
+ my ($url,$symb) = @_;
+ my $jscript=''."\n";
+ $jscript.= ''."\n";
+ return $jscript;
+}
+
+#------------------ End of general use routines --------------------
+
+#
+# Find most similar essay
+#
+
+sub most_similar {
+ my ($uname,$udom,$uessay)=@_;
+
+# ignore spaces and punctuation
+
+ $uessay=~s/\W+/ /gs;
+
+# these will be returned. Do not care if not at least 50 percent similar
+ my $limit=0.6;
+ my $sname='';
+ my $sdom='';
+ my $scrsid='';
+ my $sessay='';
+# go through all essays ...
+ foreach my $tkey (keys %oldessays) {
+ my ($tname,$tdom,$tcrsid)=split(/\./,$tkey);
+# ... except the same student
+ if (($tname ne $uname) || ($tdom ne $udom)) {
+ my $tessay=$oldessays{$tkey};
+ $tessay=~s/\W+/ /gs;
+# String similarity gives up if not even limit
+ my $tsimilar=&String::Similarity::similarity($uessay,$tessay,$limit);
+# Found one
+ if ($tsimilar>$limit) {
+ $limit=$tsimilar;
+ $sname=$tname;
+ $sdom=$tdom;
+ $scrsid=$tcrsid;
+ $sessay=$oldessays{$tkey};
+ }
+ }
+ }
+ if ($limit>0.6) {
+ return ($sname,$sdom,$scrsid,$sessay,$limit);
+ } else {
+ return ('','','','',0);
+ }
+}
+
+#-------------------------------------------------------------------
+
+#------------------------------------ Receipt Verification Routines
+#
+#--- Check whether a receipt number is valid.---
+sub verifyreceipt {
+ my $request = shift;
+
+ my $courseid = $ENV{'request.course.id'};
+ my $receipt = &Apache::lonnet::recprefix($courseid).'-'.
+ $ENV{'form.receipt'};
+ $receipt =~ s/[^\-\d]//g;
+ my $url = $ENV{'form.url'};
+ my $symb = $ENV{'form.symb'};
+ unless ($symb) {
+ $symb = &Apache::lonnet::symbread($url);
+ }
+
+ my $title.='
.
+ '/check.gif){kind=small}
';
+
+ my $wgt = &Apache::lonnet::EXT('resource.'.$partid.'.weight',$symb,$udom,$uname);
+ my $wgtmsg = ($wgt > 0 ? '(problem weight)' :
+ 'problem weight assigned by computer');
+ $wgt = ($wgt > 0 ? $wgt : '1');
+ my $score = ($$record{'resource.'.$partid.'.awarded'} eq '' ?
+ '' : $$record{'resource.'.$partid.'.awarded'}*$wgt);
+ my $result=''."\n";
+
+ my $display_part=&get_display_part($partid,undef,$symb);
+ $result.='.
+ '/mailbkgrd.gif){kind=small}
'."\n".
+ '