loncom/interface/statistics/lonstathelpers.pm - view

File: [LON-CAPA] / loncom / interface / statistics / lonstathelpers.pm
Revision 1.12: download - view: text, annotated - select for diffs
Fri Jun 4 21:42:18 2004 UTC (20 years ago) by matthew
Branches: MAIN
CVS tags: version_1_1_99_0, HEAD

Unified cache handling among statistics routines.  All use inlined progress
dialog.
&lonstatistics:&Gather_Full_Student_data now takes $formname and $inputname
    for inlined progress dialog.
&lonstathelpers: All calls to lonstatistics::Sequences_with_Assess now pass
    parameter 'all' in for mode.  Added &manage_caches which takes care of
    updating student data at the right times.  "right times" may need some
    work.  &GetStudentAnswers now takes $formname, $inputname as parameters.
&lonproblemanalysis, &lonproblemstatistics, and &lonsubmissiontimeanalysis:
    Use lonstathelpers::manage_caches and inline progress dialog.
&lonstudentsubmissions: Uses lonstathelpers::manage_caches and inlines prgwin
    Uses inlined prgwin to display further status data.

1: # The LearningOnline Network with CAPA 2: # 3: # $Id: lonstathelpers.pm,v 1.12 2004/06/04 21:42:18 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: 44: =over 4 45: 46: =cut 47: 48: #################################################### 49: #################################################### 50: package Apache::lonstathelpers; 51: 52: use strict; 53: use Apache::lonnet(); 54: use Apache::loncommon(); 55: use Apache::lonhtmlcommon(); 56: use Apache::loncoursedata(); 57: use Apache::lonstatistics; 58: use Apache::lonlocal; 59: use HTML::Entities(); 60: use Time::Local(); 61: use Spreadsheet::WriteExcel(); 62: use GDBM_File; 63: use Storable qw(freeze thaw); 64: 65: #################################################### 66: #################################################### 67: 68: =pod 69: 70: =item &render_resource($resource) 71: 72: Input: a resource generated from 73: &Apache::loncoursedata::get_sequence_assessment_data(). 74: 75: Retunrs: a scalar containing html for a rendering of the problem 76: within a table. 77: 78: =cut 79: 80: #################################################### 81: #################################################### 82: sub render_resource { 83: my ($resource) = @_; 84: ## 85: ## Render the problem 86: my $base; 87: ($base,undef) = ($resource->{'src'} =~ m|(.*/)[^/]*$|); 88: $base = "http://".$ENV{'SERVER_NAME'}.$base; 89: my $rendered_problem = 90: &Apache::lonnet::ssi_body($resource->{'src'}); 91: $rendered_problem =~ s/<\s*form\s*/<nop /g; 92: $rendered_problem =~ s|(<\s*/form\s*>)|<\/nop>|g; 93: return '<table bgcolor="ffffff"><tr><td>'. 94: '<base href="'.$base.'" />'. 95: $rendered_problem. 96: '</td></tr></table>'; 97: } 98: 99: #################################################### 100: #################################################### 101: 102: =pod 103: 104: =item &ProblemSelector($AcceptedResponseTypes) 105: 106: Input: scalar containing regular expression which matches response 107: types to show. '.' will yield all, '(option|radiobutton)' will match 108: all option response and radiobutton problems. 109: 110: Returns: A string containing html for a table which lists the sequences 111: and their contents. A radiobutton is provided for each problem. 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 &make_target_id($target) 173: 174: Inputs: Hash ref with the following entries: 175: $target->{'symb'}, $target->{'part'}, $target->{'respid'}, 176: $target->{'resptype'}. 177: 178: Returns: A string, suitable for a form parameter, which uniquely identifies 179: the problem, part, and response to do statistical analysis on. 180: 181: Used by Apache::lonstathelpers::ProblemSelector(). 182: 183: =cut 184: 185: #################################################### 186: #################################################### 187: sub make_target_id { 188: my ($target) = @_; 189: my $id = &Apache::lonnet::escape($target->{'symb'}).':'. 190: &Apache::lonnet::escape($target->{'part'}).':'. 191: &Apache::lonnet::escape($target->{'respid'}).':'. 192: &Apache::lonnet::escape($target->{'resptype'}); 193: return $id; 194: } 195: 196: #################################################### 197: #################################################### 198: 199: =pod 200: 201: =item &get_target_from_id($id) 202: 203: Inputs: $id, a scalar string from Apache::lonstathelpers::make_target_id(). 204: 205: Returns: A hash reference, $target, containing the following keys: 206: $target->{'symb'}, $target->{'part'}, $target->{'respid'}, 207: $target->{'resptype'}. 208: 209: =cut 210: 211: #################################################### 212: #################################################### 213: sub get_target_from_id { 214: my ($id) = @_; 215: my ($symb,$part,$respid,$resptype) = split(':',$id); 216: return ({ symb =>&Apache::lonnet::unescape($symb), 217: part =>&Apache::lonnet::unescape($part), 218: respid =>&Apache::lonnet::unescape($respid), 219: resptype =>&Apache::lonnet::unescape($resptype)}); 220: } 221: 222: #################################################### 223: #################################################### 224: 225: =pod 226: 227: =item &get_prev_curr_next($target) 228: 229: Determine the problem parts or responses preceeding and following the 230: current resource. 231: 232: Inputs: $target (see &Apache::lonstathelpers::get_target_from_id()) 233: $AcceptableResponseTypes, regular expression matching acceptable 234: response types, 235: $granularity, either 'part' or 'response' 236: 237: Returns: three hash references, $prev, $curr, $next, which refer to the 238: preceeding, current, or following problem parts or responses, depending 239: on the value of $granularity. Values of undef indicate there is no 240: previous or next part/response. A value of undef for all three indicates 241: there was no match found to the current part/resource. 242: 243: The hash references contain the following keys: 244: symb, part, resource 245: 246: If $granularity eq 'response', the following ADDITIONAL keys will be present: 247: respid, resptype 248: 249: =cut 250: 251: #################################################### 252: #################################################### 253: sub get_prev_curr_next { 254: my ($target,$AcceptableResponseTypes,$granularity) = @_; 255: # 256: # Build an array with the data we need to search through 257: my @Resource; 258: foreach my $seq (&Apache::lonstatistics::Sequences_with_Assess('all')) { 259: foreach my $res (@{$seq->{'contents'}}) { 260: next if ($res->{'type'} ne 'assessment'); 261: foreach my $part (@{$res->{'parts'}}) { 262: my $partdata = $res->{'partdata'}->{$part}; 263: if ($granularity eq 'part') { 264: push (@Resource, 265: { symb => $res->{symb}, 266: part => $part, 267: resource => $res, 268: } ); 269: } elsif ($granularity eq 'response') { 270: for (my $i=0; 271: $i<scalar(@{$partdata->{'ResponseTypes'}}); 272: $i++){ 273: my $respid = $partdata->{'ResponseIds'}->[$i]; 274: my $resptype = $partdata->{'ResponseTypes'}->[$i]; 275: next if ($resptype !~ m/$AcceptableResponseTypes/); 276: push (@Resource, 277: { symb => $res->{symb}, 278: part => $part, 279: respid => $partdata->{'ResponseIds'}->[$i], 280: resource => $res, 281: resptype => $resptype 282: } ); 283: } 284: } 285: } 286: } 287: } 288: # 289: # Get the index of the current situation 290: my $curr_idx; 291: for ($curr_idx=0;$curr_idx<$#Resource;$curr_idx++) { 292: my $curr_item = $Resource[$curr_idx]; 293: if ($granularity eq 'part') { 294: if ($curr_item->{'symb'} eq $target->{'symb'} && 295: $curr_item->{'part'} eq $target->{'part'}) { 296: last; 297: } 298: } elsif ($granularity eq 'response') { 299: if ($curr_item->{'symb'} eq $target->{'symb'} && 300: $curr_item->{'part'} eq $target->{'part'} && 301: $curr_item->{'respid'} eq $target->{'respid'} && 302: $curr_item->{'resptype'} eq $target->{'resptype'}) { 303: last; 304: } 305: } 306: } 307: my $curr_item = $Resource[$curr_idx]; 308: if ($granularity eq 'part') { 309: if ($curr_item->{'symb'} ne $target->{'symb'} || 310: $curr_item->{'part'} ne $target->{'part'}) { 311: # bogus symb - return nothing 312: return (undef,undef,undef); 313: } 314: } elsif ($granularity eq 'response') { 315: if ($curr_item->{'symb'} ne $target->{'symb'} || 316: $curr_item->{'part'} ne $target->{'part'} || 317: $curr_item->{'respid'} ne $target->{'respid'} || 318: $curr_item->{'resptype'} ne $target->{'resptype'}){ 319: # bogus symb - return nothing 320: return (undef,undef,undef); 321: } 322: } 323: # 324: # Now just pick up the data we need 325: my ($prev,$curr,$next); 326: if ($curr_idx == 0) { 327: $prev = undef; 328: $curr = $Resource[$curr_idx ]; 329: $next = $Resource[$curr_idx+1]; 330: } elsif ($curr_idx == $#Resource) { 331: $prev = $Resource[$curr_idx-1]; 332: $curr = $Resource[$curr_idx ]; 333: $next = undef; 334: } else { 335: $prev = $Resource[$curr_idx-1]; 336: $curr = $Resource[$curr_idx ]; 337: $next = $Resource[$curr_idx+1]; 338: } 339: return ($prev,$curr,$next); 340: } 341: 342: 343: ##################################################### 344: ##################################################### 345: 346: =pod 347: 348: =item GetStudentAnswers($r,$problem,$Students) 349: 350: Determines the correct answer for a set of students on a given problem. 351: The students answers are stored in the student hashes pointed to by the 352: array @$Students under the key 'answer'. 353: 354: Inputs: $r 355: $problem: hash reference containing the keys 'resource', 'part', and 'respid'. 356: $Students: reference to array containing student hashes (need 'username', 357: 'domain'). 358: 359: Returns: nothing 360: 361: =cut 362: 363: ##################################################### 364: ##################################################### 365: sub GetStudentAnswers { 366: my ($r,$problem,$Students,$formname,$inputname) = @_; 367: my $status_type; 368: if (defined($formname)) { 369: $status_type = 'inline'; 370: } else { 371: $status_type = 'popup'; 372: } 373: my $c = $r->connection(); 374: my %Answers; 375: my ($resource,$partid,$respid) = ($problem->{'resource'}, 376: $problem->{'part'}, 377: $problem->{'respid'}); 378: # Read in the cache (if it exists) before we start timing things. 379: &Apache::lonstathelpers::ensure_proper_cache($resource->{'symb'}); 380: # Open progress window 381: my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin 382: ($r,'Student Answer Compilation Status', 383: 'Student Answer Compilation Progress', scalar(@$Students), 384: $status_type,undef,$formname,$inputname); 385: $r->rflush(); 386: foreach my $student (@$Students) { 387: last if ($c->aborted()); 388: my $sname = $student->{'username'}; 389: my $sdom = $student->{'domain'}; 390: my $answer = &Apache::lonstathelpers::analyze_problem_as_student 391: ($resource,$sname,$sdom,$partid,$respid); 392: &Apache::lonhtmlcommon::Increment_PrgWin($r,\%prog_state, 393: &mt('last student')); 394: $student->{'answer'} = $answer; 395: } 396: &Apache::lonstathelpers::write_answer_cache(); 397: return if ($c->aborted()); 398: $r->rflush(); 399: # close progress window 400: &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state); 401: return; 402: } 403: 404: ##################################################### 405: ##################################################### 406: 407: =pod 408: 409: =item analyze_problem_as_student 410: 411: Analyzes a homework problem for a student and returns the correct answer 412: for the student. Attempts to put together an answer for problem types 413: that do not natively support it. 414: 415: Inputs: $resource: a resource object 416: $sname, $sdom, $partid, $respid 417: 418: Returns: $answer 419: 420: If $partid and $respid are specified, $answer is simply a scalar containing 421: the correct answer for the response. 422: 423: If $partid or $respid are undefined, $answer will be a hash reference with 424: keys $partid.'.'.$respid.'.answer'. 425: 426: =cut 427: 428: ##################################################### 429: ##################################################### 430: sub analyze_problem_as_student { 431: my ($resource,$sname,$sdom,$partid,$respid) = @_; 432: my $returnvalue; 433: my $url = $resource->{'src'}; 434: my $symb = $resource->{'symb'}; 435: my $answer = &get_from_answer_cache($sname,$sdom,$symb,$partid,$respid); 436: if (defined($answer)) { 437: return($answer); 438: } 439: my $courseid = $ENV{'request.course.id'}; 440: my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze', 441: 'grade_domain' => $sdom, 442: 'grade_username' => $sname, 443: 'grade_symb' => $symb, 444: 'grade_courseid' => $courseid)); 445: (my $garbage,$Answ)=split(/_HASH_REF__/,$Answ,2); 446: my %Answer=&Apache::lonnet::str2hash($Answ); 447: # 448: undef($answer); 449: foreach my $partid (@{$resource->{'parts'}}) { 450: my $partdata = $resource->{'partdata'}->{$partid}; 451: foreach my $respid (@{$partdata->{'ResponseIds'}}) { 452: my $prefix = $partid.'.'.$respid; 453: my $key = $prefix.'.answer'; 454: $answer->{$partid}->{$respid} = &get_answer($prefix,$key,%Answer); 455: } 456: } 457: &store_answer($sname,$sdom,$symb,undef,undef,$answer); 458: if (! defined($partid)) { 459: $returnvalue = $answer; 460: } elsif (! defined($respid)) { 461: $returnvalue = $answer->{$partid}; 462: } else { 463: $returnvalue = $answer->{$partid}->{$respid}; 464: } 465: return $returnvalue; 466: } 467: 468: sub get_answer { 469: my ($prefix,$key,%Answer) = @_; 470: my $returnvalue; 471: if (exists($Answer{$key})) { 472: my $student_answer = $Answer{$key}->[0]; 473: if (! defined($student_answer)) { 474: $student_answer = $Answer{$key}->[1]; 475: } 476: $returnvalue = $student_answer; 477: } else { 478: if (exists($Answer{$prefix.'.shown'})) { 479: # The response has foils 480: my %values; 481: while (my ($k,$v) = each(%Answer)) { 482: next if ($k !~ /^$prefix\.foil\.(value|area)\.(.*)$/); 483: my $foilname = $2; 484: $values{$foilname}=$v; 485: } 486: foreach my $foil (@{$Answer{$prefix.'.shown'}}) { 487: if (ref($values{$foil}) eq 'ARRAY') { 488: $returnvalue.=&HTML::Entities::encode($foil,'<>&"').'='. 489: join(',',map {&HTML::Entities::encode($_,'<>&"')} @{$values{$foil}}).'&'; 490: } else { 491: $returnvalue.=&HTML::Entities::encode($foil,'<>&"').'='. 492: &HTML::Entities::encode($values{$foil},'<>&"').'&'; 493: } 494: } 495: $returnvalue =~ s/ /\%20/g; 496: chop ($returnvalue); 497: } 498: } 499: return $returnvalue; 500: } 501: 502: 503: ##################################################### 504: ##################################################### 505: 506: =pod 507: 508: =item Caching routines 509: 510: =over 4 511: 512: =item &load_answer_cache($symb) 513: 514: Loads the cache for the given symb into memory from disk. 515: Requires the cache filename be set. 516: Only should be called by &ensure_proper_cache. 517: 518: =cut 519: 520: ##################################################### 521: ##################################################### 522: { 523: my $cache_filename = undef; 524: my $current_symb = undef; 525: my %cache; 526: 527: sub load_answer_cache { 528: my ($symb) = @_; 529: return if (! defined($cache_filename)); 530: if (! defined($current_symb) || $current_symb ne $symb) { 531: undef(%cache); 532: my $storedstring; 533: my %cache_db; 534: if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_READER(),0640)) { 535: $storedstring = $cache_db{&Apache::lonnet::escape($symb)}; 536: untie(%cache_db); 537: } 538: if (defined($storedstring)) { 539: %cache = %{thaw($storedstring)}; 540: } 541: } 542: return; 543: } 544: 545: ##################################################### 546: ##################################################### 547: 548: =pod 549: 550: =item &get_from_answer_cache($sname,$sdom,$symb,$partid,$respid) 551: 552: Returns the appropriate data from the cache, or undef if no data exists. 553: If $respid is undefined, a hash ref containing the answers for the given 554: $partid is returned. If $partid is undefined, a hash ref containing answers 555: for all of the parts is returned. 556: 557: =cut 558: 559: ##################################################### 560: ##################################################### 561: sub get_from_answer_cache { 562: my ($sname,$sdom,$symb,$partid,$respid) = @_; 563: &ensure_proper_cache($symb); 564: my $returnvalue; 565: if (exists($cache{$sname.':'.$sdom}) && 566: ref($cache{$sname.':'.$sdom}) eq 'HASH') { 567: if (defined($partid) && 568: exists($cache{$sname.':'.$sdom}->{$partid})) { 569: if (defined($respid) && 570: exists($cache{$sname.':'.$sdom}->{$partid}->{$respid})) { 571: $returnvalue = $cache{$sname.':'.$sdom}->{$partid}->{$respid}; 572: } else { 573: $returnvalue = $cache{$sname.':'.$sdom}->{$partid}; 574: } 575: } else { 576: $returnvalue = $cache{$sname.':'.$sdom}; 577: } 578: } else { 579: $returnvalue = undef; 580: } 581: return $returnvalue; 582: } 583: 584: ##################################################### 585: ##################################################### 586: 587: =pod 588: 589: =item &write_answer_cache($symb) 590: 591: Writes the in memory cache to disk so that it can be read in with 592: &load_answer_cache($symb). 593: 594: =cut 595: 596: ##################################################### 597: ##################################################### 598: sub write_answer_cache { 599: return if (! defined($current_symb) || ! defined($cache_filename)); 600: my %cache_db; 601: my $key = &Apache::lonnet::escape($current_symb); 602: if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_WRCREAT(),0640)) { 603: my $storestring = freeze(\%cache); 604: $cache_db{$key}=$storestring; 605: $cache_db{$key.'.time'}=time; 606: untie(%cache_db); 607: } 608: undef(%cache); 609: undef($current_symb); 610: undef($cache_filename); 611: return; 612: } 613: 614: ##################################################### 615: ##################################################### 616: 617: =pod 618: 619: =item &ensure_proper_cache($symb) 620: 621: Called to make sure we have the proper cache set up. This is called 622: prior to every answer lookup. 623: 624: =cut 625: 626: ##################################################### 627: ##################################################### 628: sub ensure_proper_cache { 629: my ($symb) = @_; 630: my $cid = $ENV{'request.course.id'}; 631: my $new_filename = '/home/httpd/perl/tmp/'. 632: 'problemanalsysis_'.$cid.'answer_cache.db'; 633: if (! defined($cache_filename) || 634: $cache_filename ne $new_filename || 635: ! defined($current_symb) || 636: $current_symb ne $symb) { 637: $cache_filename = $new_filename; 638: # Notice: $current_symb is not set to $symb until after the cache is 639: # loaded. This is what tells &load_answer_cache to load in a new 640: # symb cache. 641: &load_answer_cache($symb); 642: $current_symb = $symb; 643: } 644: } 645: 646: ##################################################### 647: ##################################################### 648: 649: =pod 650: 651: =item &store_answer($sname,$sdom,$symb,$partid,$respid,$dataset) 652: 653: Stores the answer data in the in memory cache. 654: 655: =cut 656: 657: ##################################################### 658: ##################################################### 659: sub store_answer { 660: my ($sname,$sdom,$symb,$partid,$respid,$dataset) = @_; 661: return if ($symb ne $current_symb); 662: if (defined($partid)) { 663: if (defined($respid)) { 664: $cache{$sname.':'.$sdom}->{$partid}->{$respid} = $dataset; 665: } else { 666: $cache{$sname.':'.$sdom}->{$partid} = $dataset; 667: } 668: } else { 669: $cache{$sname.':'.$sdom}=$dataset; 670: } 671: return; 672: } 673: 674: } 675: ##################################################### 676: ##################################################### 677: 678: =pod 679: 680: =back 681: 682: =cut 683: 684: ##################################################### 685: ##################################################### 686: 687: ## 688: ## The following is copied from datecalc1.pl, part of the 689: ## Spreadsheet::WriteExcel CPAN module. 690: ## 691: ## 692: ###################################################################### 693: # 694: # Demonstration of writing date/time cells to Excel spreadsheets, 695: # using UNIX/Perl time as source of date/time. 696: # 697: # Copyright 2000, Andrew Benham, adsb@bigfoot.com 698: # 699: ###################################################################### 700: # 701: # UNIX/Perl time is the time since the Epoch (00:00:00 GMT, 1 Jan 1970) 702: # measured in seconds. 703: # 704: # An Excel file can use exactly one of two different date/time systems. 705: # In these systems, a floating point number represents the number of days 706: # (and fractional parts of the day) since a start point. The floating point 707: # number is referred to as a 'serial'. 708: # The two systems ('1900' and '1904') use different starting points: 709: # '1900'; '1.00' is 1 Jan 1900 BUT 1900 is erroneously regarded as 710: # a leap year - see: 711: # http://support.microsoft.com/support/kb/articles/Q181/3/70.asp 712: # for the excuse^H^H^H^H^H^Hreason. 713: # '1904'; '1.00' is 2 Jan 1904. 714: # 715: # The '1904' system is the default for Apple Macs. Windows versions of 716: # Excel have the option to use the '1904' system. 717: # 718: # Note that Visual Basic's "DateSerial" function does NOT erroneously 719: # regard 1900 as a leap year, and thus its serials do not agree with 720: # the 1900 serials of Excel for dates before 1 Mar 1900. 721: # 722: # Note that StarOffice (at least at version 5.2) does NOT erroneously 723: # regard 1900 as a leap year, and thus its serials do not agree with 724: # the 1900 serials of Excel for dates before 1 Mar 1900. 725: # 726: ###################################################################### 727: # 728: # Calculation description 729: # ======================= 730: # 731: # 1900 system 732: # ----------- 733: # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 70 years after 1 Jan 1900. 734: # Of those 70 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68) 735: # were leap years with an extra day. 736: # Thus there were 17 + 70*365 days = 25567 days between 1 Jan 1900 and 737: # 1 Jan 1970. 738: # In the 1900 system, '1' is 1 Jan 1900, but as 1900 was not a leap year 739: # 1 Jan 1900 should really be '2', so 1 Jan 1970 is '25569'. 740: # 741: # 1904 system 742: # ----------- 743: # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 66 years after 1 Jan 1904. 744: # Of those 66 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68) 745: # were leap years with an extra day. 746: # Thus there were 17 + 66*365 days = 24107 days between 1 Jan 1904 and 747: # 1 Jan 1970. 748: # In the 1904 system, 2 Jan 1904 being '1', 1 Jan 1970 is '24107'. 749: # 750: ###################################################################### 751: # 752: # Copyright (c) 2000, Andrew Benham. 753: # This program is free software. It may be used, redistributed and/or 754: # modified under the same terms as Perl itself. 755: # 756: # Andrew Benham, adsb@bigfoot.com 757: # London, United Kingdom 758: # 11 Nov 2000 759: # 760: ###################################################################### 761: #----------------------------------------------------------- 762: # calc_serial() 763: # 764: # Called with (up to) 2 parameters. 765: # 1. Unix timestamp. If omitted, uses current time. 766: # 2. GMT flag. Set to '1' to return serial in GMT. 767: # If omitted, returns serial in appropriate timezone. 768: # 769: # Returns date/time serial according to $DATE_SYSTEM selected 770: #----------------------------------------------------------- 771: sub calc_serial { 772: # Use 1900 date system on all platforms other than Apple Mac (for which 773: # use 1904 date system). 774: my $DATE_SYSTEM = ($^O eq 'MacOS') ? 1 : 0; 775: my $time = (defined $_[0]) ? $_[0] : time(); 776: my $gmtflag = (defined $_[1]) ? $_[1] : 0; 777: # 778: # Divide timestamp by number of seconds in a day. 779: # This gives a date serial with '0' on 1 Jan 1970. 780: my $serial = $time / 86400; 781: # 782: # Adjust the date serial by the offset appropriate to the 783: # currently selected system (1900/1904). 784: if ($DATE_SYSTEM == 0) { # use 1900 system 785: $serial += 25569; 786: } else { # use 1904 system 787: $serial += 24107; 788: } 789: # 790: unless ($gmtflag) { 791: # Now have a 'raw' serial with the right offset. But this 792: # gives a serial in GMT, which is false unless the timezone 793: # is GMT. We need to adjust the serial by the appropriate 794: # timezone offset. 795: # Calculate the appropriate timezone offset by seeing what 796: # the differences between localtime and gmtime for the given 797: # time are. 798: # 799: my @gmtime = gmtime($time); 800: my @ltime = localtime($time); 801: # 802: # For the first 7 elements of the two arrays, adjust the 803: # date serial where the elements differ. 804: for (0 .. 6) { 805: my $diff = $ltime[$_] - $gmtime[$_]; 806: if ($diff) { 807: $serial += _adjustment($diff,$_); 808: } 809: } 810: } 811: # 812: # Perpetuate the error that 1900 was a leap year by decrementing 813: # the serial if we're using the 1900 system and the date is prior to 814: # 1 Mar 1900. This has the effect of making serial value '60' 815: # 29 Feb 1900. 816: # 817: # This fix only has any effect if UNIX/Perl time on the platform 818: # can represent 1900. Many can't. 819: # 820: unless ($DATE_SYSTEM) { 821: $serial-- if ($serial < 61); # '61' is 1 Mar 1900 822: } 823: return $serial; 824: } 825: 826: sub _adjustment { 827: # Based on the difference in the localtime/gmtime array elements 828: # number, return the adjustment required to the serial. 829: # 830: # We only look at some elements of the localtime/gmtime arrays: 831: # seconds unlikely to be different as all known timezones 832: # have an offset of integral multiples of 15 minutes, 833: # but it's easy to do. 834: # minutes will be different for timezone offsets which are 835: # not an exact number of hours. 836: # hours very likely to be different. 837: # weekday will differ when localtime/gmtime difference 838: # straddles midnight. 839: # 840: # Assume that difference between localtime and gmtime is less than 841: # 5 days, then don't have to do maths for day of month, month number, 842: # year number, etc... 843: # 844: my ($delta,$element) = @_; 845: my $adjust = 0; 846: # 847: if ($element == 0) { # Seconds 848: $adjust = $delta/86400; # 60 * 60 * 24 849: } elsif ($element == 1) { # Minutes 850: $adjust = $delta/1440; # 60 * 24 851: } elsif ($element == 2) { # Hours 852: $adjust = $delta/24; # 24 853: } elsif ($element == 6) { # Day of week number 854: # Catch difference straddling Sat/Sun in either direction 855: $delta += 7 if ($delta < -4); 856: $delta -= 7 if ($delta > 4); 857: # 858: $adjust = $delta; 859: } 860: return $adjust; 861: } 862: 863: ########################################################### 864: ########################################################### 865: 866: =pod 867: 868: =item get_problem_data 869: 870: Returns a data structure describing the problem. 871: 872: Inputs: $url 873: 874: Returns: %Partdata 875: 876: =cut 877: 878: ## note: we must force each foil and option to not begin or end with 879: ## spaces as they are stored without such data. 880: ## 881: ########################################################### 882: ########################################################### 883: sub get_problem_data { 884: my ($url) = @_; 885: my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze')); 886: (my $garbage,$Answ)=split(/_HASH_REF__/,$Answ,2); 887: my %Answer; 888: %Answer=&Apache::lonnet::str2hash($Answ); 889: my %Partdata; 890: foreach my $part (@{$Answer{'parts'}}) { 891: while (my($key,$value) = each(%Answer)) { 892: # 893: # Logging code: 894: if (0) { 895: &Apache::lonnet::logthis($part.' got key "'.$key.'"'); 896: if (ref($value) eq 'ARRAY') { 897: &Apache::lonnet::logthis(' @'.join(',',@$value)); 898: } else { 899: &Apache::lonnet::logthis(' '.$value); 900: } 901: } 902: # End of logging code 903: next if ($key !~ /^$part/); 904: $key =~ s/^$part\.//; 905: if (ref($value) eq 'ARRAY') { 906: if ($key eq 'options') { 907: $Partdata{$part}->{'_Options'}=$value; 908: } elsif ($key eq 'concepts') { 909: $Partdata{$part}->{'_Concepts'}=$value; 910: } elsif ($key =~ /^concept\.(.*)$/) { 911: my $concept = $1; 912: foreach my $foil (@$value) { 913: $Partdata{$part}->{'_Foils'}->{$foil}->{'_Concept'}= 914: $concept; 915: } 916: } elsif ($key =~ /^(incorrect|answer|ans_low|ans_high)$/) { 917: $Partdata{$part}->{$key}=$value; 918: } 919: } else { 920: if ($key=~ /^foil\.text\.(.*)$/) { 921: my $foil = $1; 922: $Partdata{$part}->{'_Foils'}->{$foil}->{'name'}=$foil; 923: $value =~ s/(\s*$|^\s*)//g; 924: $Partdata{$part}->{'_Foils'}->{$foil}->{'text'}=$value; 925: } elsif ($key =~ /^foil\.value\.(.*)$/) { 926: my $foil = $1; 927: $Partdata{$part}->{'_Foils'}->{$foil}->{'value'}=$value; 928: } 929: } 930: } 931: } 932: return %Partdata; 933: } 934: 935: #################################################### 936: #################################################### 937: 938: =pod 939: 940: =item &limit_by_time() 941: 942: =cut 943: 944: #################################################### 945: #################################################### 946: sub limit_by_time_form { 947: my $Starttime_form = ''; 948: my $starttime = &Apache::lonhtmlcommon::get_date_from_form 949: ('limitby_startdate'); 950: my $endtime = &Apache::lonhtmlcommon::get_date_from_form 951: ('limitby_enddate'); 952: if (! defined($endtime)) { 953: $endtime = time; 954: } 955: if (! defined($starttime)) { 956: $starttime = $endtime - 60*60*24*7; 957: } 958: my $state; 959: if (&limit_by_time()) { 960: $state = ''; 961: } else { 962: $state = 'disabled'; 963: } 964: my $startdateform = &Apache::lonhtmlcommon::date_setter 965: ('Statistics','limitby_startdate',$starttime,undef,undef,$state); 966: my $enddateform = &Apache::lonhtmlcommon::date_setter 967: ('Statistics','limitby_enddate',$endtime,undef,undef,$state); 968: my $Str; 969: $Str .= '<script language="Javascript" >'; 970: $Str .= 'function toggle_limitby_activity(state) {'; 971: $Str .= ' if (state) {'; 972: $Str .= ' limitby_startdate_enable();'; 973: $Str .= ' limitby_enddate_enable();'; 974: $Str .= ' } else {'; 975: $Str .= ' limitby_startdate_disable();'; 976: $Str .= ' limitby_enddate_disable();'; 977: $Str .= ' }'; 978: $Str .= '}'; 979: $Str .= '</script>'; 980: $Str .= '<fieldset>'; 981: my $timecheckbox = '<input type="checkbox" name="limit_by_time" '; 982: if (&limit_by_time()) { 983: $timecheckbox .= ' checked '; 984: } 985: $timecheckbox .= 'OnChange="javascript:toggle_limitby_activity(this.checked);" '; 986: $timecheckbox .= ' />'; 987: $Str .= '<legend>'.&mt('[_1] Limit by time',$timecheckbox).'</legend>'; 988: $Str .= &mt('Start Time: [_1]',$startdateform).'<br />'; 989: $Str .= &mt(' End Time: [_1]',$enddateform).'<br />'; 990: $Str .= '</fieldset>'; 991: return $Str; 992: } 993: 994: sub limit_by_time { 995: if (exists($ENV{'form.limit_by_time'}) && 996: $ENV{'form.limit_by_time'} ne '' ) { 997: return 1; 998: } else { 999: return 0; 1000: } 1001: } 1002: 1003: sub get_time_limits { 1004: my $starttime = &Apache::lonhtmlcommon::get_date_from_form 1005: ('limitby_startdate'); 1006: my $endtime = &Apache::lonhtmlcommon::get_date_from_form 1007: ('limitby_enddate'); 1008: return ($starttime,$endtime); 1009: } 1010: 1011: 1012: 1013: #################################################### 1014: #################################################### 1015: 1016: =pod 1017: 1018: =item sections_description 1019: 1020: Inputs: @Sections, an array of sections 1021: 1022: Returns: A text description of the sections selected. 1023: 1024: =cut 1025: 1026: #################################################### 1027: #################################################### 1028: sub sections_description { 1029: my @Sections = @_; 1030: my $sectionstring = ''; 1031: if (scalar(@Sections) > 1) { 1032: if (scalar(@Sections) > 2) { 1033: my $last = pop(@Sections); 1034: $sectionstring = "Sections ".join(', ',@Sections).', and '.$last; 1035: } else { 1036: $sectionstring = "Sections ".join(' and ',@Sections); 1037: } 1038: } else { 1039: if ($Sections[0] eq 'all') { 1040: $sectionstring = "All sections"; 1041: } else { 1042: $sectionstring = "Section ".$Sections[0]; 1043: } 1044: } 1045: return $sectionstring; 1046: } 1047: 1048: #################################################### 1049: #################################################### 1050: 1051: =pod 1052: 1053: =item &manage_caches 1054: 1055: Inputs: $r, apache request object 1056: 1057: Returns: An array of scalars containing html for buttons. 1058: 1059: =cut 1060: 1061: #################################################### 1062: #################################################### 1063: sub manage_caches { 1064: my ($r,$formname,$inputname) = @_; 1065: &Apache::loncoursedata::clear_internal_caches(); 1066: if (exists($ENV{'form.ClearCache'}) || 1067: exists($ENV{'form.updatecaches'}) || 1068: (exists($ENV{'form.firstrun'}) && 1069: $ENV{'form.firstrun'} ne 'no')) { 1070: &Apache::lonstatistics::Gather_Full_Student_Data($r,$formname, 1071: $inputname); 1072: } 1073: # 1074: if (! exists($ENV{'form.firstrun'})) { 1075: $r->print('<input type="hidden" name="firstrun" value="yes" />'); 1076: } else { 1077: $r->print('<input type="hidden" name="firstrun" value="no" />'); 1078: } 1079: my @Buttons = 1080: ('<input type="submit" name="ClearCache" '. 1081: 'value="'.&mt('Clear Caches').'" />', 1082: '<input type="submit" name="updatecaches" '. 1083: 'value="'.&mt('Update Caches').'" />'); 1084: # 1085: return @Buttons; 1086: } 1087: 1088: 1089: 1090: 1091: #################################################### 1092: #################################################### 1093: 1094: =pod 1095: 1096: =back 1097: 1098: =cut 1099: 1100: #################################################### 1101: #################################################### 1102: 1103: 1; 1104: 1105: __END__