1: # The LearningOnline Network with CAPA
2: #
3: # $Id: lonstathelpers.pm,v 1.8 2004/03/16 16:30:31 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()) {
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> </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()) {
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 analyze_problem_as_student
349:
350: Analyzes a homework problem for a student and returns the correct answer
351: for the student. Attempts to put together an answer for problem types
352: that do not natively support it.
353:
354: Inputs: $resource: a resource object
355: $sname, $sdom, $partid, $respid
356:
357: Returns: $answer
358:
359: If $partid and $respid are specified, $answer is simply a scalar containing
360: the correct answer for the response.
361:
362: If $partid or $respid are undefined, $answer will be a hash reference with
363: keys $partid.'.'.$respid.'.answer'.
364:
365: =cut
366:
367: #####################################################
368: #####################################################
369: sub analyze_problem_as_student {
370: my ($resource,$sname,$sdom,$partid,$respid) = @_;
371: my $returnvalue;
372: my $url = $resource->{'src'};
373: my $symb = $resource->{'symb'};
374: my $answer = &get_from_answer_cache($sname,$sdom,$symb,$partid,$respid);
375: if (defined($answer)) {
376: return($answer);
377: }
378: my $courseid = $ENV{'request.course.id'};
379: my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze',
380: 'grade_domain' => $sdom,
381: 'grade_username' => $sname,
382: 'grade_symb' => $symb,
383: 'grade_courseid' => $courseid));
384: (my $garbage,$Answ)=split(/_HASH_REF__/,$Answ,2);
385: my %Answer=&Apache::lonnet::str2hash($Answ);
386: #
387: undef($answer);
388: foreach my $partid (@{$resource->{'parts'}}) {
389: my $partdata = $resource->{'partdata'}->{$partid};
390: foreach my $respid (@{$partdata->{'ResponseIds'}}) {
391: my $prefix = $partid.'.'.$respid;
392: my $key = $prefix.'.answer';
393: $answer->{$partid}->{$respid} = &get_answer($prefix,$key,%Answer);
394: }
395: }
396: &store_answer($sname,$sdom,$symb,undef,undef,$answer);
397: if (! defined($partid)) {
398: $returnvalue = $answer;
399: } elsif (! defined($respid)) {
400: $returnvalue = $answer->{$partid};
401: } else {
402: $returnvalue = $answer->{$partid}->{$respid};
403: }
404: return $returnvalue;
405: }
406:
407: sub get_answer {
408: my ($prefix,$key,%Answer) = @_;
409: my $returnvalue;
410: if (exists($Answer{$key})) {
411: my $student_answer = $Answer{$key}->[0];
412: if (! defined($student_answer)) {
413: $student_answer = $Answer{$key}->[1];
414: }
415: $returnvalue = $student_answer;
416: } else {
417: if (exists($Answer{$prefix.'.shown'})) {
418: # The response has foils
419: my %values;
420: while (my ($k,$v) = each(%Answer)) {
421: next if ($k !~ /^$prefix\.foil\.(value|area)\.(.*)$/);
422: my $foilname = $2;
423: $values{$foilname}=$v;
424: }
425: foreach my $foil (@{$Answer{$prefix.'.shown'}}) {
426: if (ref($values{$foil}) eq 'ARRAY') {
427: $returnvalue.=&HTML::Entities::encode($foil).'='.
428: join(',',map {&HTML::Entities::encode($_)} @{$values{$foil}}).'&';
429: } else {
430: $returnvalue.=&HTML::Entities::encode($foil).'='.
431: &HTML::Entities::encode($values{$foil}).'&';
432: }
433: }
434: $returnvalue =~ s/ /\%20/g;
435: chop ($returnvalue);
436: }
437: }
438: return $returnvalue;
439: }
440:
441:
442: #####################################################
443: #####################################################
444:
445: =pod
446:
447: =item Caching routines
448:
449: =over 4
450:
451: =item &load_answer_cache($symb)
452:
453: Loads the cache for the given symb into memory from disk.
454: Requires the cache filename be set.
455: Only should be called by &ensure_proper_cache.
456:
457: =cut
458:
459: #####################################################
460: #####################################################
461: {
462: my $cache_filename = undef;
463: my $current_symb = undef;
464: my %cache;
465:
466: sub load_answer_cache {
467: my ($symb) = @_;
468: return if (! defined($cache_filename));
469: if (! defined($current_symb) || $current_symb ne $symb) {
470: undef(%cache);
471: my $storedstring;
472: my %cache_db;
473: if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_READER(),0640)) {
474: $storedstring = $cache_db{&Apache::lonnet::escape($symb)};
475: untie(%cache_db);
476: }
477: if (defined($storedstring)) {
478: %cache = %{thaw($storedstring)};
479: }
480: }
481: return;
482: }
483:
484: #####################################################
485: #####################################################
486:
487: =pod
488:
489: =item &get_from_answer_cache($sname,$sdom,$symb,$partid,$respid)
490:
491: Returns the appropriate data from the cache, or undef if no data exists.
492: If $respid is undefined, a hash ref containing the answers for the given
493: $partid is returned. If $partid is undefined, a hash ref containing answers
494: for all of the parts is returned.
495:
496: =cut
497:
498: #####################################################
499: #####################################################
500: sub get_from_answer_cache {
501: my ($sname,$sdom,$symb,$partid,$respid) = @_;
502: &ensure_proper_cache($symb);
503: my $returnvalue;
504: if (exists($cache{$sname.':'.$sdom}) &&
505: ref($cache{$sname.':'.$sdom}) eq 'HASH') {
506: if (defined($partid) &&
507: exists($cache{$sname.':'.$sdom}->{$partid})) {
508: if (defined($respid) &&
509: exists($cache{$sname.':'.$sdom}->{$partid}->{$respid})) {
510: $returnvalue = $cache{$sname.':'.$sdom}->{$partid}->{$respid};
511: } else {
512: $returnvalue = $cache{$sname.':'.$sdom}->{$partid};
513: }
514: } else {
515: $returnvalue = $cache{$sname.':'.$sdom};
516: }
517: } else {
518: $returnvalue = undef;
519: }
520: return $returnvalue;
521: }
522:
523: #####################################################
524: #####################################################
525:
526: =pod
527:
528: =item &write_answer_cache($symb)
529:
530: Writes the in memory cache to disk so that it can be read in with
531: &load_answer_cache($symb).
532:
533: =cut
534:
535: #####################################################
536: #####################################################
537: sub write_answer_cache {
538: return if (! defined($current_symb) || ! defined($cache_filename));
539: my %cache_db;
540: my $key = &Apache::lonnet::escape($current_symb);
541: if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_WRCREAT(),0640)) {
542: my $storestring = freeze(\%cache);
543: $cache_db{$key}=$storestring;
544: $cache_db{$key.'.time'}=time;
545: untie(%cache_db);
546: }
547: undef(%cache);
548: undef($current_symb);
549: undef($cache_filename);
550: return;
551: }
552:
553: #####################################################
554: #####################################################
555:
556: =pod
557:
558: =item &ensure_proper_cache($symb)
559:
560: Called to make sure we have the proper cache set up. This is called
561: prior to every answer lookup.
562:
563: =cut
564:
565: #####################################################
566: #####################################################
567: sub ensure_proper_cache {
568: my ($symb) = @_;
569: my $cid = $ENV{'request.course.id'};
570: my $new_filename = '/home/httpd/perl/tmp/'.
571: 'problemanalsysis_'.$cid.'answer_cache.db';
572: if (! defined($cache_filename) ||
573: $cache_filename ne $new_filename ||
574: ! defined($current_symb) ||
575: $current_symb ne $symb) {
576: $cache_filename = $new_filename;
577: # Notice: $current_symb is not set to $symb until after the cache is
578: # loaded. This is what tells &load_answer_cache to load in a new
579: # symb cache.
580: &load_answer_cache($symb);
581: $current_symb = $symb;
582: }
583: }
584:
585: #####################################################
586: #####################################################
587:
588: =pod
589:
590: =item &store_answer($sname,$sdom,$symb,$partid,$respid,$dataset)
591:
592: Stores the answer data in the in memory cache.
593:
594: =cut
595:
596: #####################################################
597: #####################################################
598: sub store_answer {
599: my ($sname,$sdom,$symb,$partid,$respid,$dataset) = @_;
600: return if ($symb ne $current_symb);
601: if (defined($partid)) {
602: if (defined($respid)) {
603: $cache{$sname.':'.$sdom}->{$partid}->{$respid} = $dataset;
604: } else {
605: $cache{$sname.':'.$sdom}->{$partid} = $dataset;
606: }
607: } else {
608: $cache{$sname.':'.$sdom}=$dataset;
609: }
610: return;
611: }
612:
613: }
614: #####################################################
615: #####################################################
616:
617: =pod
618:
619: =back
620:
621: =cut
622:
623: #####################################################
624: #####################################################
625:
626: ##
627: ## The following is copied from datecalc1.pl, part of the
628: ## Spreadsheet::WriteExcel CPAN module.
629: ##
630: ##
631: ######################################################################
632: #
633: # Demonstration of writing date/time cells to Excel spreadsheets,
634: # using UNIX/Perl time as source of date/time.
635: #
636: # Copyright 2000, Andrew Benham, adsb@bigfoot.com
637: #
638: ######################################################################
639: #
640: # UNIX/Perl time is the time since the Epoch (00:00:00 GMT, 1 Jan 1970)
641: # measured in seconds.
642: #
643: # An Excel file can use exactly one of two different date/time systems.
644: # In these systems, a floating point number represents the number of days
645: # (and fractional parts of the day) since a start point. The floating point
646: # number is referred to as a 'serial'.
647: # The two systems ('1900' and '1904') use different starting points:
648: # '1900'; '1.00' is 1 Jan 1900 BUT 1900 is erroneously regarded as
649: # a leap year - see:
650: # http://support.microsoft.com/support/kb/articles/Q181/3/70.asp
651: # for the excuse^H^H^H^H^H^Hreason.
652: # '1904'; '1.00' is 2 Jan 1904.
653: #
654: # The '1904' system is the default for Apple Macs. Windows versions of
655: # Excel have the option to use the '1904' system.
656: #
657: # Note that Visual Basic's "DateSerial" function does NOT erroneously
658: # regard 1900 as a leap year, and thus its serials do not agree with
659: # the 1900 serials of Excel for dates before 1 Mar 1900.
660: #
661: # Note that StarOffice (at least at version 5.2) does NOT erroneously
662: # regard 1900 as a leap year, and thus its serials do not agree with
663: # the 1900 serials of Excel for dates before 1 Mar 1900.
664: #
665: ######################################################################
666: #
667: # Calculation description
668: # =======================
669: #
670: # 1900 system
671: # -----------
672: # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 70 years after 1 Jan 1900.
673: # Of those 70 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68)
674: # were leap years with an extra day.
675: # Thus there were 17 + 70*365 days = 25567 days between 1 Jan 1900 and
676: # 1 Jan 1970.
677: # In the 1900 system, '1' is 1 Jan 1900, but as 1900 was not a leap year
678: # 1 Jan 1900 should really be '2', so 1 Jan 1970 is '25569'.
679: #
680: # 1904 system
681: # -----------
682: # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 66 years after 1 Jan 1904.
683: # Of those 66 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68)
684: # were leap years with an extra day.
685: # Thus there were 17 + 66*365 days = 24107 days between 1 Jan 1904 and
686: # 1 Jan 1970.
687: # In the 1904 system, 2 Jan 1904 being '1', 1 Jan 1970 is '24107'.
688: #
689: ######################################################################
690: #
691: # Copyright (c) 2000, Andrew Benham.
692: # This program is free software. It may be used, redistributed and/or
693: # modified under the same terms as Perl itself.
694: #
695: # Andrew Benham, adsb@bigfoot.com
696: # London, United Kingdom
697: # 11 Nov 2000
698: #
699: ######################################################################
700: #-----------------------------------------------------------
701: # calc_serial()
702: #
703: # Called with (up to) 2 parameters.
704: # 1. Unix timestamp. If omitted, uses current time.
705: # 2. GMT flag. Set to '1' to return serial in GMT.
706: # If omitted, returns serial in appropriate timezone.
707: #
708: # Returns date/time serial according to $DATE_SYSTEM selected
709: #-----------------------------------------------------------
710: sub calc_serial {
711: # Use 1900 date system on all platforms other than Apple Mac (for which
712: # use 1904 date system).
713: my $DATE_SYSTEM = ($^O eq 'MacOS') ? 1 : 0;
714: my $time = (defined $_[0]) ? $_[0] : time();
715: my $gmtflag = (defined $_[1]) ? $_[1] : 0;
716: #
717: # Divide timestamp by number of seconds in a day.
718: # This gives a date serial with '0' on 1 Jan 1970.
719: my $serial = $time / 86400;
720: #
721: # Adjust the date serial by the offset appropriate to the
722: # currently selected system (1900/1904).
723: if ($DATE_SYSTEM == 0) { # use 1900 system
724: $serial += 25569;
725: } else { # use 1904 system
726: $serial += 24107;
727: }
728: #
729: unless ($gmtflag) {
730: # Now have a 'raw' serial with the right offset. But this
731: # gives a serial in GMT, which is false unless the timezone
732: # is GMT. We need to adjust the serial by the appropriate
733: # timezone offset.
734: # Calculate the appropriate timezone offset by seeing what
735: # the differences between localtime and gmtime for the given
736: # time are.
737: #
738: my @gmtime = gmtime($time);
739: my @ltime = localtime($time);
740: #
741: # For the first 7 elements of the two arrays, adjust the
742: # date serial where the elements differ.
743: for (0 .. 6) {
744: my $diff = $ltime[$_] - $gmtime[$_];
745: if ($diff) {
746: $serial += _adjustment($diff,$_);
747: }
748: }
749: }
750: #
751: # Perpetuate the error that 1900 was a leap year by decrementing
752: # the serial if we're using the 1900 system and the date is prior to
753: # 1 Mar 1900. This has the effect of making serial value '60'
754: # 29 Feb 1900.
755: #
756: # This fix only has any effect if UNIX/Perl time on the platform
757: # can represent 1900. Many can't.
758: #
759: unless ($DATE_SYSTEM) {
760: $serial-- if ($serial < 61); # '61' is 1 Mar 1900
761: }
762: return $serial;
763: }
764:
765: sub _adjustment {
766: # Based on the difference in the localtime/gmtime array elements
767: # number, return the adjustment required to the serial.
768: #
769: # We only look at some elements of the localtime/gmtime arrays:
770: # seconds unlikely to be different as all known timezones
771: # have an offset of integral multiples of 15 minutes,
772: # but it's easy to do.
773: # minutes will be different for timezone offsets which are
774: # not an exact number of hours.
775: # hours very likely to be different.
776: # weekday will differ when localtime/gmtime difference
777: # straddles midnight.
778: #
779: # Assume that difference between localtime and gmtime is less than
780: # 5 days, then don't have to do maths for day of month, month number,
781: # year number, etc...
782: #
783: my ($delta,$element) = @_;
784: my $adjust = 0;
785: #
786: if ($element == 0) { # Seconds
787: $adjust = $delta/86400; # 60 * 60 * 24
788: } elsif ($element == 1) { # Minutes
789: $adjust = $delta/1440; # 60 * 24
790: } elsif ($element == 2) { # Hours
791: $adjust = $delta/24; # 24
792: } elsif ($element == 6) { # Day of week number
793: # Catch difference straddling Sat/Sun in either direction
794: $delta += 7 if ($delta < -4);
795: $delta -= 7 if ($delta > 4);
796: #
797: $adjust = $delta;
798: }
799: return $adjust;
800: }
801:
802: ###########################################################
803: ###########################################################
804:
805: =pod
806:
807: =item get_problem_data
808:
809: Returns a data structure describing the problem.
810:
811: Inputs: $url
812:
813: Returns: %Partdata
814:
815: =cut
816:
817: ## note: we must force each foil and option to not begin or end with
818: ## spaces as they are stored without such data.
819: ##
820: ###########################################################
821: ###########################################################
822: sub get_problem_data {
823: my ($url) = @_;
824: my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze'));
825: (my $garbage,$Answ)=split(/_HASH_REF__/,$Answ,2);
826: my %Answer;
827: %Answer=&Apache::lonnet::str2hash($Answ);
828: my %Partdata;
829: foreach my $part (@{$Answer{'parts'}}) {
830: while (my($key,$value) = each(%Answer)) {
831: #
832: # Logging code:
833: if (0) {
834: &Apache::lonnet::logthis($part.' got key "'.$key.'"');
835: if (ref($value) eq 'ARRAY') {
836: &Apache::lonnet::logthis(' @'.join(',',@$value));
837: } else {
838: &Apache::lonnet::logthis(' '.$value);
839: }
840: }
841: # End of logging code
842: next if ($key !~ /^$part/);
843: $key =~ s/^$part\.//;
844: if (ref($value) eq 'ARRAY') {
845: if ($key eq 'options') {
846: $Partdata{$part}->{'_Options'}=$value;
847: } elsif ($key eq 'concepts') {
848: $Partdata{$part}->{'_Concepts'}=$value;
849: } elsif ($key =~ /^concept\.(.*)$/) {
850: my $concept = $1;
851: foreach my $foil (@$value) {
852: $Partdata{$part}->{'_Foils'}->{$foil}->{'_Concept'}=
853: $concept;
854: }
855: } elsif ($key =~ /^(incorrect|answer|ans_low|ans_high)$/) {
856: $Partdata{$part}->{$key}=$value;
857: }
858: } else {
859: if ($key=~ /^foil\.text\.(.*)$/) {
860: my $foil = $1;
861: $Partdata{$part}->{'_Foils'}->{$foil}->{'name'}=$foil;
862: $value =~ s/(\s*$|^\s*)//g;
863: $Partdata{$part}->{'_Foils'}->{$foil}->{'text'}=$value;
864: } elsif ($key =~ /^foil\.value\.(.*)$/) {
865: my $foil = $1;
866: $Partdata{$part}->{'_Foils'}->{$foil}->{'value'}=$value;
867: }
868: }
869: }
870: }
871: return %Partdata;
872: }
873:
874: ####################################################
875: ####################################################
876:
877: =pod
878:
879: =item &limit_by_time()
880:
881: =cut
882:
883: ####################################################
884: ####################################################
885: sub limit_by_time_form {
886: my $Starttime_form = '';
887: my $starttime = &Apache::lonhtmlcommon::get_date_from_form
888: ('limitby_startdate');
889: my $endtime = &Apache::lonhtmlcommon::get_date_from_form
890: ('limitby_enddate');
891: if (! defined($endtime)) {
892: $endtime = time;
893: }
894: if (! defined($starttime)) {
895: $starttime = $endtime - 60*60*24*7;
896: }
897: my $state;
898: if (&limit_by_time()) {
899: $state = '';
900: } else {
901: $state = 'disabled';
902: }
903: my $startdateform = &Apache::lonhtmlcommon::date_setter
904: ('Statistics','limitby_startdate',$starttime,undef,undef,$state);
905: my $enddateform = &Apache::lonhtmlcommon::date_setter
906: ('Statistics','limitby_enddate',$endtime,undef,undef,$state);
907: my $Str;
908: $Str .= '<script language="Javascript" >';
909: $Str .= 'function toggle_limitby_activity(state) {';
910: $Str .= ' if (state) {';
911: $Str .= ' limitby_startdate_enable();';
912: $Str .= ' limitby_enddate_enable();';
913: $Str .= ' } else {';
914: $Str .= ' limitby_startdate_disable();';
915: $Str .= ' limitby_enddate_disable();';
916: $Str .= ' }';
917: $Str .= '}';
918: $Str .= '</script>';
919: $Str .= '<fieldset>';
920: my $timecheckbox = '<input type="checkbox" name="limit_by_time" ';
921: if (&limit_by_time()) {
922: $timecheckbox .= ' checked ';
923: }
924: $timecheckbox .= 'OnChange="javascript:toggle_limitby_activity(this.checked);" ';
925: $timecheckbox .= ' />';
926: $Str .= '<legend>'.&mt('[_1] Limit by time',$timecheckbox).'</legend>';
927: $Str .= &mt('Start Time: [_1]',$startdateform).'<br />';
928: $Str .= &mt(' End Time: [_1]',$enddateform).'<br />';
929: $Str .= '</fieldset>';
930: return $Str;
931: }
932:
933: sub limit_by_time {
934: if (exists($ENV{'form.limit_by_time'}) &&
935: $ENV{'form.limit_by_time'} ne '' ) {
936: return 1;
937: } else {
938: return 0;
939: }
940: }
941:
942: sub get_time_limits {
943: my $starttime = &Apache::lonhtmlcommon::get_date_from_form
944: ('limitby_startdate');
945: my $endtime = &Apache::lonhtmlcommon::get_date_from_form
946: ('limitby_enddate');
947: return ($starttime,$endtime);
948: }
949:
950: ####################################################
951: ####################################################
952:
953: =pod
954:
955: =back
956:
957: =cut
958:
959: ####################################################
960: ####################################################
961:
962: 1;
963:
964: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonstathelpers.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface / statistics