Annotation of loncom/interface/statistics/lonstathelpers.pm, revision 1.37

1.1       matthew     1: # The LearningOnline Network with CAPA
                      2: #
1.37    ! matthew     3: # $Id: lonstathelpers.pm,v 1.36 2005/02/01 15:15:28 matthew Exp $
1.1       matthew     4: #
                      5: # Copyright Michigan State University Board of Trustees
                      6: #
                      7: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      8: #
                      9: # LON-CAPA is free software; you can redistribute it and/or modify
                     10: # it under the terms of the GNU General Public License as published by
                     11: # the Free Software Foundation; either version 2 of the License, or
                     12: # (at your option) any later version.
                     13: #
                     14: # LON-CAPA is distributed in the hope that it will be useful,
                     15: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     16: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     17: # GNU General Public License for more details.
                     18: #
                     19: # You should have received a copy of the GNU General Public License
                     20: # along with LON-CAPA; if not, write to the Free Software
                     21: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     22: #
                     23: # /home/httpd/html/adm/gpl.txt
                     24: #
                     25: # http://www.lon-capa.org/
                     26: #
                     27: ####################################################
                     28: ####################################################
                     29: 
                     30: =pod
                     31: 
                     32: =head1 NAME
                     33: 
                     34: Apache::lonstathelpers - helper routines used by statistics
                     35: 
                     36: =head1 SYNOPSIS
                     37: 
                     38: This module provides a place to consolidate much of the statistics 
                     39: routines that are needed across multiple statistics functions.
                     40: 
                     41: =head1 OVERVIEW
                     42: 
                     43: =over 4
                     44: 
                     45: =cut
                     46: 
                     47: ####################################################
                     48: ####################################################
                     49: package Apache::lonstathelpers;
                     50: 
                     51: use strict;
                     52: use Apache::lonnet();
                     53: use Apache::loncommon();
                     54: use Apache::lonhtmlcommon();
                     55: use Apache::loncoursedata();
                     56: use Apache::lonstatistics;
                     57: use Apache::lonlocal;
                     58: use HTML::Entities();
                     59: use Time::Local();
                     60: use Spreadsheet::WriteExcel();
1.8       matthew    61: use GDBM_File;
                     62: use Storable qw(freeze thaw);
1.1       matthew    63: 
                     64: ####################################################
                     65: ####################################################
                     66: 
                     67: =pod
                     68: 
                     69: =item &render_resource($resource)
                     70: 
                     71: Input: a resource generated from 
                     72: &Apache::loncoursedata::get_sequence_assessment_data().
                     73: 
                     74: Retunrs: a scalar containing html for a rendering of the problem
                     75: within a table.
                     76: 
                     77: =cut
                     78: 
                     79: ####################################################
                     80: ####################################################
                     81: sub render_resource {
                     82:     my ($resource) = @_;
                     83:     ##
                     84:     ## Render the problem
                     85:     my $base;
                     86:     ($base,undef) = ($resource->{'src'} =~ m|(.*/)[^/]*$|);
                     87:     $base = "http://".$ENV{'SERVER_NAME'}.$base;
                     88:     my $rendered_problem = 
1.34      matthew    89:         &Apache::lonnet::ssi_body($resource->{'src'}.'?symb='.&Apache::lonnet::escape($resource->{'symb'}));
1.1       matthew    90:     $rendered_problem =~ s/<\s*form\s*/<nop /g;
                     91:     $rendered_problem =~ s|(<\s*/form\s*>)|<\/nop>|g;
                     92:     return '<table bgcolor="ffffff"><tr><td>'.
                     93:         '<base href="'.$base.'" />'.
                     94:         $rendered_problem.
                     95:         '</td></tr></table>';
                     96: }
1.2       matthew    97: 
                     98: ####################################################
                     99: ####################################################
                    100: 
                    101: =pod
                    102: 
                    103: =item &ProblemSelector($AcceptedResponseTypes)
                    104: 
                    105: Input: scalar containing regular expression which matches response
                    106: types to show.  '.' will yield all, '(option|radiobutton)' will match
                    107: all option response and radiobutton problems.
                    108: 
                    109: Returns: A string containing html for a table which lists the sequences
                    110: and their contents.  A radiobutton is provided for each problem.
1.14      matthew   111: Skips 'survey' problems.
1.2       matthew   112: 
                    113: =cut
                    114: 
                    115: ####################################################
                    116: ####################################################
                    117: sub ProblemSelector {
                    118:     my ($AcceptedResponseTypes) = @_;
                    119:     my $Str;
                    120:     $Str = "\n<table>\n";
1.27      matthew   121:     my $rb_count =0;
1.12      matthew   122:     foreach my $seq (&Apache::lonstatistics::Sequences_with_Assess('all')) {
1.2       matthew   123:         next if ($seq->{'num_assess'}<1);
                    124:         my $seq_str = '';
                    125:         foreach my $res (@{$seq->{'contents'}}) {
                    126:             next if ($res->{'type'} ne 'assessment');
                    127:             foreach my $part (@{$res->{'parts'}}) {
                    128:                 my $partdata = $res->{'partdata'}->{$part};
                    129:                 for (my $i=0;$i<scalar(@{$partdata->{'ResponseTypes'}});$i++){
                    130:                     my $respid = $partdata->{'ResponseIds'}->[$i];
                    131:                     my $resptype = $partdata->{'ResponseTypes'}->[$i];
                    132:                     if ($resptype =~ m/$AcceptedResponseTypes/) {
                    133:                         my $value = &make_target_id({symb=>$res->{'symb'},
                    134:                                                      part=>$part,
                    135:                                                      respid=>$respid,
                    136:                                                      resptype=>$resptype});
                    137:                         my $checked = '';
                    138:                         if ($ENV{'form.problemchoice'} eq $value) {
                    139:                             $checked = 'checked ';
                    140:                         }
                    141:                         my $title = $res->{'title'};
                    142:                         if (! defined($title) || $title eq '') {
                    143:                             ($title) = ($res->{'src'} =~ m:/([^/]*)$:);
                    144:                         }
1.27      matthew   145:                         $seq_str .= '<tr>'.
                    146:                             qq{<td><input type="radio" id="$rb_count" name="problemchoice" value="$value" $checked /></td>}.
                    147:                             '<td><label for="'.$rb_count.'">'.$resptype.'</label></td>'.
                    148:                             '<td><label for="'.$rb_count.'">'.$title.'</label>';
1.5       matthew   149:                         if (scalar(@{$partdata->{'ResponseIds'}}) > 1) {
1.2       matthew   150:                             $seq_str .= &mt('response').' '.$respid;
                    151:                         }
1.34      matthew   152:                         my $link = $res->{'src'}.'?symb='.
                    153:                             &Apache::lonnet::escape($res->{'symb'});
1.27      matthew   154:                         $seq_str .= ('&nbsp;'x2).
1.34      matthew   155:                             qq{<a target="preview" href="$link">view</a>};
1.2       matthew   156:                         $seq_str .= "</td></tr>\n";
1.27      matthew   157:                         $rb_count++;
1.2       matthew   158:                     }
                    159:                 }
                    160:             }
                    161:         }
                    162:         if ($seq_str ne '') {
                    163:             $Str .= '<tr><td>&nbsp</td><td colspan="2"><b>'.$seq->{'title'}.'</b></td>'.
                    164:                 "</tr>\n".$seq_str;
                    165:         }
                    166:     }
                    167:     $Str .= "</table>\n";
                    168:     return $Str;
                    169: }
                    170: 
                    171: ####################################################
                    172: ####################################################
                    173: 
                    174: =pod
                    175: 
1.24      matthew   176: =item &MultipleProblemSelector($navmap,$selected,$inputname)
1.21      matthew   177: 
                    178: Generate HTML with checkboxes for problem selection.
                    179: 
                    180: Input: 
                    181: 
                    182: $navmap: a navmap object.  If undef, navmaps will be called to create a
                    183: new object.
                    184: 
                    185: $selected: Scalar, Array, or hash reference of currently selected items.
                    186: 
                    187: $inputname: The name of the form elements to use for the checkboxs.
                    188: 
                    189: Returns: A string containing html for a table which lists the sequences
                    190: and their contents.  A checkbox is provided for each problem.
                    191: 
                    192: =cut
                    193: 
                    194: ####################################################
                    195: ####################################################
                    196: sub MultipleProblemSelector {
1.23      matthew   197:     my ($navmap,$inputname,$formname)=@_;
1.21      matthew   198:     my $cid = $ENV{'request.course.id'};
                    199:     my $Str;
                    200:     # Massage the input as needed.
                    201:     if (! defined($navmap)) {
                    202:         $navmap = Apache::lonnavmaps::navmap->new();
                    203:         if (! defined($navmap)) {
                    204:             $Str .= 
                    205:                 '<h1>'.&mt('Error: cannot process course structure').'</h1>';
                    206:             return $Str;
                    207:         }
                    208:     }
                    209:     my $selected = {map { ($_,1) } (&get_selected_symbs($inputname))};
                    210:     # Header
                    211:     $Str .= <<"END";
1.25      matthew   212: <script language="JavaScript" type="text/javascript">
                    213:     function checkall(value,seqid) {
1.21      matthew   214:         for (i=0; i<document.forms.$formname.elements.length; i++) {
                    215:             ele = document.forms.$formname.elements[i];
                    216:             if (ele.name == '$inputname') {
1.25      matthew   217:                 if (seqid != null) {
                    218:                     itemid = document.forms.$formname.elements[i].id;
                    219:                     thing = itemid.split(':');
                    220:                     if (thing[0] == seqid) {
                    221:                         document.forms.$formname.elements[i].checked=value;
                    222:                     }
                    223:                 } else {
                    224:                     document.forms.$formname.elements[i].checked=value;
                    225:                 }
1.21      matthew   226:             }
                    227:         }
                    228:     }
                    229: </script>
                    230: END
                    231:     $Str .= 
                    232:         '<a href="javascript:checkall(true)">'.&mt('Select All').'</a>'.
                    233:         ('&nbsp;'x4).
                    234:         '<a href="javascript:checkall(false)">'.&mt('Unselect All').'</a>';
                    235:     $Str .= $/.'<table>'.$/;
                    236:     my $iterator = $navmap->getIterator(undef, undef, undef, 1);
                    237:     my $sequence_string;
1.25      matthew   238:     my $seq_id = 0;
1.21      matthew   239:     my @Accumulator = (&new_accumulator($ENV{'course.'.$cid.'.description'},
                    240:                                         '',
                    241:                                         '',
1.25      matthew   242:                                         $seq_id++,
1.21      matthew   243:                                         $inputname));
                    244:     my @Sequence_Data;
                    245:     while (my $curRes = $iterator->next()) {
                    246:         if ($curRes == $iterator->END_MAP) {
                    247:             if (ref($Accumulator[-1]) eq 'CODE') {
1.24      matthew   248:                 my $old_accumulator = pop(@Accumulator);
                    249:                 push(@Sequence_Data,&{$old_accumulator}());
1.21      matthew   250:             }
                    251:         } elsif ($curRes == $iterator->BEGIN_MAP) {
                    252:             # Not much to do here.
                    253:         }
                    254:         next if (! ref($curRes));
                    255:         if ($curRes->is_map) {
1.24      matthew   256:             push(@Accumulator,&new_accumulator($curRes->compTitle,
1.21      matthew   257:                                                $curRes->src,
                    258:                                                $curRes->symb,
1.25      matthew   259:                                                $seq_id++,
1.21      matthew   260:                                                $inputname));
                    261:         } elsif ($curRes->is_problem) {
                    262:             if (@Accumulator && $Accumulator[-1] ne '') {
                    263:                 &{$Accumulator[-1]}($curRes,
                    264:                                     exists($selected->{$curRes->symb}));
                    265:             }
                    266:         }
                    267:     }
                    268:     my $course_seq = pop(@Sequence_Data);
                    269:     foreach my $seq ($course_seq,@Sequence_Data) {
                    270:         #my $seq = pop(@Sequence_Data);
                    271:         next if (! defined($seq) || ref($seq) ne 'HASH');
                    272:         $Str.= '<tr><td colspan="2">'.
1.25      matthew   273:             '<b>'.$seq->{'title'}.'</b>'.('&nbsp;'x2).
                    274:             '<a href="javascript:checkall(true,'.$seq->{'id'}.')">'.
                    275:                                   &mt('Select').'</a>'.('&nbsp;'x2).
                    276:             '<a href="javascript:checkall(false,'.$seq->{'id'}.')">'.
                    277:                                   &mt('Unselect').'</a>'.('&nbsp;'x2).
1.21      matthew   278:             '</td></tr>'.$/;
                    279:         $Str.= $seq->{'html'};
                    280:     }
                    281:     $Str .= '</table>'.$/;
                    282:     return $Str;
                    283: }
                    284: 
                    285: sub new_accumulator {
1.25      matthew   286:     my ($title,$src,$symb,$seq_id,$inputname) = @_;
1.21      matthew   287:     my $target;
1.25      matthew   288:     my $item_id=0;
1.21      matthew   289:     return 
                    290:         sub {
                    291:             if (@_) { 
                    292:                 my ($res,$checked) = @_;
1.23      matthew   293:                 $target.='<tr><td><label>'.
1.21      matthew   294:                     '<input type="checkbox" name="'.$inputname.'" ';
                    295:                 if ($checked) {
                    296:                     $target .= 'checked ';
                    297:                 }
1.25      matthew   298:                 $target .= 'id="'.$seq_id.':'.$item_id++.'" ';
1.21      matthew   299:                 $target.= 
                    300:                     'value="'.&Apache::lonnet::escape($res->symb).'" />'.
1.26      matthew   301:                     '&nbsp;'.$res->compTitle.'</label>'.
                    302:                     ('&nbsp;'x2).'<a target="preview" '.
1.34      matthew   303:                     'href="'.$res->src.'?symb='.
                    304:                          &Apache::lonnet::escape($res->{'symb'}).'">view</a>'.
1.26      matthew   305:                     '</td></tr>'.$/;
1.21      matthew   306:             } else { 
                    307:                 if (defined($target)) {
                    308:                     return { title => $title,
                    309:                              symb  => $symb,
                    310:                              src   => $src,
1.25      matthew   311:                              id    => $seq_id,
1.21      matthew   312:                              html  => $target, }; 
                    313:                 }
                    314:                 return undef;
                    315:             }
                    316:         };
                    317: }
                    318: 
                    319: sub get_selected_symbs {
                    320:     my ($inputfield) = @_;
                    321:     my $field = 'form.'.$inputfield;
                    322:     my @Symbs;
                    323:     if (exists($ENV{$field})) {
                    324:         if (! ref($ENV{$field})) {
                    325:             @Symbs = (&Apache::lonnet::unescape($ENV{$field}));
                    326:         } else {
                    327:             @Symbs = (map {&Apache::lonnet::unescape($_);} @{$ENV{$field}});
                    328:         }
                    329:     }
                    330:     return @Symbs;
                    331: }
                    332: 
                    333: ####################################################
                    334: ####################################################
                    335: 
                    336: =pod
                    337: 
1.2       matthew   338: =item &make_target_id($target)
                    339: 
                    340: Inputs: Hash ref with the following entries:
                    341:     $target->{'symb'}, $target->{'part'}, $target->{'respid'}, 
                    342:     $target->{'resptype'}.
                    343: 
                    344: Returns: A string, suitable for a form parameter, which uniquely identifies
                    345: the problem, part, and response to do statistical analysis on.
                    346: 
                    347: Used by Apache::lonstathelpers::ProblemSelector().
                    348: 
                    349: =cut
                    350: 
                    351: ####################################################
                    352: ####################################################
                    353: sub make_target_id {
                    354:     my ($target) = @_;
                    355:     my $id = &Apache::lonnet::escape($target->{'symb'}).':'.
                    356:              &Apache::lonnet::escape($target->{'part'}).':'.
                    357:              &Apache::lonnet::escape($target->{'respid'}).':'.
                    358:              &Apache::lonnet::escape($target->{'resptype'});
                    359:     return $id;
                    360: }
                    361: 
                    362: ####################################################
                    363: ####################################################
                    364: 
                    365: =pod
                    366: 
                    367: =item &get_target_from_id($id)
                    368: 
                    369: Inputs: $id, a scalar string from Apache::lonstathelpers::make_target_id().
                    370: 
                    371: Returns: A hash reference, $target, containing the following keys:
                    372:     $target->{'symb'}, $target->{'part'}, $target->{'respid'}, 
                    373:     $target->{'resptype'}.
                    374: 
                    375: =cut
                    376: 
                    377: ####################################################
                    378: ####################################################
                    379: sub get_target_from_id {
                    380:     my ($id) = @_;
1.21      matthew   381:     if (! ref($id)) {
                    382:         my ($symb,$part,$respid,$resptype) = split(':',$id);
                    383:         return ({ symb     => &Apache::lonnet::unescape($symb),
                    384:                   part     => &Apache::lonnet::unescape($part),
                    385:                   respid   => &Apache::lonnet::unescape($respid),
                    386:                   resptype => &Apache::lonnet::unescape($resptype)});
                    387:     } elsif (ref($id) eq 'ARRAY') {
                    388:         my @Return;
                    389:         foreach my $selected (@$id) {
                    390:             my ($symb,$part,$respid,$resptype) = split(':',$selected);
                    391:             push(@Return,{ symb     => &Apache::lonnet::unescape($symb),
                    392:                            part     => &Apache::lonnet::unescape($part),
                    393:                            respid   => &Apache::lonnet::unescape($respid),
                    394:                            resptype => &Apache::lonnet::unescape($resptype)});
                    395:         }
                    396:         return \@Return;
                    397:     }
1.2       matthew   398: }
                    399: 
                    400: ####################################################
                    401: ####################################################
                    402: 
                    403: =pod
                    404: 
1.13      matthew   405: =item &get_prev_curr_next($target,$AcceptableResponseTypes,$granularity)
1.2       matthew   406: 
                    407: Determine the problem parts or responses preceeding and following the
                    408: current resource.
                    409: 
                    410: Inputs: $target (see &Apache::lonstathelpers::get_target_from_id())
                    411:   $AcceptableResponseTypes, regular expression matching acceptable
                    412:                             response types,
1.13      matthew   413:   $granularity, either 'part', 'response', or 'part_survey'
1.2       matthew   414: 
                    415: Returns: three hash references, $prev, $curr, $next, which refer to the
                    416: preceeding, current, or following problem parts or responses, depending
                    417: on the value of $granularity.  Values of undef indicate there is no
                    418: previous or next part/response.  A value of undef for all three indicates
                    419: there was no match found to the current part/resource.
                    420: 
                    421: The hash references contain the following keys:
                    422:     symb, part, resource
                    423: 
                    424: If $granularity eq 'response', the following ADDITIONAL keys will be present:
                    425:     respid, resptype
                    426: 
                    427: =cut
                    428: 
                    429: ####################################################
                    430: ####################################################
                    431: sub get_prev_curr_next {
                    432:     my ($target,$AcceptableResponseTypes,$granularity) = @_;
                    433:     #
                    434:     # Build an array with the data we need to search through
                    435:     my @Resource;
1.12      matthew   436:     foreach my $seq (&Apache::lonstatistics::Sequences_with_Assess('all')) {
1.2       matthew   437:         foreach my $res (@{$seq->{'contents'}}) {
                    438:             next if ($res->{'type'} ne 'assessment');
                    439:             foreach my $part (@{$res->{'parts'}}) {
                    440:                 my $partdata = $res->{'partdata'}->{$part};
1.20      matthew   441:                 if ($partdata->{'Survey'} && ($granularity eq 'part_survey')){
                    442:                     push (@Resource,
                    443:                           { symb     => $res->{symb},
                    444:                             part     => $part,
                    445:                             resource => $res,
                    446:                         } );
1.13      matthew   447:                 } elsif ($granularity eq 'part') {
1.2       matthew   448:                     push (@Resource,
                    449:                           { symb     => $res->{symb},
                    450:                             part     => $part,
                    451:                             resource => $res,
                    452:                         } );
                    453:                 } elsif ($granularity eq 'response') {
                    454:                     for (my $i=0;
                    455:                          $i<scalar(@{$partdata->{'ResponseTypes'}});
                    456:                          $i++){
                    457:                         my $respid = $partdata->{'ResponseIds'}->[$i];
                    458:                         my $resptype = $partdata->{'ResponseTypes'}->[$i];
                    459:                         next if ($resptype !~ m/$AcceptableResponseTypes/);
                    460:                         push (@Resource,
                    461:                               { symb     => $res->{symb},
                    462:                                 part     => $part,
                    463:                                 respid   => $partdata->{'ResponseIds'}->[$i],
                    464:                                 resource => $res,
                    465:                                 resptype => $resptype
                    466:                                 } );
                    467:                     }
                    468:                 }
                    469:             }
                    470:         }
                    471:     }
                    472:     #
                    473:     # Get the index of the current situation
                    474:     my $curr_idx;
                    475:     for ($curr_idx=0;$curr_idx<$#Resource;$curr_idx++) {
                    476:         my $curr_item = $Resource[$curr_idx];
1.13      matthew   477:         if ($granularity eq 'part' || $granularity eq 'part_survey') {
1.2       matthew   478:             if ($curr_item->{'symb'} eq $target->{'symb'} &&
                    479:                 $curr_item->{'part'} eq $target->{'part'}) {
                    480:                 last;
                    481:             }
                    482:         } elsif ($granularity eq 'response') {
                    483:             if ($curr_item->{'symb'} eq $target->{'symb'} &&
                    484:                 $curr_item->{'part'} eq $target->{'part'} &&
                    485:                 $curr_item->{'respid'} eq $target->{'respid'} &&
                    486:                 $curr_item->{'resptype'} eq $target->{'resptype'}) {
                    487:                 last;
                    488:             }
                    489:         }
                    490:     }
                    491:     my $curr_item = $Resource[$curr_idx];
1.13      matthew   492:     if ($granularity eq 'part' || $granularity eq 'part_survey') {
1.2       matthew   493:         if ($curr_item->{'symb'}     ne $target->{'symb'} ||
                    494:             $curr_item->{'part'}     ne $target->{'part'}) {
                    495:             # bogus symb - return nothing
                    496:             return (undef,undef,undef);
                    497:         }
                    498:     } elsif ($granularity eq 'response') {
                    499:         if ($curr_item->{'symb'}     ne $target->{'symb'} ||
                    500:             $curr_item->{'part'}     ne $target->{'part'} ||
                    501:             $curr_item->{'respid'}   ne $target->{'respid'} ||
                    502:             $curr_item->{'resptype'} ne $target->{'resptype'}){
                    503:             # bogus symb - return nothing
                    504:             return (undef,undef,undef);
                    505:         }
                    506:     }
                    507:     #
                    508:     # Now just pick up the data we need
                    509:     my ($prev,$curr,$next);
                    510:     if ($curr_idx == 0) {
                    511:         $prev = undef;
                    512:         $curr = $Resource[$curr_idx  ];
                    513:         $next = $Resource[$curr_idx+1];
                    514:     } elsif ($curr_idx == $#Resource) {
                    515:         $prev = $Resource[$curr_idx-1];
                    516:         $curr = $Resource[$curr_idx  ];
                    517:         $next = undef;
                    518:     } else {
                    519:         $prev = $Resource[$curr_idx-1];
                    520:         $curr = $Resource[$curr_idx  ];
                    521:         $next = $Resource[$curr_idx+1];
                    522:     }
                    523:     return ($prev,$curr,$next);
1.4       matthew   524: }
                    525: 
1.9       matthew   526: 
                    527: #####################################################
                    528: #####################################################
                    529: 
                    530: =pod
                    531: 
                    532: =item GetStudentAnswers($r,$problem,$Students)
                    533: 
                    534: Determines the correct answer for a set of students on a given problem.
                    535: The students answers are stored in the student hashes pointed to by the
                    536: array @$Students under the key 'answer'.
                    537: 
                    538: Inputs: $r
                    539: $problem: hash reference containing the keys 'resource', 'part', and 'respid'.
                    540: $Students: reference to array containing student hashes (need 'username', 
                    541:     'domain').  
                    542: 
                    543: Returns: nothing 
                    544: 
                    545: =cut
                    546: 
                    547: #####################################################
                    548: #####################################################
                    549: sub GetStudentAnswers {
1.12      matthew   550:     my ($r,$problem,$Students,$formname,$inputname) = @_;
1.31      matthew   551:     my %answers;
1.12      matthew   552:     my $status_type;
                    553:     if (defined($formname)) {
                    554:         $status_type = 'inline';
                    555:     } else {
                    556:         $status_type = 'popup';
                    557:     }    
1.9       matthew   558:     my $c = $r->connection();
                    559:     my %Answers;
                    560:     my ($resource,$partid,$respid) = ($problem->{'resource'},
                    561:                                       $problem->{'part'},
                    562:                                       $problem->{'respid'});
                    563:     # Read in the cache (if it exists) before we start timing things.
                    564:     &Apache::lonstathelpers::ensure_proper_cache($resource->{'symb'});
                    565:     # Open progress window
                    566:     my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin
                    567:         ($r,'Student Answer Compilation Status',
1.12      matthew   568:          'Student Answer Compilation Progress', scalar(@$Students),
                    569:          $status_type,undef,$formname,$inputname);
1.9       matthew   570:     $r->rflush();
                    571:     foreach my $student (@$Students) {
                    572:         last if ($c->aborted());
                    573:         my $sname = $student->{'username'};
                    574:         my $sdom = $student->{'domain'};
1.30      matthew   575:         my $answer = &Apache::lonstathelpers::get_student_answer
1.9       matthew   576:             ($resource,$sname,$sdom,$partid,$respid);
                    577:         &Apache::lonhtmlcommon::Increment_PrgWin($r,\%prog_state,
                    578:                                                  &mt('last student'));
1.31      matthew   579:         $answers{$answer}++;
1.9       matthew   580:         $student->{'answer'} = $answer;
                    581:     }
1.29      matthew   582:     &Apache::lonstathelpers::write_analysis_cache();
1.9       matthew   583:     return if ($c->aborted());
                    584:     $r->rflush();
                    585:     # close progress window
                    586:     &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state);
1.31      matthew   587:     return \%answers;
1.9       matthew   588: }
1.4       matthew   589: 
                    590: #####################################################
                    591: #####################################################
                    592: 
                    593: =pod
                    594: 
                    595: =item analyze_problem_as_student
                    596: 
1.30      matthew   597: Analyzes a homework problem for a student
1.4       matthew   598: 
                    599: Inputs: $resource: a resource object
                    600:         $sname, $sdom, $partid, $respid
                    601: 
1.30      matthew   602: Returns: the problem analysis hash
1.6       matthew   603: 
1.4       matthew   604: =cut
                    605: 
                    606: #####################################################
                    607: #####################################################
                    608: sub analyze_problem_as_student {
1.30      matthew   609:     my ($resource,$sname,$sdom) = @_;
1.22      matthew   610:     if (ref($resource) ne 'HASH') {
                    611:         my $res = $resource;
                    612:         $resource = { 'src' => $res->src,
                    613:                       'symb' => $res->symb,
                    614:                       'parts' => $res->parts };
                    615:         foreach my $part (@{$resource->{'parts'}}) {
                    616:             $resource->{'partdata'}->{$part}->{'ResponseIds'}=
                    617:                 [$res->responseIds($part)];
                    618:         }
                    619:     }
1.4       matthew   620:     my $url = $resource->{'src'};
                    621:     my $symb = $resource->{'symb'};
1.29      matthew   622:     my $analysis = &get_from_analysis_cache($sname,$sdom,$symb);
                    623:     if (! defined($analysis)) {
                    624:         my $courseid = $ENV{'request.course.id'};
                    625:         my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze',
                    626:                                             'grade_domain' => $sdom,
                    627:                                             'grade_username' => $sname,
                    628:                                             'grade_symb' => $symb,
                    629:                                             'grade_courseid' => $courseid));
                    630:         (my $garbage,$analysis)=split(/_HASH_REF__/,$Answ,2);
                    631:         &store_analysis($sname,$sdom,$symb,$analysis);
                    632:     }
                    633:     my %Answer=&Apache::lonnet::str2hash($analysis);
1.6       matthew   634:     #
1.30      matthew   635:     return \%Answer;
                    636: }
                    637: 
                    638: #####################################################
                    639: #####################################################
                    640: 
                    641: =pod
                    642: 
                    643: =item get_student_answer
                    644: 
                    645: Analyzes a homework problem for a particular student and returns the correct 
                    646: answer.  Attempts to put together an answer for problem types 
                    647: that do not natively support it.
                    648: 
                    649: Inputs: $resource: a resource object (from navmaps or hash from loncoursedata)
                    650:         $sname, $sdom, $partid, $respid
                    651: 
                    652: Returns: $answer
                    653: 
                    654: If $partid and $respid are specified, $answer is simply a scalar containing
                    655: the correct answer for the response.
                    656: 
                    657: If $partid or $respid are undefined, $answer will be a hash reference with
                    658: keys $partid.'.'.$respid.'.answer'.
                    659: 
                    660: =cut
                    661: 
                    662: #####################################################
                    663: #####################################################
                    664: sub get_student_answer {
                    665:     my ($resource,$sname,$sdom,$partid,$respid) = @_;
                    666:     #
                    667:     if (ref($resource) ne 'HASH') {
                    668:         my $res = $resource;
                    669:         $resource = { 'src' => $res->src,
                    670:                       'symb' => $res->symb,
                    671:                       'parts' => $res->parts };
                    672:         foreach my $part (@{$resource->{'parts'}}) {
                    673:             $resource->{'partdata'}->{$part}->{'ResponseIds'}=
                    674:                 [$res->responseIds($part)];
                    675:         }
                    676:     }
                    677:     #
                    678:     my $analysis = 
                    679:         &analyze_problem_as_student($resource,$sname,$sdom);
1.29      matthew   680:     my $answer;
1.8       matthew   681:     foreach my $partid (@{$resource->{'parts'}}) {
1.6       matthew   682:         my $partdata = $resource->{'partdata'}->{$partid};
                    683:         foreach my $respid (@{$partdata->{'ResponseIds'}}) {
                    684:             my $prefix = $partid.'.'.$respid;
                    685:             my $key = $prefix.'.answer';
1.30      matthew   686:             $answer->{$partid}->{$respid} = 
                    687:                 &get_answer($prefix,$key,%$analysis);
1.6       matthew   688:         }
1.8       matthew   689:     }
1.30      matthew   690:     my $returnvalue;
1.8       matthew   691:     if (! defined($partid)) {
                    692:         $returnvalue = $answer;
                    693:     } elsif (! defined($respid)) {
                    694:         $returnvalue = $answer->{$partid};
1.6       matthew   695:     } else {
1.8       matthew   696:         $returnvalue = $answer->{$partid}->{$respid};
1.6       matthew   697:     }
                    698:     return $returnvalue;
                    699: }
                    700: 
                    701: sub get_answer {
                    702:     my ($prefix,$key,%Answer) = @_;
                    703:     my $returnvalue;
1.4       matthew   704:     if (exists($Answer{$key})) {
                    705:         my $student_answer = $Answer{$key}->[0];
                    706:         if (! defined($student_answer)) {
                    707:             $student_answer = $Answer{$key}->[1];
                    708:         }
                    709:         $returnvalue = $student_answer;
                    710:     } else {
                    711:         if (exists($Answer{$prefix.'.shown'})) {
                    712:             # The response has foils
                    713:             my %values;
                    714:             while (my ($k,$v) = each(%Answer)) {
                    715:                 next if ($k !~ /^$prefix\.foil\.(value|area)\.(.*)$/);
                    716:                 my $foilname = $2;
                    717:                 $values{$foilname}=$v;
                    718:             }
                    719:             foreach my $foil (@{$Answer{$prefix.'.shown'}}) {
                    720:                 if (ref($values{$foil}) eq 'ARRAY') {
1.10      albertel  721:                     $returnvalue.=&HTML::Entities::encode($foil,'<>&"').'='.
                    722:                         join(',',map {&HTML::Entities::encode($_,'<>&"')} @{$values{$foil}}).'&';
1.4       matthew   723:                 } else {
1.10      albertel  724:                     $returnvalue.=&HTML::Entities::encode($foil,'<>&"').'='.
                    725:                         &HTML::Entities::encode($values{$foil},'<>&"').'&';
1.4       matthew   726:                 }
                    727:             }
                    728:             $returnvalue =~ s/ /\%20/g;
                    729:             chop ($returnvalue);
                    730:         }
                    731:     }
                    732:     return $returnvalue;
                    733: }
1.8       matthew   734: 
                    735: #####################################################
                    736: #####################################################
                    737: 
                    738: =pod
                    739: 
                    740: =item Caching routines
                    741: 
                    742: =over 4
                    743: 
1.29      matthew   744: =item &load_analysis_cache($symb)
1.8       matthew   745: 
                    746: Loads the cache for the given symb into memory from disk.  
                    747: Requires the cache filename be set.  
                    748: Only should be called by &ensure_proper_cache.
                    749: 
                    750: =cut
                    751: 
                    752: #####################################################
                    753: #####################################################
                    754: {
                    755:     my $cache_filename = undef;
                    756:     my $current_symb = undef;
                    757:     my %cache;
                    758: 
1.29      matthew   759: sub load_analysis_cache {
1.8       matthew   760:     my ($symb) = @_;
                    761:     return if (! defined($cache_filename));
                    762:     if (! defined($current_symb) || $current_symb ne $symb) {
                    763:         undef(%cache);
                    764:         my $storedstring;
                    765:         my %cache_db;
                    766:         if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_READER(),0640)) {
                    767:             $storedstring = $cache_db{&Apache::lonnet::escape($symb)};
                    768:             untie(%cache_db);
                    769:         }
                    770:         if (defined($storedstring)) {
                    771:             %cache = %{thaw($storedstring)};
                    772:         }
                    773:     }
                    774:     return;
                    775: }
                    776: 
                    777: #####################################################
                    778: #####################################################
                    779: 
                    780: =pod
                    781: 
1.29      matthew   782: =item &get_from_analysis_cache($sname,$sdom,$symb,$partid,$respid)
1.8       matthew   783: 
                    784: Returns the appropriate data from the cache, or undef if no data exists.
                    785: 
                    786: =cut
                    787: 
                    788: #####################################################
                    789: #####################################################
1.29      matthew   790: sub get_from_analysis_cache {
                    791:     my ($sname,$sdom,$symb) = @_;
1.8       matthew   792:     &ensure_proper_cache($symb);
                    793:     my $returnvalue;
1.29      matthew   794:     if (exists($cache{$sname.':'.$sdom})) {
                    795:         $returnvalue = $cache{$sname.':'.$sdom};
1.8       matthew   796:     } else {
                    797:         $returnvalue = undef;
                    798:     }
                    799:     return $returnvalue;
                    800: }
                    801: 
                    802: #####################################################
                    803: #####################################################
                    804: 
                    805: =pod
                    806: 
1.29      matthew   807: =item &write_analysis_cache($symb)
1.8       matthew   808: 
                    809: Writes the in memory cache to disk so that it can be read in with
1.29      matthew   810: &load_analysis_cache($symb).
1.8       matthew   811: 
                    812: =cut
                    813: 
                    814: #####################################################
                    815: #####################################################
1.29      matthew   816: sub write_analysis_cache {
1.8       matthew   817:     return if (! defined($current_symb) || ! defined($cache_filename));
                    818:     my %cache_db;
                    819:     my $key = &Apache::lonnet::escape($current_symb);
                    820:     if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_WRCREAT(),0640)) {
                    821:         my $storestring = freeze(\%cache);
                    822:         $cache_db{$key}=$storestring;
                    823:         $cache_db{$key.'.time'}=time;
                    824:         untie(%cache_db);
                    825:     }
                    826:     undef(%cache);
                    827:     undef($current_symb);
                    828:     undef($cache_filename);
                    829:     return;
                    830: }
                    831: 
                    832: #####################################################
                    833: #####################################################
                    834: 
                    835: =pod
                    836: 
                    837: =item &ensure_proper_cache($symb)
                    838: 
                    839: Called to make sure we have the proper cache set up.  This is called
1.29      matthew   840: prior to every analysis lookup.
1.8       matthew   841: 
                    842: =cut
                    843: 
                    844: #####################################################
                    845: #####################################################
                    846: sub ensure_proper_cache {
                    847:     my ($symb) = @_;
                    848:     my $cid = $ENV{'request.course.id'};
                    849:     my $new_filename =  '/home/httpd/perl/tmp/'.
1.29      matthew   850:         'problemanalysis_'.$cid.'_analysis_cache.db';
1.8       matthew   851:     if (! defined($cache_filename) ||
                    852:         $cache_filename ne $new_filename ||
                    853:         ! defined($current_symb)   ||
                    854:         $current_symb ne $symb) {
                    855:         $cache_filename = $new_filename;
                    856:         # Notice: $current_symb is not set to $symb until after the cache is
1.29      matthew   857:         # loaded.  This is what tells &load_analysis_cache to load in a new
1.8       matthew   858:         # symb cache.
1.29      matthew   859:         &load_analysis_cache($symb);
1.8       matthew   860:         $current_symb = $symb;
                    861:     }
                    862: }
                    863: 
                    864: #####################################################
                    865: #####################################################
                    866: 
                    867: =pod
                    868: 
1.29      matthew   869: =item &store_analysis($sname,$sdom,$symb,$partid,$respid,$dataset)
1.8       matthew   870: 
1.29      matthew   871: Stores the analysis data in the in memory cache.
1.8       matthew   872: 
                    873: =cut
                    874: 
                    875: #####################################################
                    876: #####################################################
1.29      matthew   877: sub store_analysis {
                    878:     my ($sname,$sdom,$symb,$dataset) = @_;
1.8       matthew   879:     return if ($symb ne $current_symb);
1.29      matthew   880:     $cache{$sname.':'.$sdom}=$dataset;
1.8       matthew   881:     return;
                    882: }
                    883: 
                    884: }
                    885: #####################################################
                    886: #####################################################
                    887: 
                    888: =pod
                    889: 
                    890: =back
                    891: 
                    892: =cut
                    893: 
                    894: #####################################################
                    895: #####################################################
1.4       matthew   896: 
                    897: ##
                    898: ## The following is copied from datecalc1.pl, part of the 
                    899: ## Spreadsheet::WriteExcel CPAN module.
                    900: ##
                    901: ##
                    902: ######################################################################
                    903: #
                    904: # Demonstration of writing date/time cells to Excel spreadsheets,
                    905: # using UNIX/Perl time as source of date/time.
                    906: #
                    907: # Copyright 2000, Andrew Benham, adsb@bigfoot.com
                    908: #
                    909: ######################################################################
                    910: #
                    911: # UNIX/Perl time is the time since the Epoch (00:00:00 GMT, 1 Jan 1970)
                    912: # measured in seconds.
                    913: #
                    914: # An Excel file can use exactly one of two different date/time systems.
                    915: # In these systems, a floating point number represents the number of days
                    916: # (and fractional parts of the day) since a start point. The floating point
                    917: # number is referred to as a 'serial'.
                    918: # The two systems ('1900' and '1904') use different starting points:
                    919: #  '1900'; '1.00' is 1 Jan 1900 BUT 1900 is erroneously regarded as
                    920: #          a leap year - see:
                    921: #            http://support.microsoft.com/support/kb/articles/Q181/3/70.asp
                    922: #          for the excuse^H^H^H^H^H^Hreason.
                    923: #  '1904'; '1.00' is 2 Jan 1904.
                    924: #
                    925: # The '1904' system is the default for Apple Macs. Windows versions of
                    926: # Excel have the option to use the '1904' system.
                    927: #
                    928: # Note that Visual Basic's "DateSerial" function does NOT erroneously
                    929: # regard 1900 as a leap year, and thus its serials do not agree with
                    930: # the 1900 serials of Excel for dates before 1 Mar 1900.
                    931: #
                    932: # Note that StarOffice (at least at version 5.2) does NOT erroneously
                    933: # regard 1900 as a leap year, and thus its serials do not agree with
                    934: # the 1900 serials of Excel for dates before 1 Mar 1900.
                    935: #
                    936: ######################################################################
                    937: #
                    938: # Calculation description
                    939: # =======================
                    940: #
                    941: # 1900 system
                    942: # -----------
                    943: # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 70 years after 1 Jan 1900.
                    944: # Of those 70 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68)
                    945: # were leap years with an extra day.
                    946: # Thus there were 17 + 70*365 days = 25567 days between 1 Jan 1900 and
                    947: # 1 Jan 1970.
                    948: # In the 1900 system, '1' is 1 Jan 1900, but as 1900 was not a leap year
                    949: # 1 Jan 1900 should really be '2', so 1 Jan 1970 is '25569'.
                    950: #
                    951: # 1904 system
                    952: # -----------
                    953: # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 66 years after 1 Jan 1904.
                    954: # Of those 66 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68)
                    955: # were leap years with an extra day.
                    956: # Thus there were 17 + 66*365 days = 24107 days between 1 Jan 1904 and
                    957: # 1 Jan 1970.
                    958: # In the 1904 system, 2 Jan 1904 being '1', 1 Jan 1970 is '24107'.
                    959: #
                    960: ######################################################################
                    961: #
                    962: # Copyright (c) 2000, Andrew Benham.
                    963: # This program is free software. It may be used, redistributed and/or
                    964: # modified under the same terms as Perl itself.
                    965: #
                    966: # Andrew Benham, adsb@bigfoot.com
                    967: # London, United Kingdom
                    968: # 11 Nov 2000
                    969: #
                    970: ######################################################################
                    971: #-----------------------------------------------------------
                    972: # calc_serial()
                    973: #
                    974: # Called with (up to) 2 parameters.
                    975: #   1.  Unix timestamp.  If omitted, uses current time.
                    976: #   2.  GMT flag. Set to '1' to return serial in GMT.
                    977: #       If omitted, returns serial in appropriate timezone.
                    978: #
                    979: # Returns date/time serial according to $DATE_SYSTEM selected
                    980: #-----------------------------------------------------------
                    981: sub calc_serial {
                    982:     # Use 1900 date system on all platforms other than Apple Mac (for which
                    983:     # use 1904 date system).
                    984:     my $DATE_SYSTEM = ($^O eq 'MacOS') ? 1 : 0;
                    985:     my $time = (defined $_[0]) ? $_[0] : time();
                    986:     my $gmtflag = (defined $_[1]) ? $_[1] : 0;
                    987:     #
                    988:     # Divide timestamp by number of seconds in a day.
                    989:     # This gives a date serial with '0' on 1 Jan 1970.
                    990:     my $serial = $time / 86400;
                    991:     #
                    992:     # Adjust the date serial by the offset appropriate to the
                    993:     # currently selected system (1900/1904).
                    994:     if ($DATE_SYSTEM == 0) {        # use 1900 system
                    995:         $serial += 25569;
                    996:     } else {                        # use 1904 system
                    997:         $serial += 24107;
                    998:     }
                    999:     #
                   1000:     unless ($gmtflag) {
                   1001:         # Now have a 'raw' serial with the right offset. But this
                   1002:         # gives a serial in GMT, which is false unless the timezone
                   1003:         # is GMT. We need to adjust the serial by the appropriate
                   1004:         # timezone offset.
                   1005:         # Calculate the appropriate timezone offset by seeing what
                   1006:         # the differences between localtime and gmtime for the given
                   1007:         # time are.
                   1008:         #    
                   1009:         my @gmtime = gmtime($time);
                   1010:         my @ltime  = localtime($time);
                   1011:         #
                   1012:         # For the first 7 elements of the two arrays, adjust the
                   1013:         # date serial where the elements differ.
                   1014:         for (0 .. 6) {
                   1015:             my $diff = $ltime[$_] - $gmtime[$_];
                   1016:             if ($diff) {
                   1017:                 $serial += _adjustment($diff,$_);
                   1018:             }
                   1019:         }
                   1020:     }
                   1021:     #
                   1022:     # Perpetuate the error that 1900 was a leap year by decrementing
                   1023:     # the serial if we're using the 1900 system and the date is prior to
                   1024:     # 1 Mar 1900. This has the effect of making serial value '60'
                   1025:     # 29 Feb 1900.
                   1026:     #
                   1027:     # This fix only has any effect if UNIX/Perl time on the platform
                   1028:     # can represent 1900. Many can't.
                   1029:     #
                   1030:     unless ($DATE_SYSTEM) {
                   1031:         $serial-- if ($serial < 61);    # '61' is 1 Mar 1900
                   1032:     }
                   1033:     return $serial;
                   1034: }
                   1035: 
                   1036: sub _adjustment {
                   1037:     # Based on the difference in the localtime/gmtime array elements
                   1038:     # number, return the adjustment required to the serial.
                   1039:     #
                   1040:     # We only look at some elements of the localtime/gmtime arrays:
                   1041:     #    seconds    unlikely to be different as all known timezones
                   1042:     #               have an offset of integral multiples of 15 minutes,
                   1043:     #               but it's easy to do.
                   1044:     #    minutes    will be different for timezone offsets which are
                   1045:     #               not an exact number of hours.
                   1046:     #    hours      very likely to be different.
                   1047:     #    weekday    will differ when localtime/gmtime difference
                   1048:     #               straddles midnight.
                   1049:     #
                   1050:     # Assume that difference between localtime and gmtime is less than
                   1051:     # 5 days, then don't have to do maths for day of month, month number,
                   1052:     # year number, etc...
                   1053:     #
                   1054:     my ($delta,$element) = @_;
                   1055:     my $adjust = 0;
                   1056:     #
                   1057:     if ($element == 0) {            # Seconds
                   1058:         $adjust = $delta/86400;         # 60 * 60 * 24
                   1059:     } elsif ($element == 1) {       # Minutes
                   1060:         $adjust = $delta/1440;          # 60 * 24
                   1061:     } elsif ($element == 2) {       # Hours
                   1062:         $adjust = $delta/24;            # 24
                   1063:     } elsif ($element == 6) {       # Day of week number
                   1064:         # Catch difference straddling Sat/Sun in either direction
                   1065:         $delta += 7 if ($delta < -4);
                   1066:         $delta -= 7 if ($delta > 4);
                   1067:         #    
                   1068:         $adjust = $delta;
                   1069:     }
                   1070:     return $adjust;
                   1071: }
                   1072: 
                   1073: ###########################################################
                   1074: ###########################################################
                   1075: 
                   1076: =pod
                   1077: 
                   1078: =item get_problem_data
                   1079: 
                   1080: Returns a data structure describing the problem.
                   1081: 
                   1082: Inputs: $url
                   1083: 
                   1084: Returns: %Partdata
                   1085: 
                   1086: =cut
                   1087: 
                   1088: ## note: we must force each foil and option to not begin or end with
                   1089: ##       spaces as they are stored without such data.
                   1090: ##
                   1091: ###########################################################
                   1092: ###########################################################
                   1093: sub get_problem_data {
                   1094:     my ($url) = @_;
                   1095:     my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze'));
                   1096:     (my $garbage,$Answ)=split(/_HASH_REF__/,$Answ,2);
                   1097:     my %Answer;
                   1098:     %Answer=&Apache::lonnet::str2hash($Answ);
                   1099:     my %Partdata;
                   1100:     foreach my $part (@{$Answer{'parts'}}) {
                   1101:         while (my($key,$value) = each(%Answer)) {
                   1102:             #
                   1103:             # Logging code:
1.7       matthew  1104:             if (0) {
1.4       matthew  1105:                 &Apache::lonnet::logthis($part.' got key "'.$key.'"');
                   1106:                 if (ref($value) eq 'ARRAY') {
                   1107:                     &Apache::lonnet::logthis('    @'.join(',',@$value));
                   1108:                 } else {
                   1109:                     &Apache::lonnet::logthis('    '.$value);
                   1110:                 }
                   1111:             }
                   1112:             # End of logging code
                   1113:             next if ($key !~ /^$part/);
                   1114:             $key =~ s/^$part\.//;
                   1115:             if (ref($value) eq 'ARRAY') {
                   1116:                 if ($key eq 'options') {
                   1117:                     $Partdata{$part}->{'_Options'}=$value;
                   1118:                 } elsif ($key eq 'concepts') {
                   1119:                     $Partdata{$part}->{'_Concepts'}=$value;
1.28      matthew  1120:                 } elsif ($key eq 'items') {
                   1121:                     $Partdata{$part}->{'_Items'}=$value;
1.4       matthew  1122:                 } elsif ($key =~ /^concept\.(.*)$/) {
                   1123:                     my $concept = $1;
                   1124:                     foreach my $foil (@$value) {
                   1125:                         $Partdata{$part}->{'_Foils'}->{$foil}->{'_Concept'}=
                   1126:                                                                       $concept;
                   1127:                     }
1.32      matthew  1128:                 } elsif ($key =~ /^(unit|incorrect|answer|ans_low|ans_high|str_type)$/) {
1.4       matthew  1129:                     $Partdata{$part}->{$key}=$value;
                   1130:                 }
                   1131:             } else {
                   1132:                 if ($key=~ /^foil\.text\.(.*)$/) {
                   1133:                     my $foil = $1;
                   1134:                     $Partdata{$part}->{'_Foils'}->{$foil}->{'name'}=$foil;
                   1135:                     $value =~ s/(\s*$|^\s*)//g;
                   1136:                     $Partdata{$part}->{'_Foils'}->{$foil}->{'text'}=$value;
                   1137:                 } elsif ($key =~ /^foil\.value\.(.*)$/) {
                   1138:                     my $foil = $1;
                   1139:                     $Partdata{$part}->{'_Foils'}->{$foil}->{'value'}=$value;
1.28      matthew  1140:                 } elsif ($key eq 'answercomputed') {
                   1141:                     $Partdata{$part}->{'answercomputed'} = $value;
1.4       matthew  1142:                 }
                   1143:             }
                   1144:         }
                   1145:     }
1.28      matthew  1146:     # Further debugging code
                   1147:     if (0) {
                   1148:         &Apache::lonnet::logthis('lonstathelpers::get_problem_data');
                   1149:         &log_hash_ref(\%Partdata);
                   1150:     }
1.4       matthew  1151:     return %Partdata;
1.5       matthew  1152: }
                   1153: 
1.28      matthew  1154: sub log_array_ref {
                   1155:     my ($arrayref,$prefix) = @_;
                   1156:     return if (ref($arrayref) ne 'ARRAY');
                   1157:     if (! defined($prefix)) { $prefix = ''; };
                   1158:     foreach my $v (@$arrayref) {
                   1159:         if (ref($v) eq 'ARRAY') {
                   1160:             &log_array_ref($v,$prefix.'  ');
                   1161:         } elsif (ref($v) eq 'HASH') {
                   1162:             &log_hash_ref($v,$prefix.'  ');
                   1163:         } else {
                   1164:             &Apache::lonnet::logthis($prefix.'"'.$v.'"');
                   1165:         }
                   1166:     }
                   1167: }
                   1168: 
                   1169: sub log_hash_ref {
                   1170:     my ($hashref,$prefix) = @_;
                   1171:     return if (ref($hashref) ne 'HASH');
                   1172:     if (! defined($prefix)) { $prefix = ''; };
                   1173:     while (my ($k,$v) = each(%$hashref)) {
                   1174:         if (ref($v) eq 'ARRAY') {
                   1175:             &Apache::lonnet::logthis($prefix.'"'.$k.'" = array');
                   1176:             &log_array_ref($v,$prefix.'  ');
                   1177:         } elsif (ref($v) eq 'HASH') {
                   1178:             &Apache::lonnet::logthis($prefix.'"'.$k.'" = hash');
                   1179:             &log_hash_ref($v,$prefix.'  ');
                   1180:         } else {
                   1181:             &Apache::lonnet::logthis($prefix.'"'.$k.'" => "'.$v.'"');
                   1182:         }
                   1183:     }
                   1184: }
1.5       matthew  1185: ####################################################
                   1186: ####################################################
                   1187: 
                   1188: =pod
                   1189: 
                   1190: =item &limit_by_time()
                   1191: 
                   1192: =cut
                   1193: 
                   1194: ####################################################
                   1195: ####################################################
                   1196: sub limit_by_time_form {
                   1197:     my $Starttime_form = '';
                   1198:     my $starttime = &Apache::lonhtmlcommon::get_date_from_form
                   1199:         ('limitby_startdate');
                   1200:     my $endtime = &Apache::lonhtmlcommon::get_date_from_form
                   1201:         ('limitby_enddate');
                   1202:     if (! defined($endtime)) {
                   1203:         $endtime = time;
                   1204:     }
                   1205:     if (! defined($starttime)) {
                   1206:         $starttime = $endtime - 60*60*24*7;
                   1207:     }
                   1208:     my $state;
                   1209:     if (&limit_by_time()) {
                   1210:         $state = '';
                   1211:     } else {
                   1212:         $state = 'disabled';
                   1213:     }
                   1214:     my $startdateform = &Apache::lonhtmlcommon::date_setter
                   1215:         ('Statistics','limitby_startdate',$starttime,undef,undef,$state);
                   1216:     my $enddateform = &Apache::lonhtmlcommon::date_setter
                   1217:         ('Statistics','limitby_enddate',$endtime,undef,undef,$state);
                   1218:     my $Str;
                   1219:     $Str .= '<script language="Javascript" >';
                   1220:     $Str .= 'function toggle_limitby_activity(state) {';
                   1221:     $Str .= '    if (state) {';
                   1222:     $Str .= '        limitby_startdate_enable();';
                   1223:     $Str .= '        limitby_enddate_enable();';
                   1224:     $Str .= '    } else {';
                   1225:     $Str .= '        limitby_startdate_disable();';
                   1226:     $Str .= '        limitby_enddate_disable();';
                   1227:     $Str .= '    }';    
                   1228:     $Str .= '}';
                   1229:     $Str .= '</script>';
                   1230:     $Str .= '<fieldset>';
                   1231:     my $timecheckbox = '<input type="checkbox" name="limit_by_time" ';
                   1232:     if (&limit_by_time()) {
                   1233:         $timecheckbox .= ' checked ';
                   1234:     } 
                   1235:     $timecheckbox .= 'OnChange="javascript:toggle_limitby_activity(this.checked);" ';
                   1236:     $timecheckbox .= ' />';
                   1237:     $Str .= '<legend>'.&mt('[_1] Limit by time',$timecheckbox).'</legend>';
                   1238:     $Str .= &mt('Start Time: [_1]',$startdateform).'<br />';
                   1239:     $Str .= &mt('&nbsp;End Time: [_1]',$enddateform).'<br />';
                   1240:     $Str .= '</fieldset>';
                   1241:     return $Str;
                   1242: }
                   1243: 
                   1244: sub limit_by_time {
                   1245:     if (exists($ENV{'form.limit_by_time'}) &&
                   1246:         $ENV{'form.limit_by_time'} ne '' ) {
                   1247:         return 1;
                   1248:     } else {
                   1249:         return 0;
                   1250:     }
                   1251: }
                   1252: 
                   1253: sub get_time_limits {
                   1254:     my $starttime = &Apache::lonhtmlcommon::get_date_from_form
                   1255:         ('limitby_startdate');
                   1256:     my $endtime = &Apache::lonhtmlcommon::get_date_from_form
                   1257:         ('limitby_enddate');
                   1258:     return ($starttime,$endtime);
1.11      matthew  1259: }
                   1260: 
                   1261: 
                   1262: 
                   1263: ####################################################
                   1264: ####################################################
                   1265: 
                   1266: =pod
                   1267: 
                   1268: =item sections_description 
                   1269: 
                   1270: Inputs: @Sections, an array of sections
                   1271: 
                   1272: Returns: A text description of the sections selected.
                   1273: 
                   1274: =cut
                   1275: 
                   1276: ####################################################
                   1277: ####################################################
                   1278: sub sections_description {
                   1279:     my @Sections = @_;
                   1280:     my $sectionstring = '';
                   1281:     if (scalar(@Sections) > 1) {
                   1282:         if (scalar(@Sections) > 2) {
                   1283:             my $last = pop(@Sections);
                   1284:             $sectionstring = "Sections ".join(', ',@Sections).', and '.$last;
                   1285:         } else {
                   1286:             $sectionstring = "Sections ".join(' and ',@Sections);
                   1287:         }
                   1288:     } else {
                   1289:         if ($Sections[0] eq 'all') {
                   1290:             $sectionstring = "All sections";
                   1291:         } else {
                   1292:             $sectionstring = "Section ".$Sections[0];
                   1293:         }
                   1294:     }
                   1295:     return $sectionstring;
1.2       matthew  1296: }
                   1297: 
                   1298: ####################################################
                   1299: ####################################################
                   1300: 
                   1301: =pod
                   1302: 
1.12      matthew  1303: =item &manage_caches
                   1304: 
                   1305: Inputs: $r, apache request object
                   1306: 
                   1307: Returns: An array of scalars containing html for buttons.
                   1308: 
                   1309: =cut
                   1310: 
                   1311: ####################################################
                   1312: ####################################################
                   1313: sub manage_caches {
1.23      matthew  1314:     my ($r,$formname,$inputname,$update_message) = @_;
1.12      matthew  1315:     &Apache::loncoursedata::clear_internal_caches();
1.16      matthew  1316:     my $sectionkey = 
                   1317:         join(',',
                   1318:              map {
                   1319:                      &Apache::lonnet::escape($_);
                   1320:                  } sort(@Apache::lonstatistics::SelectedSections)
                   1321:              );
                   1322:     my $statuskey = $Apache::lonstatistics::enrollment_status;
1.12      matthew  1323:     if (exists($ENV{'form.ClearCache'}) || 
1.16      matthew  1324:         exists($ENV{'form.updatecaches'}) || 
                   1325:         (exists($ENV{'form.firstrun'}) && $ENV{'form.firstrun'} ne 'no') ||
                   1326:         (exists($ENV{'form.prevsection'}) &&
                   1327:             $ENV{'form.prevsection'} ne $sectionkey) ||
                   1328:         (exists($ENV{'form.prevenrollstatus'}) &&
                   1329:             $ENV{'form.prevenrollstatus'} ne $statuskey)
                   1330:         ) {
1.23      matthew  1331:         if (defined($update_message)) {
                   1332:             $r->print($update_message);
                   1333:         }
1.36      matthew  1334:         &gather_full_student_data($r,$formname,$inputname);
1.12      matthew  1335:     }
                   1336:     #
1.16      matthew  1337:     my @Buttons = 
                   1338:         ('<input type="submit" name="ClearCache" '.
                   1339:              'value="'.&mt('Clear Caches').'" />',
                   1340:          '<input type="submit" name="updatecaches" '.
1.17      matthew  1341:              'value="'.&mt('Update Caches').'" />'.
                   1342:          &Apache::loncommon::help_open_topic('Statistics_Cache'),
1.16      matthew  1343:          '<input type="hidden" name="prevsection" value="'.$sectionkey.'" />',
                   1344:          '<input type="hidden" name="prevenrollstatus" value="'.$statuskey.'" />'
                   1345:          );
                   1346:     #
1.12      matthew  1347:     if (! exists($ENV{'form.firstrun'})) {
                   1348:         $r->print('<input type="hidden" name="firstrun" value="yes" />');
                   1349:     } else {
                   1350:         $r->print('<input type="hidden" name="firstrun" value="no" />');
                   1351:     }
                   1352:     #
                   1353:     return @Buttons;
                   1354: }
                   1355: 
1.36      matthew  1356: sub gather_full_student_data {
                   1357:     my ($r,$formname,$inputname) = @_;
                   1358:     my $status_type;
                   1359:     if (defined($formname)) {
                   1360:         $status_type = 'inline';
                   1361:     } else {
                   1362:         $status_type = 'popup';
                   1363:     }
                   1364:     my $c = $r->connection();
                   1365:     #
                   1366:     &Apache::loncoursedata::clear_internal_caches();
                   1367:     #
                   1368:     my @Students = @Apache::lonstatistics::Students;
                   1369:     #
                   1370:     # Open the progress window
                   1371:     my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin
                   1372:         ($r,&mt('Student Data Compilation Status'),
                   1373:          &mt('Student Data Compilation Progress'), scalar(@Students),
                   1374:          $status_type,undef,$formname,$inputname);
                   1375:     #
                   1376:     while (my $student = shift @Students) {
                   1377:         return if ($c->aborted());
                   1378:         my $status = &Apache::loncoursedata::ensure_current_full_data
                   1379:             ($student->{'username'},$student->{'domain'},
                   1380:              $ENV{'request.course.id'});
                   1381:         &Apache::lonhtmlcommon::Increment_PrgWin($r,\%prog_state,
                   1382:                                                  &mt('last student'));
                   1383:     }
                   1384:     &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state);
                   1385:     $r->rflush();
                   1386:     return;
                   1387: }
1.12      matthew  1388: 
                   1389: 
                   1390: ####################################################
                   1391: ####################################################
                   1392: 
                   1393: =pod
                   1394: 
1.2       matthew  1395: =back
                   1396: 
                   1397: =cut
                   1398: 
                   1399: ####################################################
                   1400: ####################################################
1.1       matthew  1401: 
                   1402: 1;
                   1403: 
                   1404: __END__

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