--- loncom/homework/grades.pm 2008/12/22 15:13:45 1.528.2.3 +++ loncom/homework/grades.pm 2008/12/24 12:33:28 1.528.2.5 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # The LON-CAPA Grading handler # -# $Id: grades.pm,v 1.528.2.3 2008/12/22 15:13:45 raeburn Exp $ +# $Id: grades.pm,v 1.528.2.5 2008/12/24 12:33:28 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -7333,20 +7333,84 @@ sub scantron_get_maxbubble { my $response_number = 0; my $bubble_line = 0; foreach my $resource (@resources) { - my $symb = $resource->symb(); + my ($analysis,$parts) = &scantron_partids_tograde($resource,$cid,$uname,$udom); + if ((ref($analysis) eq 'HASH') && (ref($parts) eq 'ARRAY')) { + foreach my $part_id (@{$parts}) { + + my $lines; + + # TODO - make this a persistent hash not an array. + + # optionresponse, matchresponse and rankresponse type items + # render as separate sub-questions in exam mode. + if (($analysis->{$part_id.'.type'} eq 'optionresponse') || + ($analysis->{$part_id.'.type'} eq 'matchresponse') || + ($analysis->{$part_id.'.type'} eq 'rankresponse')) { + my ($numbub,$numshown); + if ($analysis->{$part_id.'.type'} eq 'optionresponse') { + if (ref($analysis->{$part_id.'.options'}) eq 'ARRAY') { + $numbub = scalar(@{$analysis->{$part_id.'.options'}}); + } + } elsif ($analysis->{$part_id.'.type'} eq 'matchresponse') { + if (ref($analysis->{$part_id.'.items'}) eq 'ARRAY') { + $numbub = scalar(@{$analysis->{$part_id.'.items'}}); + } + } elsif ($analysis->{$part_id.'.type'} eq 'rankresponse') { + if (ref($analysis->{$part_id.'.foils'}) eq 'ARRAY') { + $numbub = scalar(@{$analysis->{$part_id.'.foils'}}); + } + } + if (ref($analysis->{$part_id.'.shown'}) eq 'ARRAY') { + $numshown = scalar(@{$analysis->{$part_id.'.shown'}}); + } + my $bubbles_per_line = 10; + my $inner_bubble_lines = int($numbub/$bubbles_per_line); + if (($numbub % $bubbles_per_line) != 0) { + $inner_bubble_lines++; + } + for (my $i=0; $i<$numshown; $i++) { + $subdivided_bubble_lines{$response_number} .= + $inner_bubble_lines.','; + } + $subdivided_bubble_lines{$response_number} =~ s/,$//; + $lines = $numshown * $inner_bubble_lines; + } else { + $lines = $analysis->{"$part_id.bubble_lines"}; + } + + $first_bubble_line{$response_number} = $bubble_line; + $bubble_lines_per_response{$response_number} = $lines; + $responsetype_per_response{$response_number} = + $analysis->{$part_id.'.type'}; + $response_number++; + + $bubble_line += $lines; + $total_lines += $lines; + } + } + } + &Apache::lonnet::delenv('scantron\.'); + + &save_bubble_lines(); + $env{'form.scantron_maxbubble'} = + $total_lines; + return $env{'form.scantron_maxbubble'}; +} - my @parts; +sub scantron_partids_tograde { + my ($resource,$cid,$uname,$udom) = @_; + my (%analysis,@parts); + if (ref($resource)) { + my $symb = $resource->symb(); my $result=&ssi_with_retries($resource->src(), $ssi_retries, ('symb' => $symb, 'grade_target' => 'analyze', 'grade_courseid' => $cid, 'grade_domain' => $udom, 'grade_username' => $uname)); - my (undef, $an) = - split(/_HASH_REF__/,$result, 2); - - my %analysis = &Apache::lonnet::str2hash($an); + my (undef, $an) = split(/_HASH_REF__/,$result, 2); + %analysis = &Apache::lonnet::str2hash($an); if (ref($analysis{'parts'}) eq 'ARRAY') { foreach my $part (@{$analysis{'parts'}}) { @@ -7356,66 +7420,8 @@ sub scantron_get_maxbubble { } } } - - foreach my $part_id (@parts) { - my $lines; - - # TODO - make this a persistent hash not an array. - - # optionresponse, matchresponse and rankresponse type items - # render as separate sub-questions in exam mode. - if (($analysis{$part_id.'.type'} eq 'optionresponse') || - ($analysis{$part_id.'.type'} eq 'matchresponse') || - ($analysis{$part_id.'.type'} eq 'rankresponse')) { - my ($numbub,$numshown); - if ($analysis{$part_id.'.type'} eq 'optionresponse') { - if (ref($analysis{$part_id.'.options'}) eq 'ARRAY') { - $numbub = scalar(@{$analysis{$part_id.'.options'}}); - } - } elsif ($analysis{$part_id.'.type'} eq 'matchresponse') { - if (ref($analysis{$part_id.'.items'}) eq 'ARRAY') { - $numbub = scalar(@{$analysis{$part_id.'.items'}}); - } - } elsif ($analysis{$part_id.'.type'} eq 'rankresponse') { - if (ref($analysis{$part_id.'.foils'}) eq 'ARRAY') { - $numbub = scalar(@{$analysis{$part_id.'.foils'}}); - } - } - if (ref($analysis{$part_id.'.shown'}) eq 'ARRAY') { - $numshown = scalar(@{$analysis{$part_id.'.shown'}}); - } - my $bubbles_per_line = 10; - my $inner_bubble_lines = int($numbub/$bubbles_per_line); - if (($numbub % $bubbles_per_line) != 0) { - $inner_bubble_lines++; - } - for (my $i=0; $i<$numshown; $i++) { - $subdivided_bubble_lines{$response_number} .= - $inner_bubble_lines.','; - } - $subdivided_bubble_lines{$response_number} =~ s/,$//; - $lines = $numshown * $inner_bubble_lines; - } else { - $lines = $analysis{"$part_id.bubble_lines"}; - } - - $first_bubble_line{$response_number} = $bubble_line; - $bubble_lines_per_response{$response_number} = $lines; - $responsetype_per_response{$response_number} = - $analysis{$part_id.'.type'}; - $response_number++; - - $bubble_line += $lines; - $total_lines += $lines; - } - } - &Apache::lonnet::delenv('scantron\.'); - - &save_bubble_lines(); - $env{'form.scantron_maxbubble'} = - $total_lines; - return $env{'form.scantron_maxbubble'}; + return (\%analysis,\@parts); } =pod @@ -7522,6 +7528,14 @@ sub scantron_process_students { my $navmap=Apache::lonnavmaps::navmap->new(); my $map=$navmap->getResourceByUrl($sequence); my @resources=$navmap->retrieveResources($map,\&scantron_filter,1,0); + + my ($uname,$udom,%partids_by_symb); + foreach my $resource (@resources) { + my $ressymb = $resource->symb(); + my ($analysis,$parts) = + &scantron_partids_tograde($resource,$env{'request.course.id'},$uname,$udom); + $partids_by_symb{$ressymb} = $parts; + } # $r->print("geto ".scalar(@resources)."
"); my $result= < @@ -7531,7 +7545,7 @@ SCANTRONFORM $r->print($result); my @delayqueue; - my %completedstudents; + my (%completedstudents,,%scandata); my $lock=&Apache::lonnet::set_lock(&mt('Grading bubblesheet exam')); my $count=&get_todo_count($scanlines,$scan_data); @@ -7540,9 +7554,10 @@ SCANTRONFORM 'inline',undef,'scantronupload'); &Apache::lonhtmlcommon::Update_PrgWin($r,\%prog_state, 'Processing first student'); + $r->print('
'); my $start=&Time::HiRes::time(); my $i=-1; - my ($uname,$udom,$started); + my $started; &scantron_get_maxbubble(); # Need the bubble lines array to parse. @@ -7558,6 +7573,9 @@ SCANTRONFORM return ''; # Dunno why the other returns return '' rather than just returning. } + my %lettdig = &letter_to_digits(); + my $numletts = scalar(keys(%lettdig)); + while ($i<$scanlines->{'count'}) { ($uname,$udom)=('',''); $i++; @@ -7589,36 +7607,80 @@ SCANTRONFORM if (&scantron_clear_skip($scanlines,$scan_data,$i)) { &scantron_putfile($scanlines,$scan_data); } - - my $i=0; - foreach my $resource (@resources) { - $i++; - my %form=('submitted' =>'scantron', - 'grade_target' =>'grade', - 'grade_username'=>$uname, - 'grade_domain' =>$udom, - 'grade_courseid'=>$env{'request.course.id'}, - 'grade_symb' =>$resource->symb()); - if (exists($scan_record->{'scantron.CODE'}) - && - &Apache::lonnet::validCODE($scan_record->{'scantron.CODE'})) { - $form{'CODE'}=$scan_record->{'scantron.CODE'}; - } else { - $form{'CODE'}=''; - } - my $result=&ssi_with_retries($resource->src(), $ssi_retries, %form); - if ($ssi_error) { - $ssi_error = 0; # So end of handler error message does not trigger. - $r->print(""); - &ssi_print_error($r); - $r->print(&show_grading_menu_form($symb)); - &Apache::lonnet::remove_lock($lock); - return ''; # Why return ''? Beats me. - } - if (&Apache::loncommon::connection_aborted($r)) { last; } - } + my $scancode; + if ((exists($scan_record->{'scantron.CODE'})) && + (&Apache::lonnet::validCODE($scan_record->{'scantron.CODE'}))) { + $scancode = $scan_record->{'scantron.CODE'}; + } else { + $scancode = ''; + } + + if (&grade_student_bubbles($r,$uname,$udom,$scan_record,$scancode, + @resources) eq 'ssi_error') { + $ssi_error = 0; # So end of handler error message does not trigger. + $r->print(""); + &ssi_print_error($r); + $r->print(&show_grading_menu_form($symb)); + &Apache::lonnet::remove_lock($lock); + return ''; # Why return ''? Beats me. + } + $completedstudents{$uname}={'line'=>$line}; + if ($env{'form.verifyrecord'}) { + my $lastpos = $env{'form.scantron_maxbubble'}*$scantron_config{'Qlength'}; + my $studentdata = substr($line,$scantron_config{'Qstart'}-1,$lastpos); + chomp($studentdata); + $studentdata =~ s/\r$//; + my $studentrecord = ''; + my $counter = -1; + foreach my $resource (@resources) { + ($counter,my $recording) = + &verify_scantron_grading($resource,$udom,$uname,$env{'request.course.id'}, + $counter,$studentdata,\%partids_by_symb, + \%scantron_config,\%lettdig,$numletts); + $studentrecord .= $recording; + } + if ($studentrecord ne $studentdata) { + $counter = -1; + $studentrecord = ''; + foreach my $resource (@resources) { + ($counter,my $recording) = + &verify_scantron_grading($resource,$udom,$uname,$env{'request.course.id'}, + $counter,$studentdata,\%partids_by_symb, + \%scantron_config,\%lettdig,$numletts); + $studentrecord .= $recording; + } + if ($studentrecord ne $studentdata) { + $r->print('

'); + if ($scancode eq '') { + $r->print(&mt('Mismatch grading bubble sheet for user: [_1] with ID: [_2].', + $uname.':'.$udom,$scan_record->{'scantron.ID'})); + } else { + $r->print(&mt('Mismatch grading bubble sheet for user: [_1] with ID: [_2] and CODE: [_3].', + $uname.':'.$udom,$scan_record->{'scantron.ID'},$scancode)); + } + $r->print('
'.&Apache::loncommon::start_data_table()."\n". + &Apache::loncommon::start_data_table_header_row()."\n". + ''.&mt('Source').''.&mt('Bubbled responses').''. + &Apache::loncommon::end_data_table_header_row()."\n". + &Apache::loncommon::start_data_table_row(). + ''.&mt('Bubble Sheet').''. + ''.$studentdata.''. + &Apache::loncommon::end_data_table_row(). + &Apache::loncommon::start_data_table_row(). + 'Stored submissions'. + ''.$studentrecord.''."\n". + &Apache::loncommon::end_data_table_row(). + &Apache::loncommon::end_data_table().'

'); + } else { + $r->print('
'. + &mt('A second grading pass was needed for user: [_1] with ID: [_2], because a mismatch was seen on the first pass.',$uname.':'.$udom,$scan_record->{'scantron.ID'}).'
'. + &mt("As a consequence, this user's submission history records two tries."). + '
'); + } + } + } if (&Apache::loncommon::connection_aborted($r)) { last; } } continue { &Apache::lonxml::clear_problem_counter(); @@ -7634,6 +7696,23 @@ SCANTRONFORM return ''; } +sub grade_student_bubbles { + my ($r,$uname,$udom,$scan_record,$scancode,@resources) = @_; + foreach my $resource (@resources) { + my %form = ('submitted' => 'scantron', + 'grade_target' => 'grade', + 'grade_username'=> $uname, + 'grade_domain' => $udom, + 'grade_courseid'=> $env{'request.course.id'}, + 'grade_symb' => $resource->symb(), + 'code' => $scancode); + my $result=&ssi_with_retries($resource->src(),$ssi_retries,%form); + return 'ssi_error' if ($ssi_error); + last if (&Apache::loncommon::connection_aborted($r)); + } + return; +} + =pod =item scantron_upload_scantron_data @@ -7822,18 +7901,7 @@ sub checkscantron_results { if (!$symb) {return '';} my $grading_menu_button=&show_grading_menu_form($symb); my $cid = $env{'request.course.id'}; - my %lettdig = ( - A => 1, - B => 2, - C => 3, - D => 4, - E => 5, - F => 6, - G => 7, - H => 8, - I => 9, - J => 0, - ); + my %lettdig = &letter_to_digits(); my $numletts = scalar(keys(%lettdig)); my $cnum = $env{'course.'.$cid.'.num'}; my $cdom = $env{'course.'.$cid.'.domain'}; @@ -7847,6 +7915,13 @@ sub checkscantron_results { my $navmap=Apache::lonnavmaps::navmap->new(); my $map=$navmap->getResourceByUrl($sequence); my @resources=$navmap->retrieveResources($map,undef,1,0); + my ($uname,$udom,%partids_by_symb); + foreach my $resource (@resources) { + my $ressymb = $resource->symb(); + my ($analysis,$parts) = + &scantron_partids_tograde($resource,$env{'request.course.id'},$uname,$udom); + $partids_by_symb{$ressymb} = $parts; + } my (%scandata,%lastname,%bylast); $r->print('
'."\n"); @@ -7900,126 +7975,12 @@ sub checkscantron_results { $scandata{$pid} =~ s/\r$//; ($username,$domain)=split(/:/,$uname); my $counter = -1; - my (%expected,%startpos); foreach my $resource (@resources) { - next if (!$resource->is_problem()); - my $symb = $resource->symb(); - my $partsref = $resource->parts(); - my @parts; - my @part_ids = (); - if (ref($partsref) eq 'ARRAY') { - @parts = @{$partsref}; - foreach my $part (@parts) { - my @resp_ids = $resource->responseIds($part); - foreach my $resp (@resp_ids) { - $counter ++; - my $part_id = $part.'.'.$resp; - $expected{$part_id} = 0; - push(@part_ids,$part_id); - if ($env{"form.scantron.sub_bubblelines.$counter"}) { - my @sub_lines = split(/,/,$env{"form.scantron.sub_bubblelines.$counter"}); - foreach my $item (@sub_lines) { - $expected{$part_id} += $item; - } - } else { - $expected{$part_id} = $env{"form.scantron.bubblelines.$counter"}; - } - $startpos{$part_id} = $env{"form.scantron.first_bubble_line.$counter"}; - } - } - } - if ($symb) { - my %recorded; - my (%returnhash) = - &Apache::lonnet::restore($symb,$cid,$domain,$username); - if ($returnhash{'version'}) { - my %lasthash=(); - my $version; - for ($version=1;$version<=$returnhash{'version'};$version++) { - foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) { - $lasthash{$key}=$returnhash{$version.':'.$key}; - } - } - foreach my $key (keys(%lasthash)) { - if ($key =~ /\.scantron$/) { - my $value = &unescape($lasthash{$key}); - my ($part_id) = ($key =~ /^resource\.(.+)\.scantron$/); - if ($value eq '') { - for (my $i=0; $i<$expected{$part_id}; $i++) { - for (my $j=0; $j<$scantron_config{'length'}; $j++) { - $recorded{$part_id} .= $; - } - } - } else { - my @tocheck; - my @items = split(//,$value); - if (($scantron_config{'Qon'} eq 'letter') || - ($scantron_config{'Qon'} eq 'number')) { - if (@items < $expected{$part_id}) { - my $fragment = substr($scandata{$pid},$startpos{$part_id},$expected{$part_id}); - my @singles = split(//,$fragment); - foreach my $pos (@singles) { - if ($pos eq ' ') { - push(@tocheck,$pos); - } else { - my $next = shift(@items); - push(@tocheck,$next); - } - } - } else { - @tocheck = @items; - } - foreach my $letter (@tocheck) { - if ($scantron_config{'Qon'} eq 'letter') { - if ($letter !~ /^[A-J]$/) { - $letter = $scantron_config{'Qoff'}; - } - $recorded{$part_id} .= $letter; - } elsif ($scantron_config{'Qon'} eq 'number') { - my $digit; - if ($letter !~ /^[A-J]$/) { - $digit = $scantron_config{'Qoff'}; - } else { - $digit = $lettdig{$letter}; - } - $recorded{$part_id} .= $digit; - } - } - } else { - @tocheck = @items; - for (my $i=0; $i<$expected{$part_id}; $i++) { - my $curr_sub = shift(@tocheck); - my $digit; - if ($curr_sub =~ /^[A-J]$/) { - $digit = $lettdig{$curr_sub}-1; - } - if ($curr_sub eq 'J') { - $digit += scalar($numletts); - } - for (my $j=0; $j<$scantron_config{'Qlength'}; $j++) { - if ($j == $digit) { - $recorded{$part_id} .= $scantron_config{'Qon'}; - } else { - $recorded{$part_id} .= $scantron_config{'Qoff'}; - } - } - } - } - } - } - } - } - foreach my $part_id (@part_ids) { - if ($recorded{$part_id} eq '') { - for (my $i=0; $i<$expected{$part_id}; $i++) { - for (my $j=0; $j<$scantron_config{'Qlength'}; $j++) { - $recorded{$part_id} .= $scantron_config{'Qoff'}; - } - } - } - $record{$pid} .= $recorded{$part_id}; - } - } + ($counter,my $recording) = + &verify_scantron_grading($resource,$domain,$username,$cid,$counter, + $scandata{$pid},\%partids_by_symb, + \%scantron_config,\%lettdig,$numletts); + $record{$pid} .= $recording; } } &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state); @@ -8081,6 +8042,138 @@ sub checkscantron_results { return; } +sub verify_scantron_grading { + my ($resource,$domain,$username,$cid,$counter,$scandata,$partids_by_symb, + $scantron_config,$lettdig,$numletts) = @_; + my ($record,%expected,%startpos); + return ($counter,$record) if (!ref($resource)); + return ($counter,$record) if (!$resource->is_problem()); + my $symb = $resource->symb(); + return ($counter,$record) if (ref($partids_by_symb) ne 'HASH'); + return ($counter,$record) if (ref($partids_by_symb->{$symb}) ne 'ARRAY'); + foreach my $part_id (@{$partids_by_symb->{$symb}}) { + $counter ++; + $expected{$part_id} = 0; + if ($env{"form.scantron.sub_bubblelines.$counter"}) { + my @sub_lines = split(/,/,$env{"form.scantron.sub_bubblelines.$counter"}); + foreach my $item (@sub_lines) { + $expected{$part_id} += $item; + } + } else { + $expected{$part_id} = $env{"form.scantron.bubblelines.$counter"}; + } + $startpos{$part_id} = $env{"form.scantron.first_bubble_line.$counter"}; + } + if ($symb) { + my %recorded; + my (%returnhash) = &Apache::lonnet::restore($symb,$cid,$domain,$username); + if ($returnhash{'version'}) { + my %lasthash=(); + my $version; + for ($version=1;$version<=$returnhash{'version'};$version++) { + foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) { + $lasthash{$key}=$returnhash{$version.':'.$key}; + } + } + foreach my $key (keys(%lasthash)) { + if ($key =~ /\.scantron$/) { + my $value = &unescape($lasthash{$key}); + my ($part_id) = ($key =~ /^resource\.(.+)\.scantron$/); + if ($value eq '') { + for (my $i=0; $i<$expected{$part_id}; $i++) { + for (my $j=0; $j<$scantron_config->{'length'}; $j++) { + $recorded{$part_id} .= $scantron_config->{'Qoff'}; + } + } + } else { + my @tocheck; + my @items = split(//,$value); + if (($scantron_config->{'Qon'} eq 'letter') || + ($scantron_config->{'Qon'} eq 'number')) { + if (@items < $expected{$part_id}) { + my $fragment = substr($scandata,$startpos{$part_id},$expected{$part_id}); + my @singles = split(//,$fragment); + foreach my $pos (@singles) { + if ($pos eq ' ') { + push(@tocheck,$pos); + } else { + my $next = shift(@items); + push(@tocheck,$next); + } + } + } else { + @tocheck = @items; + } + foreach my $letter (@tocheck) { + if ($scantron_config->{'Qon'} eq 'letter') { + if ($letter !~ /^[A-J]$/) { + $letter = $scantron_config->{'Qoff'}; + } + $recorded{$part_id} .= $letter; + } elsif ($scantron_config->{'Qon'} eq 'number') { + my $digit; + if ($letter !~ /^[A-J]$/) { + $digit = $scantron_config->{'Qoff'}; + } else { + $digit = $lettdig->{$letter}; + } + $recorded{$part_id} .= $digit; + } + } + } else { + @tocheck = @items; + for (my $i=0; $i<$expected{$part_id}; $i++) { + my $curr_sub = shift(@tocheck); + my $digit; + if ($curr_sub =~ /^[A-J]$/) { + $digit = $lettdig->{$curr_sub}-1; + } + if ($curr_sub eq 'J') { + $digit += scalar($numletts); + } + for (my $j=0; $j<$scantron_config->{'Qlength'}; $j++) { + if ($j == $digit) { + $recorded{$part_id} .= $scantron_config->{'Qon'}; + } else { + $recorded{$part_id} .= $scantron_config->{'Qoff'}; + } + } + } + } + } + } + } + } + foreach my $part_id (@{$partids_by_symb->{$symb}}) { + if ($recorded{$part_id} eq '') { + for (my $i=0; $i<$expected{$part_id}; $i++) { + for (my $j=0; $j<$scantron_config->{'Qlength'}; $j++) { + $recorded{$part_id} .= $scantron_config->{'Qoff'}; + } + } + } + $record .= $recorded{$part_id}; + } + } + return ($counter,$record); +} + +sub letter_to_digits { + my %lettdig = ( + A => 1, + B => 2, + C => 3, + D => 4, + E => 5, + F => 6, + G => 7, + H => 8, + I => 9, + J => 0, + ); + return %lettdig; +} + =pod =back 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.