loncom/interface/statistics/lonstathelpers.pm - view

File: [LON-CAPA] / loncom / interface / statistics / lonstathelpers.pm
Revision 1.23: download - view: text, annotated - select for diffs
Thu Sep 16 21:54:22 2004 UTC (19 years, 10 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

lonstathelpers: removed $ResponseTypes input from MultipleProblemSelector
Added parameter $update_message to manage_caches.
lonstudentsubmissions:Removed useless calls to get_problem_data, added
warning about the amount of time it takes to compute correct answers,
new_excel_output: determine number of columns we will use in the excel
  spreadsheet and abort if it's too many, added support for correct answer
  printing
added &get_problem_data which is not currently used and probably won't be
Excel output is the only working output still.

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