--- loncom/homework/grades.pm 2002/10/02 21:24:35 1.53 +++ loncom/homework/grades.pm 2002/10/17 14:35:34 1.57 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # The LON-CAPA Grading handler # -# $Id: grades.pm,v 1.53 2002/10/02 21:24:35 albertel Exp $ +# $Id: grades.pm,v 1.57 2002/10/17 14:35:34 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -40,6 +40,7 @@ use Apache::lonxml; use Apache::lonnet; use Apache::loncommon; use Apache::lonhomework; +use Apache::loncoursedata; use Apache::lonmsg qw(:user_normal_msg); use Apache::Constants qw(:common); @@ -51,7 +52,7 @@ sub getpartlist { my @parts =(); my (@metakeys) = split(/,/,&Apache::lonnet::metadata($url,'keys')); foreach my $key (@metakeys) { - if ( $key =~ m/stores_([0-9]+)_.*/) { + if ( $key =~ m/stores_(\w+)_.*/) { push(@parts,$key); } } @@ -72,13 +73,16 @@ sub get_symb_and_url { 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; } @@ -91,7 +95,7 @@ sub response_type { my %seen = (); my (@partlist,%handgrade); foreach (split(/,/,&Apache::lonnet::metadata($url,'packages'))) { - if (/^\w+response_\d+.*/) { + if (/^\w+response_\w+.*/) { my ($responsetype,$part) = split(/_/,$_,2); my ($partid,$respid) = split(/_/,$part); $handgrade{$part} = $responsetype.':'.($allkeys =~ /parameter_$part\_handgrade/ ? 'yes' : 'no'); @@ -107,62 +111,32 @@ sub response_type { #--- section, ids and fullnames for each user. sub getclasslist { my ($getsec,$hideexpired) = @_; - my $now = time; - my %classlist=&Apache::lonnet::dump('classlist', - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}); - my ($tmp) = keys(%classlist); + my $classlist=&Apache::loncoursedata::get_classlist(); # Bail out if we were unable to get the classlist - return if ($tmp =~ /^(con_lost|error|no_such_host)/i); - - # codes to check for fields in the classlist - # should contain end:start:id:section:fullname - for (keys %classlist) { - my (@fields) = split(/:/,$classlist{$_}); - %classlist = &reformat_classlist(\%classlist) if (scalar(@fields) <= 2); - last; - } - - my (@holdsec,@sections,%allids,%stusec,%fullname); - foreach (keys(%classlist)) { - my ($end,$start,$id,$section,$fullname)=split(/:/,$classlist{$_}); + return if (! defined($classlist)); + # + my %sections; + my %fullnames; + foreach (keys(%$classlist)) { + # the following undefs are for 'domain', and 'username' respectively. + my (undef,undef,$end,$start,$id,$section,$fullname,$status)= + @{$classlist->{$_}}; # still a student? - if (($hideexpired) && ($end) && ($end < $now)) { - next; - } + if (($hideexpired) && ($status ne 'Active')) { + delete ($classlist->{$_}); + next; + } $section = ($section ne '' ? $section : 'no'); - push @holdsec,$section; if ($getsec eq 'all' || $getsec eq $section) { - push (@{ $classlist{$getsec} }, $_); - $allids{$_} =$id; - $stusec{$_} =$section; - $fullname{$_}=$fullname; - } + $sections{$section}++; + $fullnames{$_}=$fullname; + } else { + delete($classlist->{$_}); + } } my %seen = (); - foreach my $item (@holdsec) { - push (@sections, $item) unless $seen{$item}++; - } - return (\%classlist,\@sections,\%allids,\%stusec,\%fullname); -} - -# add id, section and fullname to the classlist.db -# done to maintain backward compatibility with older versions -sub reformat_classlist { - my ($classlist) = shift; - foreach (sort keys(%$classlist)) { - my ($unam,$udom) = split(/:/); - my $section = &Apache::lonnet::usection($udom,$unam,$ENV{'request.course.id'}); - my $fullname = &get_fullname ($unam,$udom); - my %userid = &Apache::lonnet::idrget($udom,($unam)); - $$classlist{$_} = $$classlist{$_}.':'.$userid{$unam}.':'.$section.':'.$fullname; - } - my $putresult = &Apache::lonnet::put - ('classlist',\%$classlist, - $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, - $ENV{'course.'.$ENV{'request.course.id'}.'.num'}); - - return %$classlist; + my @sections = sort(keys(%sections)); + return ($classlist,\@sections,\%fullnames); } #find user domain @@ -263,8 +237,8 @@ sub verifyreceipt { 'Resource: '.$ENV{'form.url'}.'

'."\n"; my ($string,$contents,$matches) = ('','',0); - my ($classlist,$seclist,$ids,$stusec,$fullname) = &getclasslist('all','0'); - + my (undef,undef,$fullname) = &getclasslist('all','0'); + foreach (sort {lc($$fullname{$a}) cmp lc($$fullname{$b}) } keys %$fullname) { my ($uname,$udom)=split(/\:/); if ($receipt eq @@ -365,8 +339,8 @@ LISTJAVASCRIPT my $checklastsub = $ENV{'form.handgrade'} eq 'yes' ? '' : 'checked'; my $gradeTable='
'."\n". - ' View Problem: no '."\n". - ' yes
'."\n". + ' View Problem: no '."\n". + ' yes
'."\n". ' Submissions: '."\n"; if ($ENV{'form.handgrade'} eq 'yes') { $gradeTable.=' handgrade only'."\n"; @@ -389,7 +363,7 @@ LISTJAVASCRIPT 'onClick="javascript:checkSelect(this.form.stuinfo);" '."\n". 'value="'.$viewgrade.'" />'."\n"; - my ($classlist,$seclist,$ids,$stusec,$fullname) = &getclasslist($getsec,'0'); + my (undef,undef,$fullname) = &getclasslist($getsec,'0'); $gradeTable.=''."\n"; $result.= ''."\n"; $ctsparts++; @@ -1664,11 +1654,9 @@ sub viewgrades { my (@parts) = sort(&getpartlist($url)); foreach my $part (@parts) { my $display=&Apache::lonnet::metadata($url,$part.'.display'); - next if ($display =~ /^Number of Attempts/); if (!$display) { $display = &Apache::lonnet::metadata($url,$part.'.name'); } if ($display =~ /^Partial Credit Factor/) { - $_ = $display; - my ($partid) = /.*?(\d+).*/; + my ($partid) = &split_part_type($part); $result.=''."\n"; next; @@ -1680,7 +1668,7 @@ sub viewgrades { #get info for each student #list all the students - with points and grade status - my ($classlist,$seclist,$ids,$stusec,$fullname) = &getclasslist($ENV{'form.section'},'0'); + my (undef,undef,$fullname) = &getclasslist($ENV{'form.section'},'0'); my $ctr = 0; foreach (sort {lc($$fullname{$a}) cmp lc($$fullname{$b}) } keys %$fullname) { my ($uname,$udom) = split(/:/); @@ -1707,30 +1695,36 @@ sub viewstudentgrade { '\')"; TARGET=_self>'.$fullname.''. ''."\n"; foreach my $part (@$parts) { - my ($temp,$part,$type)=split(/_/,$part); + my ($part,$type) = &split_part_type($part); my $score=$record{"resource.$part.$type"}; - next if $type eq 'tries'; if ($type eq 'awarded') { my $pts = $score eq '' ? '' : $score*$$weight{$part}; $result.=''."\n"; + 'GD_'.$uname.'_'.$part.'_awarded_s" value="'.$pts.'" />'."\n"; $result.=''."\n"; } elsif ($type eq 'solved') { my ($status,$foo)=split(/_/,$score,2); $status = 'nothing' if ($status eq ''); - $result.=''."\n"; + $result.=''."\n"; $result.='\n"; + } else { + $result.=''. + "\n"; + $result.=''."\n"; } } $result.=''; @@ -1759,24 +1753,44 @@ sub editgrades { 'ungraded' =>'ungraded_attempted', 'nothing' => '', ); - my ($classlist,$seclist,$ids,$stusec,$fullname) = &getclasslist($ENV{'form.section'},'0'); + my ($classlist,undef,$fullname) = &getclasslist($ENV{'form.section'},'0'); my (@partid); my %weight = (); + my %columns = (); my ($i,$ctr,$count,$rec_update) = (0,0,0,0); + + my (@parts) = sort(&getpartlist($url)); + my $header; while ($ctr < $ENV{'form.totalparts'}) { my $partid = $ENV{'form.partid_'.$ctr}; push @partid,$partid; $weight{$partid} = $ENV{'form.weight_'.$partid}; $ctr++; - $result .= ''; } - $result .= ''; - foreach (@partid) { - $result .= ''. + foreach my $partid (@partid) { + $header .= ''. ''; + $columns{$partid}=2; + foreach my $stores (@parts) { + my ($part,$type) = &split_part_type($stores); + if ($part !~ m/^\Q$partid\E/) { next;} + if ($type eq 'awarded' || $type eq 'solved') { next; } + my $display=&Apache::lonnet::metadata($url,$stores.'.display'); + $display =~ s/\[Part: (\w)+\]//; + $header .= ''. + ''; + $columns{$partid}+=2; + } + } + foreach my $partid (@partid) { + $result .= ''; + } + $result .= ''; + $result .= $header; $result .= ''."\n"; for ($i=0; $i<$ENV{'form.total'}; $i++) { @@ -1784,38 +1798,54 @@ sub editgrades { my %newrecord; my $updateflag = 0; my @userdom = grep /^$user:/,keys %$classlist; - my ($foo,$udom) = split(/:/,$userdom[0]); + my (undef,$udom) = split(/:/,$userdom[0]); $result .= ''; - foreach (@partid) { - my $old_aw = $ENV{'form.GD_'.$user.'_'.$_.'_aw_s'}; - my $old_part = $old_aw eq '' ? '' : $old_aw/$weight{$_}; - my $old_score = $scoreptr{$ENV{'form.GD_'.$user.'_'.$_.'_sv_s'}}; - - my $awarded = $ENV{'form.GD_'.$user.'_'.$_.'_aw'}; - my $partial = $awarded eq '' ? '' : $awarded/$weight{$_}; + my $old_aw = $ENV{'form.GD_'.$user.'_'.$_.'_awarded_s'}; + my $old_part_pcr = $old_aw/($weight{$_} ne '0' ? $weight{$_}:1); + my $old_part = $old_aw eq '' ? '' : $old_part_pcr; + my $old_score = $scoreptr{$ENV{'form.GD_'.$user.'_'.$_.'_solved_s'}}; + + my $awarded = $ENV{'form.GD_'.$user.'_'.$_.'_awarded'}; + my $pcr = $awarded/($weight{$_} ne '0' ? $weight{$_} : 1); + my $partial = $awarded eq '' ? '' : $pcr; my $score; if ($partial eq '') { - $score = $scoreptr{$ENV{'form.GD_'.$user.'_'.$_.'_sv_s'}}; + $score = $scoreptr{$ENV{'form.GD_'.$user.'_'.$_.'_solved_s'}}; } elsif ($partial > 0) { $score = 'correct_by_override'; } elsif ($partial == 0) { $score = 'incorrect_by_override'; } - $score = 'excused' if (($ENV{'form.GD_'.$user.'_'.$_.'_sv'} eq 'excused') && + $score = 'excused' if (($ENV{'form.GD_'.$user.'_'.$_.'_solved'} eq 'excused') && ($score ne 'excused')); $result .= ''. ''; - next if ($old_part eq $partial && $old_score eq $score); - - $updateflag = 1; - $newrecord{'resource.'.$_.'.awarded'} = $partial if $partial ne ''; - $newrecord{'resource.'.$_.'.solved'} = $score; - $rec_update++; + if (!($old_part eq $partial && $old_score eq $score)) { + $updateflag = 1; + $newrecord{'resource.'.$_.'.awarded'} = $partial if $partial ne ''; + $newrecord{'resource.'.$_.'.solved'} = $score; + $rec_update++; + } + + my $partid=$_; + foreach my $stores (@parts) { + my ($part,$type) = &split_part_type($stores); + if ($part !~ m/^\Q$partid\E/) { next;} + if ($type eq 'awarded' || $type eq 'solved') { next; } + my $old_aw = $ENV{'form.GD_'.$user.'_'.$part.'_'.$type.'_s'}; + my $awarded = $ENV{'form.GD_'.$user.'_'.$part.'_'.$type}; + if ($awarded ne '' && $awarded ne $old_aw) { + $newrecord{'resource.'.$part.'.'.$type}= $awarded; + $updateflag=1; + } + $result .= ''. + ''; + } } $result .= ''."\n"; if ($updateflag) { @@ -1831,6 +1861,15 @@ sub editgrades { 'Total number of students = '.$ENV{'form.total'}.'
'; return $title.$msg.$result; } + +sub split_part_type { + my ($partstr) = @_; + my ($temp,@allparts)=split(/_/,$partstr); + my $type=pop(@allparts); + my $part=join('.',@allparts); + return ($part,$type); +} + #------------- end of section for handling grading by section/class --------- # #---------------------------------------------------------------------------- @@ -2132,7 +2171,7 @@ sub gradingmenu { #--- Menu for grading a section or the whole class --- sub view_edit_entire_class_form { my ($symb,$url)=@_; - my ($classlist,$sections) = &getclasslist('all','0'); + my ($classlist,$sections,undef) = &getclasslist('all','0'); my $result.='
'. ''. @@ -836,7 +810,6 @@ sub submission { if ($symb eq '') { $request->print("Unable to handle ambiguous references:$url:."); return ''; } my $last = ($ENV{'form.lastSub'} eq 'last' ? 'last' : ''); $ENV{'form.vProb'} = $ENV{'form.vProb'} ne '' ? $ENV{'form.vProb'} : 'yes'; - my ($classlist,$seclist,$ids,$stusec,$fullname); # header info if ($counter == 0) { @@ -937,49 +910,61 @@ KEYWORDS # If this is handgraded, then check for collaborators my @col_fullnames; + my ($classlist,$fullname); if ($ENV{'form.handgrade'} eq 'yes') { my @col_list; - ($classlist,$seclist,$ids,$stusec,$fullname) = &getclasslist('all','0'); + ($classlist,undef,$fullname) = &getclasslist('all','0'); for (keys (%$handgrade)) { my $ncol = &Apache::lonnet::EXT('resource.'.$_. - '.maxcollaborators',$symb,$udom,$uname); - if ($ncol > 0) { - s/\_/\./g; - if ($record{'resource.'.$_.'.collaborators'} ne '') { - my (@collaborators) = split(/,?\s+/, - $record{'resource.'.$_.'.collaborators'}); - my (@badcollaborators); - if (scalar(@collaborators) != 0) { - $result.='Collaborators: '; - foreach my $collaborator (@collaborators) { - $collaborator = $collaborator =~ /\@|:/ ? - (split(/@|:/,$collaborator))[0] : $collaborator; - next if ($collaborator eq $uname); - if (!grep /^$collaborator:/i,keys %$classlist) { - push @badcollaborators,$collaborator; - next; - } - push @col_list, $collaborator; - my ($lastname,$givenn) = split(/,/,$$fullname{$collaborator.':'.$udom}); - push @col_fullnames, $givenn.' '.$lastname; - $result.=$$fullname{$collaborator.':'.$udom}.'     '; - } - $result.='
'."\n"; - $result.='
'. - 'This student has submitted '. - (scalar (@badcollaborators) > 1 ? '' : 'an'). - ' invalid collaborator'.(scalar (@badcollaborators) > 1 ? 's. ' : '. '). - (join ', ',@badcollaborators).'
' - if (scalar(@badcollaborators) > 0); - - $result.='
'. - 'This student has submitted too many collaborators. Maximum is '. - $ncol.'.
' if (scalar(@collaborators) > $ncol); - $result.=''."\n"; - } - } - } + '.maxcollaborators', + $symb,$udom,$uname); + next if ($ncol <= 0); + s/\_/\./g; + next if ($record{'resource.'.$_.'.collaborators'} eq ''); + my (@collaborators) = split(/,?\s+/, + $record{'resource.'.$_.'.collaborators'}); + my (@badcollaborators); + if (scalar(@collaborators) != 0) { + $result.='Collaborators: '; + foreach my $collaborator (@collaborators) { + my ($co_name,$co_dom) = split /\@|:/,$collaborator; + $co_dom = $udom if (! defined($co_dom)); + next if ($co_name eq $uname && $co_dom eq $udom); + # Doing this grep allows 'fuzzy' specification + my @Matches = grep /^$co_name:$co_dom/i, + keys %$classlist; + if (! scalar(@Matches)) { + push @badcollaborators,$collaborator; + next; + } + push @col_list, @Matches; + foreach (@Matches) { + my ($lastname,$givenn) = split(/,/,$$fullname{$_}); + push @col_fullnames, $givenn.' '.$lastname; + $result.=$$fullname{$_}.'     '; + } + } + $result.='
'."\n"; + if (scalar(@badcollaborators) > 0) { + $result.='\n"; $result.=(($ctr+1)%10 == 0 ? '' : ''); $ctr++; } $result.='
'; + $result.='This student has submitted '; + if (scalar(@badcollaborators) == 1) { + $result .= 'an invalid collaborator'; + } else { + $result .= 'invalid collaborators'; + } + $result .= ': '.join(', ',@badcollaborators); + + } + if (scalar(@collaborators > $ncol)) { + $result .= '
'; + $result .= 'This student has sumbitted too many '. + 'collaborators. Maximum is '.$ncol; + $result .= '
'; + } + $result.=''."\n"; + } } } $request->print($result."\n"); @@ -1189,6 +1174,11 @@ sub keywords_highlight { foreach (@keylist) { $string =~ s/\b$_(\b|\.)/\$styleon$_$styleoff\<\/font\>/gi; } + # This is not really the right place to do this, but I cannot find a + # better one at this time. So here we go - the m in the s:::mg causes + # ^ to match the beginning of a new line. So we replace(???) the beginning + # of the line with
to make things formatted a little better. + $string =~ s:^:
:mg; return $string; } @@ -1297,7 +1287,7 @@ sub processHandGrade { $laststu = $firststu if ($ctr > $ngrade); } - my ($classlist,$seclist,$ids,$stusec,$fullname) = &getclasslist($ENV{'form.section'},'0'); + my (undef,undef,$fullname) = &getclasslist($ENV{'form.section'},'0'); my (@parsedlist,@nextlist); my ($nextflg) = 0; foreach (sort {lc($$fullname{$a}) cmp lc($$fullname{$b}) } keys %$fullname) { @@ -1441,10 +1431,10 @@ sub viewgrades_js { for (i=0;i'.$ctr."
'; $result.= '		 or /'. + $partid.'" size="4" '.'onChange="javascript:writePoint(\''. + $partid.'\','.$weight{$partid}.',\'textval\')" /> /'. $weight{$partid}.' (problem weight)
Score Part '.$partid.'
(weight = '. $weight{$partid}.')		'.$uname.''.$udom.'
Part '.$partid. - ' (Weight = '.$weight{$partid}.')
 Old Score  Old Score  New Score  Old '.$display.'  New '.$display.' Part '.$partid. + ' (Weight = '.$weight{$partid}.')
'.$user.' '. $$fullname{$userdom[0]}.' '.$old_aw.' '.$awarded. ($score eq 'excused' ? $score : '').' '.$old_aw.' '.$awarded.' 
'."\n"; $result.=''."\n";
'."\n"; $result.=' Grade Entire Section or Class