loncom/interface/statistics/lonstathelpers.pm - view

File: [LON-CAPA] / loncom / interface / statistics / lonstathelpers.pm
Revision 1.13: download - view: text, annotated - select for diffs
Tue Jun 15 14:22:45 2004 UTC (20 years ago) by matthew
Branches: MAIN
CVS tags: HEAD

Added lonsurveyreports.pm - module to generate (currently only HTML) reports
of student answers to survey questions.
lonstatistics.pm: Added hooks to survey reports
lonstathelpers.pm: Modified &get_prev_curr_next to work on just surveys
loncapafiles.lpml: Added lonsurveyreports.pm

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