loncom/interface/statistics/lonstathelpers.pm - view

File: [LON-CAPA] / loncom / interface / statistics / lonstathelpers.pm
Revision 1.54: download - view: text, annotated - select for diffs
Fri Dec 29 21:47:11 2006 UTC (17 years, 4 months ago) by albertel
Branches: MAIN
CVS tags: version_2_7_0, version_2_6_X, version_2_6_99_1, version_2_6_99_0, version_2_6_3, version_2_6_2, version_2_6_1, version_2_6_0, version_2_5_X, version_2_5_99_1, version_2_5_99_0, version_2_5_2, version_2_5_1, version_2_5_0, version_2_4_X, version_2_4_99_0, version_2_4_2, version_2_4_1, version_2_4_0, version_2_3_X, version_2_3_99_0, version_2_3_2, version_2_3_1, version_2_3_0, HEAD

- BUG#5118 - analyzing numeircal problem was causing ISE

# The LearningOnline Network with CAPA # # $Id: lonstathelpers.pm,v 1.54 2006/12/29 21:47:11 albertel Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # #################################################### #################################################### =pod =head1 NAME Apache::lonstathelpers - helper routines used by statistics =head1 SYNOPSIS This module provides a place to consolidate much of the statistics routines that are needed across multiple statistics functions. =head1 OVERVIEW =over 4 =cut #################################################### #################################################### package Apache::lonstathelpers; use strict; use Apache::lonnet; use Apache::loncommon(); use Apache::lonhtmlcommon(); use Apache::loncoursedata(); use Apache::lonstatistics; use Apache::lonlocal; use HTML::Entities(); use Time::Local(); use Spreadsheet::WriteExcel(); use GDBM_File; use Storable qw(freeze thaw); use lib '/home/httpd/lib/perl/'; use LONCAPA; #################################################### #################################################### =pod =item &render_resource($resource) Input: a navmaps resource Retunrs: a scalar containing html for a rendering of the problem within a table. =cut #################################################### #################################################### sub render_resource { my ($resource) = @_; ## ## Render the problem my ($base) = ($resource->src =~ m|^(.*/)[^/]*$|); $base="http://".$ENV{'SERVER_NAME'}.$base; my ($src,$symb)=($resource->src,&escape($resource->symb)); my $rendered_problem = &Apache::lonnet::ssi_body($src.'?symb='.$symb); $rendered_problem =~ s/<\s*form\s*/<nop /g; $rendered_problem =~ s|(<\s*/form\s*>)|<\/nop>|g; return '<table bgcolor="ffffff"><tr><td>'. '<base href="'.$base.'" />'. $rendered_problem. '</td></tr></table>'; } #################################################### #################################################### =pod =item &get_resources =cut #################################################### #################################################### sub get_resources { my ($navmap,$sequence) = @_; my @resources = $navmap->retrieveResources($sequence, sub { shift->is_problem(); }, 0,0,0); return @resources; } #################################################### #################################################### =pod =item &problem_selector($AcceptedResponseTypes) Input: scalar containing regular expression which matches response types to show. '.' will yield all, '(option|radiobutton)' will match all option response and radiobutton problems. Returns: A string containing html for a table which lists the sequences and their contents. A radiobutton is provided for each problem. Skips 'survey' problems. =cut #################################################### #################################################### sub problem_selector { my ($AcceptedResponseTypes,$sequence_addendum) = @_; my $Str; $Str = "\n<table>\n"; my $rb_count =0; my ($navmap,@sequences) = &Apache::lonstatistics::selected_sequences_with_assessments('all'); return $navmap if (! ref($navmap)); # error foreach my $seq (@sequences) { my $seq_str = ''; foreach my $res (&get_resources($navmap,$seq)) { foreach my $part (@{$res->parts}) { my @response_ids = $res->responseIds($part); my @response_types = $res->responseType($part); for (my $i=0;$i<scalar(@response_types);$i++){ my $respid = $response_ids[$i]; my $resptype = $response_types[$i]; if ($resptype =~ m/$AcceptedResponseTypes/) { my $value = &make_target_id({symb=>$res->symb, part=>$part, respid=>$respid, resptype=>$resptype}); my $checked = ''; if ($env{'form.problemchoice'} eq $value) { $checked = 'checked '; } my $title = $res->compTitle; if (! defined($title) || $title eq '') { ($title) = ($res->src =~ m:/([^/]*)$:); } $seq_str .= '<tr>'. qq{<td><input type="radio" id="$rb_count" name="problemchoice" value="$value" $checked /></td>}. '<td><label for="'.$rb_count.'">'.$resptype.'</label></td>'. '<td><label for="'.$rb_count.'">'.$title.'</label>'; if (scalar(@response_ids) > 1) { $seq_str .= &mt('response').' '.$respid; } my $link = $res->src.'?symb='. &escape($res->symb); $seq_str .= (' 'x2). qq{<a target="preview" href="$link">view</a>}; $seq_str .= "</td></tr>\n"; $rb_count++; } } } } if ($seq_str ne '') { $Str .= '<tr><td>&nbsp</td>'. '<td colspan="2"><b>'.$seq->compTitle.'</b></td>'. "</tr>\n".$seq_str; if (defined($sequence_addendum)) { $Str .= '<tr>'. ('<td>&nbsp</td>'x2). '<td align="right">'.$sequence_addendum.'</td>'. "</tr>\n"; } } } $Str .= "</table>\n"; return $Str; } #################################################### #################################################### =pod =item &MultipleProblemSelector($navmap,$selected,$inputname) Generate HTML with checkboxes for problem selection. Input: $navmap: a navmap object. If undef, navmaps will be called to create a new object. $selected: Scalar, Array, or hash reference of currently selected items. $inputname: The name of the form elements to use for the checkboxs. Returns: A string containing html for a table which lists the sequences and their contents. A checkbox is provided for each problem. =cut #################################################### #################################################### sub MultipleProblemSelector { my ($navmap,$inputname,$formname)=@_; my $cid = $env{'request.course.id'}; my $Str; # Massage the input as needed. if (! defined($navmap)) { $navmap = Apache::lonnavmaps::navmap->new(); if (! defined($navmap)) { $Str .= '<h1>'.&mt('Error: cannot process course structure').'</h1>'; return $Str; } } my $selected = {map { ($_,1) } (&get_selected_symbs($inputname))}; # Header $Str .= <<"END"; <script language="JavaScript" type="text/javascript"> function checkall(value,seqid) { for (i=0; i<document.forms.$formname.elements.length; i++) { ele = document.forms.$formname.elements[i]; if (ele.name == '$inputname') { if (seqid != null) { itemid = document.forms.$formname.elements[i].id; thing = itemid.split(':'); if (thing[0] == seqid) { document.forms.$formname.elements[i].checked=value; } } else { document.forms.$formname.elements[i].checked=value; } } } } </script> END $Str .= '<a href="javascript:checkall(true)">'.&mt('Select All').'</a>'. (' 'x4). '<a href="javascript:checkall(false)">'.&mt('Unselect All').'</a>'; $Str .= $/.'<table>'.$/; my $iterator = $navmap->getIterator(undef, undef, undef, 1); my $sequence_string; my $seq_id = 0; my @Accumulator = (&new_accumulator($env{'course.'.$cid.'.description'}, '', '', $seq_id++, $inputname)); my @Sequence_Data; while (my $curRes = $iterator->next()) { if ($curRes == $iterator->END_MAP) { if (ref($Accumulator[-1]) eq 'CODE') { my $old_accumulator = pop(@Accumulator); push(@Sequence_Data,&{$old_accumulator}()); } } elsif ($curRes == $iterator->BEGIN_MAP) { # Not much to do here. } next if (! ref($curRes)); if ($curRes->is_map) { push(@Accumulator,&new_accumulator($curRes->compTitle, $curRes->src, $curRes->symb, $seq_id++, $inputname)); } elsif ($curRes->is_problem) { if (@Accumulator && $Accumulator[-1] ne '') { &{$Accumulator[-1]}($curRes, exists($selected->{$curRes->symb})); } } } my $course_seq = pop(@Sequence_Data); foreach my $seq ($course_seq,@Sequence_Data) { #my $seq = pop(@Sequence_Data); next if (! defined($seq) || ref($seq) ne 'HASH'); $Str.= '<tr><td colspan="2">'. '<b>'.$seq->{'title'}.'</b>'.(' 'x2). '<a href="javascript:checkall(true,'.$seq->{'id'}.')">'. &mt('Select').'</a>'.(' 'x2). '<a href="javascript:checkall(false,'.$seq->{'id'}.')">'. &mt('Unselect').'</a>'.(' 'x2). '</td></tr>'.$/; $Str.= $seq->{'html'}; } $Str .= '</table>'.$/; return $Str; } sub new_accumulator { my ($title,$src,$symb,$seq_id,$inputname) = @_; my $target; my $item_id=0; return sub { if (@_) { my ($res,$checked) = @_; $target.='<tr><td><label>'. '<input type="checkbox" name="'.$inputname.'" '; if ($checked) { $target .= 'checked '; } $target .= 'id="'.$seq_id.':'.$item_id++.'" '; $target.= 'value="'.&escape($res->symb).'" />'. ' '.$res->compTitle.'</label>'. (' 'x2).'<a target="preview" '. 'href="'.$res->src.'?symb='. &escape($res->symb).'">view</a>'. '</td></tr>'.$/; } else { if (defined($target)) { return { title => $title, symb => $symb, src => $src, id => $seq_id, html => $target, }; } return undef; } }; } sub get_selected_symbs { my ($inputfield) = @_; my $field = 'form.'.$inputfield; my @symbs = (map { &unescape($_); } &Apache::loncommon::get_env_multiple($field)); return @symbs; } #################################################### #################################################### =pod =item &make_target_id($target) Inputs: Hash ref with the following entries: $target->{'symb'}, $target->{'part'}, $target->{'respid'}, $target->{'resptype'}. Returns: A string, suitable for a form parameter, which uniquely identifies the problem, part, and response to do statistical analysis on. Used by Apache::lonstathelpers::ProblemSelector(). =cut #################################################### #################################################### sub make_target_id { my ($target) = @_; my $id = &escape($target->{'symb'}).':'. &escape($target->{'part'}).':'. &escape($target->{'respid'}).':'. &escape($target->{'resptype'}); return $id; } #################################################### #################################################### =pod =item &get_target_from_id($id) Inputs: $id, a scalar string from Apache::lonstathelpers::make_target_id(). Returns: A hash reference, $target, containing the following keys: $target->{'symb'}, $target->{'part'}, $target->{'respid'}, $target->{'resptype'}. =cut #################################################### #################################################### sub get_target_from_id { my ($id) = @_; if (! ref($id)) { my ($symb,$part,$respid,$resptype) = split(':',$id); return ({ symb => &unescape($symb), part => &unescape($part), respid => &unescape($respid), resptype => &unescape($resptype)}); } elsif (ref($id) eq 'ARRAY') { my @Return; foreach my $selected (@$id) { my ($symb,$part,$respid,$resptype) = split(':',$selected); push(@Return,{ symb => &unescape($symb), part => &unescape($part), respid => &unescape($respid), resptype => &unescape($resptype)}); } return \@Return; } } #################################################### #################################################### =pod =item &get_prev_curr_next($target,$AcceptableResponseTypes,$granularity) Determine the problem parts or responses preceeding and following the current resource. Inputs: $target (see &Apache::lonstathelpers::get_target_from_id()) $AcceptableResponseTypes, regular expression matching acceptable response types, $granularity, either 'part', 'response', 'part_survey', or 'part_task' Returns: three hash references, $prev, $curr, $next, which refer to the preceeding, current, or following problem parts or responses, depending on the value of $granularity. Values of undef indicate there is no previous or next part/response. A value of undef for all three indicates there was no match found to the current part/resource. The hash references contain the following keys: symb, part, resource If $granularity eq 'response', the following ADDITIONAL keys will be present: respid, resptype =cut #################################################### #################################################### sub get_prev_curr_next { my ($target,$AcceptableResponseTypes,$granularity) = @_; # # Build an array with the data we need to search through my @Resource; my ($navmap,@sequences) = &Apache::lonstatistics::selected_sequences_with_assessments('all'); return $navmap if (! ref($navmap)); foreach my $seq (@sequences) { my @resources = &get_resources($navmap,$seq); foreach my $res (@resources) { foreach my $part (@{$res->parts}) { if ($res->is_survey($part) && ($granularity eq 'part_survey')){ push (@Resource, { symb => $res->symb, part => $part, resource => $res, } ); } elsif ($res->is_task($part) && ($granularity eq 'part_task')){ push (@Resource, { symb => $res->symb, part => $part, resource => $res, } ); } elsif ($granularity eq 'part') { push (@Resource, { symb => $res->symb, part => $part, resource => $res, } ); } elsif ($granularity eq 'response') { my @response_ids = $res->responseIds($part); my @response_types = $res->responseType($part); for (my $i=0; $i<scalar(@response_ids); $i++){ my $respid = $response_ids[$i]; my $resptype = $response_types[$i]; next if ($resptype !~ m/$AcceptableResponseTypes/); push (@Resource, { symb => $res->symb, part => $part, respid => $respid, resptype => $resptype, resource => $res, } ); } } } } } # # Get the index of the current situation my $curr_idx; for ($curr_idx=0;$curr_idx<$#Resource;$curr_idx++) { my $curr_item = $Resource[$curr_idx]; if ($granularity =~ /^(part|part_survey|part_task)$/) { if ($curr_item->{'symb'} eq $target->{'symb'} && $curr_item->{'part'} eq $target->{'part'}) { last; } } elsif ($granularity eq 'response') { if ($curr_item->{'symb'} eq $target->{'symb'} && $curr_item->{'part'} eq $target->{'part'} && $curr_item->{'respid'} eq $target->{'respid'} && $curr_item->{'resptype'} eq $target->{'resptype'}) { last; } } } my $curr_item = $Resource[$curr_idx]; if ($granularity =~ /^(part|part_survey|part_task)$/) { if ($curr_item->{'symb'} ne $target->{'symb'} || $curr_item->{'part'} ne $target->{'part'}) { # bogus symb - return nothing return (undef,undef,undef); } } elsif ($granularity eq 'response') { if ($curr_item->{'symb'} ne $target->{'symb'} || $curr_item->{'part'} ne $target->{'part'} || $curr_item->{'respid'} ne $target->{'respid'} || $curr_item->{'resptype'} ne $target->{'resptype'}){ # bogus symb - return nothing return (undef,undef,undef); } } # # Now just pick up the data we need my ($prev,$curr,$next); if ($curr_idx == 0) { $prev = undef; $curr = $Resource[$curr_idx ]; $next = $Resource[$curr_idx+1]; } elsif ($curr_idx == $#Resource) { $prev = $Resource[$curr_idx-1]; $curr = $Resource[$curr_idx ]; $next = undef; } else { $prev = $Resource[$curr_idx-1]; $curr = $Resource[$curr_idx ]; $next = $Resource[$curr_idx+1]; } return ($navmap,$prev,$curr,$next); } ##################################################### ##################################################### =pod =item GetStudentAnswers($r,$problem,$Students) Determines the correct answer for a set of students on a given problem. The students answers are stored in the student hashes pointed to by the array @$Students under the key 'answer'. Inputs: $r $problem: hash reference containing the keys 'resource', 'part', and 'respid'. $Students: reference to array containing student hashes (need 'username', 'domain'). Returns: nothing =cut ##################################################### ##################################################### sub GetStudentAnswers { my ($r,$problem,$Students,$formname,$inputname) = @_; my %answers; my $status_type; if (defined($formname)) { $status_type = 'inline'; } else { $status_type = 'popup'; } my $c = $r->connection(); my %Answers; my ($resource,$partid,$respid) = ($problem->{'resource'}, $problem->{'part'}, $problem->{'respid'}); # Read in the cache (if it exists) before we start timing things. &Apache::lonstathelpers::ensure_proper_cache($resource->{'symb'}); # Open progress window my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin ($r,'Student Answer Compilation Status', 'Student Answer Compilation Progress', scalar(@$Students), $status_type,undef,$formname,$inputname); $r->rflush(); foreach my $student (@$Students) { last if ($c->aborted()); my $sname = $student->{'username'}; my $sdom = $student->{'domain'}; my $answer = &Apache::lonstathelpers::get_student_answer ($resource,$sname,$sdom,$partid,$respid); &Apache::lonhtmlcommon::Increment_PrgWin($r,\%prog_state, &mt('last student')); $answers{$answer}++; $student->{'answer'} = $answer; } &Apache::lonstathelpers::write_analysis_cache(); return if ($c->aborted()); $r->rflush(); # close progress window &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state); return \%answers; } ##################################################### ##################################################### =pod =item analyze_problem_as_student Analyzes a homework problem for a student Inputs: $resource: a resource object $sname, $sdom, $partid, $respid Returns: the problem analysis hash =cut ##################################################### ##################################################### sub analyze_problem_as_student { my ($resource,$sname,$sdom) = @_; if (ref($resource) ne 'HASH') { my $res = $resource; $resource = { 'src' => $res->src, 'symb' => $res->symb, 'parts' => $res->parts }; foreach my $part (@{$resource->{'parts'}}) { $resource->{'partdata'}->{$part}->{'ResponseIds'}= [$res->responseIds($part)]; } } my $url = $resource->{'src'}; my $symb = $resource->{'symb'}; my $analysis = &get_from_analysis_cache($sname,$sdom,$symb); if (! defined($analysis)) { my $courseid = $env{'request.course.id'}; my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze', 'grade_domain' => $sdom, 'grade_username' => $sname, 'grade_symb' => $symb, 'grade_courseid' => $courseid)); (my $garbage,$analysis)=split(/_HASH_REF__/,$Answ,2); &store_analysis($sname,$sdom,$symb,$analysis); } my %Answer=&Apache::lonnet::str2hash($analysis); # return \%Answer; } ##################################################### ##################################################### =pod =item get_student_answer Analyzes a homework problem for a particular student and returns the correct answer. Attempts to put together an answer for problem types that do not natively support it. Inputs: $resource: a resource object (from navmaps or hash from loncoursedata) $sname, $sdom, $partid, $respid Returns: $answer If $partid and $respid are specified, $answer is simply a scalar containing the correct answer for the response. If $partid or $respid are undefined, $answer will be a hash reference with keys $partid.'.'.$respid.'.answer'. =cut ##################################################### ##################################################### sub get_student_answer { my ($resource,$sname,$sdom,$partid,$respid) = @_; # if (ref($resource) ne 'HASH') { my $res = $resource; $resource = { 'src' => $res->src, 'symb' => $res->symb, 'parts' => $res->parts }; foreach my $part (@{$resource->{'parts'}}) { $resource->{'partdata'}->{$part}->{'ResponseIds'}= [$res->responseIds($part)]; } } # my $analysis = &analyze_problem_as_student($resource,$sname,$sdom); my $answer; foreach my $partid (@{$resource->{'parts'}}) { my $partdata = $resource->{'partdata'}->{$partid}; foreach my $respid (@{$partdata->{'ResponseIds'}}) { my $prefix = $partid.'.'.$respid; my $key = $prefix.'.answer'; $answer->{$partid}->{$respid} = &get_answer($prefix,$key,%$analysis); } } my $returnvalue; if (! defined($partid)) { $returnvalue = $answer; } elsif (! defined($respid)) { $returnvalue = $answer->{$partid}; } else { $returnvalue = $answer->{$partid}->{$respid}; } return $returnvalue; } sub get_answer { my ($prefix,$key,%Answer) = @_; my $returnvalue; if (exists($Answer{$key})) { if (ref($Answer{$key}) eq 'HASH') { my $which = 'INTERNAL'; if (!exists($Answer{$key}{$which})) { $which = (sort(keys(%{ $Answer{$key} })))[0]; } my $student_answer = $Answer{$key}{$which}[0][0]; $returnvalue = $student_answer; } else { &Apache::lonnet::logthis("error analyzing problem. got a answer of type ".ref($Answer{$key})); } } else { if (exists($Answer{$prefix.'.shown'})) { # The response has foils my %values; while (my ($k,$v) = each(%Answer)) { next if ($k !~ /^$prefix\.foil\.(value|area)\.(.*)$/); my $foilname = $2; $values{$foilname}=$v; } foreach my $foil (@{$Answer{$prefix.'.shown'}}) { if (ref($values{$foil}) eq 'ARRAY') { $returnvalue.=&HTML::Entities::encode($foil,'<>&"').'='. join(',',map {&HTML::Entities::encode($_,'<>&"')} @{$values{$foil}}).'&'; } else { $returnvalue.=&HTML::Entities::encode($foil,'<>&"').'='. &HTML::Entities::encode($values{$foil},'<>&"').'&'; } } $returnvalue =~ s/ /\%20/g; chop ($returnvalue); } } return $returnvalue; } ##################################################### ##################################################### =pod =item Caching routines =over 4 =item &load_analysis_cache($symb) Loads the cache for the given symb into memory from disk. Requires the cache filename be set. Only should be called by &ensure_proper_cache. =cut ##################################################### ##################################################### { my $cache_filename = undef; my $current_symb = undef; my %cache; sub load_analysis_cache { my ($symb) = @_; return if (! defined($cache_filename)); if (! defined($current_symb) || $current_symb ne $symb) { undef(%cache); my $storedstring; my %cache_db; if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_READER(),0640)) { $storedstring = $cache_db{&escape($symb)}; untie(%cache_db); } if (defined($storedstring)) { %cache = %{thaw($storedstring)}; } } return; } ##################################################### ##################################################### =pod =item &get_from_analysis_cache($sname,$sdom,$symb,$partid,$respid) Returns the appropriate data from the cache, or undef if no data exists. =cut ##################################################### ##################################################### sub get_from_analysis_cache { my ($sname,$sdom,$symb) = @_; &ensure_proper_cache($symb); my $returnvalue; if (exists($cache{$sname.':'.$sdom})) { $returnvalue = $cache{$sname.':'.$sdom}; } else { $returnvalue = undef; } return $returnvalue; } ##################################################### ##################################################### =pod =item &write_analysis_cache($symb) Writes the in memory cache to disk so that it can be read in with &load_analysis_cache($symb). =cut ##################################################### ##################################################### sub write_analysis_cache { return if (! defined($current_symb) || ! defined($cache_filename)); my %cache_db; my $key = &escape($current_symb); if (tie(%cache_db,'GDBM_File',$cache_filename,&GDBM_WRCREAT(),0640)) { my $storestring = freeze(\%cache); $cache_db{$key}=$storestring; $cache_db{$key.'.time'}=time; untie(%cache_db); } undef(%cache); undef($current_symb); undef($cache_filename); return; } ##################################################### ##################################################### =pod =item &ensure_proper_cache($symb) Called to make sure we have the proper cache set up. This is called prior to every analysis lookup. =cut ##################################################### ##################################################### sub ensure_proper_cache { my ($symb) = @_; my $cid = $env{'request.course.id'}; my $new_filename = '/home/httpd/perl/tmp/'. 'problemanalysis_'.$cid.'_analysis_cache.db'; if (! defined($cache_filename) || $cache_filename ne $new_filename || ! defined($current_symb) || $current_symb ne $symb) { $cache_filename = $new_filename; # Notice: $current_symb is not set to $symb until after the cache is # loaded. This is what tells &load_analysis_cache to load in a new # symb cache. &load_analysis_cache($symb); $current_symb = $symb; } } ##################################################### ##################################################### =pod =item &store_analysis($sname,$sdom,$symb,$partid,$respid,$dataset) Stores the analysis data in the in memory cache. =cut ##################################################### ##################################################### sub store_analysis { my ($sname,$sdom,$symb,$dataset) = @_; return if ($symb ne $current_symb); $cache{$sname.':'.$sdom}=$dataset; return; } } ##################################################### ##################################################### =pod =back =cut ##################################################### ##################################################### ## ## The following is copied from datecalc1.pl, part of the ## Spreadsheet::WriteExcel CPAN module. ## ## ###################################################################### # # Demonstration of writing date/time cells to Excel spreadsheets, # using UNIX/Perl time as source of date/time. # # Copyright 2000, Andrew Benham, adsb@bigfoot.com # ###################################################################### # # UNIX/Perl time is the time since the Epoch (00:00:00 GMT, 1 Jan 1970) # measured in seconds. # # An Excel file can use exactly one of two different date/time systems. # In these systems, a floating point number represents the number of days # (and fractional parts of the day) since a start point. The floating point # number is referred to as a 'serial'. # The two systems ('1900' and '1904') use different starting points: # '1900'; '1.00' is 1 Jan 1900 BUT 1900 is erroneously regarded as # a leap year - see: # http://support.microsoft.com/support/kb/articles/Q181/3/70.asp # for the excuse^H^H^H^H^H^Hreason. # '1904'; '1.00' is 2 Jan 1904. # # The '1904' system is the default for Apple Macs. Windows versions of # Excel have the option to use the '1904' system. # # Note that Visual Basic's "DateSerial" function does NOT erroneously # regard 1900 as a leap year, and thus its serials do not agree with # the 1900 serials of Excel for dates before 1 Mar 1900. # # Note that StarOffice (at least at version 5.2) does NOT erroneously # regard 1900 as a leap year, and thus its serials do not agree with # the 1900 serials of Excel for dates before 1 Mar 1900. # ###################################################################### # # Calculation description # ======================= # # 1900 system # ----------- # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 70 years after 1 Jan 1900. # Of those 70 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68) # were leap years with an extra day. # Thus there were 17 + 70*365 days = 25567 days between 1 Jan 1900 and # 1 Jan 1970. # In the 1900 system, '1' is 1 Jan 1900, but as 1900 was not a leap year # 1 Jan 1900 should really be '2', so 1 Jan 1970 is '25569'. # # 1904 system # ----------- # Unix time is '0' at 00:00:00 GMT 1 Jan 1970, i.e. 66 years after 1 Jan 1904. # Of those 66 years, 17 (1904,08,12,16,20,24,28,32,36,40,44,48,52,56,60,64,68) # were leap years with an extra day. # Thus there were 17 + 66*365 days = 24107 days between 1 Jan 1904 and # 1 Jan 1970. # In the 1904 system, 2 Jan 1904 being '1', 1 Jan 1970 is '24107'. # ###################################################################### # # Copyright (c) 2000, Andrew Benham. # This program is free software. It may be used, redistributed and/or # modified under the same terms as Perl itself. # # Andrew Benham, adsb@bigfoot.com # London, United Kingdom # 11 Nov 2000 # ###################################################################### #----------------------------------------------------------- # calc_serial() # # Called with (up to) 2 parameters. # 1. Unix timestamp. If omitted, uses current time. # 2. GMT flag. Set to '1' to return serial in GMT. # If omitted, returns serial in appropriate timezone. # # Returns date/time serial according to $DATE_SYSTEM selected #----------------------------------------------------------- sub calc_serial { # Use 1900 date system on all platforms other than Apple Mac (for which # use 1904 date system). my $DATE_SYSTEM = ($^O eq 'MacOS') ? 1 : 0; my $time = (defined $_[0]) ? $_[0] : time(); my $gmtflag = (defined $_[1]) ? $_[1] : 0; # # Divide timestamp by number of seconds in a day. # This gives a date serial with '0' on 1 Jan 1970. my $serial = $time / 86400; # # Adjust the date serial by the offset appropriate to the # currently selected system (1900/1904). if ($DATE_SYSTEM == 0) { # use 1900 system $serial += 25569; } else { # use 1904 system $serial += 24107; } # unless ($gmtflag) { # Now have a 'raw' serial with the right offset. But this # gives a serial in GMT, which is false unless the timezone # is GMT. We need to adjust the serial by the appropriate # timezone offset. # Calculate the appropriate timezone offset by seeing what # the differences between localtime and gmtime for the given # time are. # my @gmtime = gmtime($time); my @ltime = localtime($time); # # For the first 7 elements of the two arrays, adjust the # date serial where the elements differ. for (0 .. 6) { my $diff = $ltime[$_] - $gmtime[$_]; if ($diff) { $serial += _adjustment($diff,$_); } } } # # Perpetuate the error that 1900 was a leap year by decrementing # the serial if we're using the 1900 system and the date is prior to # 1 Mar 1900. This has the effect of making serial value '60' # 29 Feb 1900. # # This fix only has any effect if UNIX/Perl time on the platform # can represent 1900. Many can't. # unless ($DATE_SYSTEM) { $serial-- if ($serial < 61); # '61' is 1 Mar 1900 } return $serial; } sub _adjustment { # Based on the difference in the localtime/gmtime array elements # number, return the adjustment required to the serial. # # We only look at some elements of the localtime/gmtime arrays: # seconds unlikely to be different as all known timezones # have an offset of integral multiples of 15 minutes, # but it's easy to do. # minutes will be different for timezone offsets which are # not an exact number of hours. # hours very likely to be different. # weekday will differ when localtime/gmtime difference # straddles midnight. # # Assume that difference between localtime and gmtime is less than # 5 days, then don't have to do maths for day of month, month number, # year number, etc... # my ($delta,$element) = @_; my $adjust = 0; # if ($element == 0) { # Seconds $adjust = $delta/86400; # 60 * 60 * 24 } elsif ($element == 1) { # Minutes $adjust = $delta/1440; # 60 * 24 } elsif ($element == 2) { # Hours $adjust = $delta/24; # 24 } elsif ($element == 6) { # Day of week number # Catch difference straddling Sat/Sun in either direction $delta += 7 if ($delta < -4); $delta -= 7 if ($delta > 4); # $adjust = $delta; } return $adjust; } ########################################################### ########################################################### =pod =item get_problem_data Returns a data structure describing the problem. Inputs: $url Returns: %Partdata =cut ## note: we must force each foil and option to not begin or end with ## spaces as they are stored without such data. ## ########################################################### ########################################################### sub get_problem_data { my ($url) = @_; my $Answ=&Apache::lonnet::ssi($url,('grade_target' => 'analyze')); (my $garbage,$Answ)=split(/_HASH_REF__/,$Answ,2); my %Answer; %Answer=&Apache::lonnet::str2hash($Answ); my %Partdata; foreach my $part (@{$Answer{'parts'}}) { while (my($key,$value) = each(%Answer)) { # # Logging code: if (0) { &Apache::lonnet::logthis($part.' got key "'.$key.'"'); if (ref($value) eq 'ARRAY') { &Apache::lonnet::logthis(' @'.join(',',@$value)); } else { &Apache::lonnet::logthis(' '.$value); } } # End of logging code next if ($key !~ /^\Q$part\E/); $key =~ s/^\Q$part\E\.//; if (ref($value) eq 'ARRAY') { if ($key eq 'options') { $Partdata{$part}->{'_Options'}=$value; } elsif ($key eq 'concepts') { $Partdata{$part}->{'_Concepts'}=$value; } elsif ($key eq 'items') { $Partdata{$part}->{'_Items'}=$value; } elsif ($key =~ /^concept\.(.*)$/) { my $concept = $1; foreach my $foil (@$value) { $Partdata{$part}->{'_Foils'}->{$foil}->{'_Concept'}= $concept; } } elsif ($key =~ /^(unit|incorrect|answer|ans_low|ans_high|str_type)$/) { $Partdata{$part}->{$key}=$value; } } else { if ($key=~ /^foil\.text\.(.*)$/) { my $foil = $1; $Partdata{$part}->{'_Foils'}->{$foil}->{'name'}=$foil; $value =~ s/(\s*$|^\s*)//g; $Partdata{$part}->{'_Foils'}->{$foil}->{'text'}=$value; } elsif ($key =~ /^foil\.value\.(.*)$/) { my $foil = $1; $Partdata{$part}->{'_Foils'}->{$foil}->{'value'}=$value; } elsif ($key eq 'answercomputed') { $Partdata{$part}->{'answercomputed'} = $value; } } } } # Further debugging code if (0) { &Apache::lonnet::logthis('lonstathelpers::get_problem_data'); &log_hash_ref(\%Partdata); } return %Partdata; } sub log_array_ref { my ($arrayref,$prefix) = @_; return if (ref($arrayref) ne 'ARRAY'); if (! defined($prefix)) { $prefix = ''; }; foreach my $v (@$arrayref) { if (ref($v) eq 'ARRAY') { &log_array_ref($v,$prefix.' '); } elsif (ref($v) eq 'HASH') { &log_hash_ref($v,$prefix.' '); } else { &Apache::lonnet::logthis($prefix.'"'.$v.'"'); } } } sub log_hash_ref { my ($hashref,$prefix) = @_; return if (ref($hashref) ne 'HASH'); if (! defined($prefix)) { $prefix = ''; }; while (my ($k,$v) = each(%$hashref)) { if (ref($v) eq 'ARRAY') { &Apache::lonnet::logthis($prefix.'"'.$k.'" = array'); &log_array_ref($v,$prefix.' '); } elsif (ref($v) eq 'HASH') { &Apache::lonnet::logthis($prefix.'"'.$k.'" = hash'); &log_hash_ref($v,$prefix.' '); } else { &Apache::lonnet::logthis($prefix.'"'.$k.'" => "'.$v.'"'); } } } #################################################### #################################################### =pod =item &limit_by_time() =cut #################################################### #################################################### sub limit_by_time_form { my $Starttime_form = ''; my $starttime = &Apache::lonhtmlcommon::get_date_from_form ('limitby_startdate'); my $endtime = &Apache::lonhtmlcommon::get_date_from_form ('limitby_enddate'); if (! defined($endtime)) { $endtime = time; } if (! defined($starttime)) { $starttime = $endtime - 60*60*24*7; } my $state; if (&limit_by_time()) { $state = ''; } else { $state = 'disabled'; } my $startdateform = &Apache::lonhtmlcommon::date_setter ('Statistics','limitby_startdate',$starttime,undef,undef,$state); my $enddateform = &Apache::lonhtmlcommon::date_setter ('Statistics','limitby_enddate',$endtime,undef,undef,$state); my $Str; $Str .= '<script language="Javascript" >'; $Str .= 'function toggle_limitby_activity(state) {'; $Str .= ' if (state) {'; $Str .= ' limitby_startdate_enable();'; $Str .= ' limitby_enddate_enable();'; $Str .= ' } else {'; $Str .= ' limitby_startdate_disable();'; $Str .= ' limitby_enddate_disable();'; $Str .= ' }'; $Str .= '}'; $Str .= '</script>'; $Str .= '<fieldset>'; my $timecheckbox = '<input type="checkbox" name="limit_by_time" '; if (&limit_by_time()) { $timecheckbox .= ' checked '; } $timecheckbox .= 'OnChange="javascript:toggle_limitby_activity(this.checked);" '; $timecheckbox .= ' />'; $Str .= '<legend><label>'.&mt('[_1] Limit by time',$timecheckbox).'</label></legend>'; $Str .= &mt('Start Time: [_1]',$startdateform).'<br />'; $Str .= &mt(' End Time: [_1]',$enddateform).'<br />'; $Str .= '</fieldset>'; return $Str; } sub limit_by_time { if (exists($env{'form.limit_by_time'}) && $env{'form.limit_by_time'} ne '' ) { return 1; } else { return 0; } } sub get_time_limits { my $starttime = &Apache::lonhtmlcommon::get_date_from_form ('limitby_startdate'); my $endtime = &Apache::lonhtmlcommon::get_date_from_form ('limitby_enddate'); return ($starttime,$endtime); } #################################################### #################################################### =pod =item &manage_caches Inputs: $r, apache request object Returns: An array of scalars containing html for buttons. =cut #################################################### #################################################### sub manage_caches { my ($r,$formname,$inputname,$update_message) = @_; &Apache::loncoursedata::clear_internal_caches(); my $sectionkey = join(',', map { &escape($_); } sort(&Apache::lonstatistics::get_selected_sections()) ); my $statuskey = $Apache::lonstatistics::enrollment_status; if (exists($env{'form.ClearCache'}) || exists($env{'form.updatecaches'}) || (exists($env{'form.firstrun'}) && $env{'form.firstrun'} ne 'no') || (exists($env{'form.prevsection'}) && $env{'form.prevsection'} ne $sectionkey) || (exists($env{'form.prevenrollstatus'}) && $env{'form.prevenrollstatus'} ne $statuskey) ) { if (defined($update_message)) { $r->print($update_message); } if (0) { &Apache::lonnet::logthis('Updating mysql student data caches'); } &gather_full_student_data($r,$formname,$inputname); } # my @Buttons = ('<input type="submit" name="ClearCache" '. 'value="'.&mt('Clear Caches').'" />', '<input type="submit" name="updatecaches" '. 'value="'.&mt('Update Caches').'" />'. &Apache::loncommon::help_open_topic('Statistics_Cache'), '<input type="hidden" name="prevsection" value="'.$sectionkey.'" />', '<input type="hidden" name="prevenrollstatus" value="'.$statuskey.'" />' ); # if (! exists($env{'form.firstrun'})) { $r->print('<input type="hidden" name="firstrun" value="yes" />'); } else { $r->print('<input type="hidden" name="firstrun" value="no" />'); } # return @Buttons; } sub gather_full_student_data { my ($r,$formname,$inputname) = @_; my $status_type; if (defined($formname)) { $status_type = 'inline'; } else { $status_type = 'popup'; } my $c = $r->connection(); # &Apache::loncoursedata::clear_internal_caches(); # my @Students = @Apache::lonstatistics::Students; # # Open the progress window my %prog_state=&Apache::lonhtmlcommon::Create_PrgWin ($r,&mt('Student Data Compilation Status'), &mt('Student Data Compilation Progress'), scalar(@Students), $status_type,undef,$formname,$inputname); # while (my $student = shift @Students) { return if ($c->aborted()); my $status = &Apache::loncoursedata::ensure_current_full_data ($student->{'username'},$student->{'domain'}, $env{'request.course.id'}); &Apache::lonhtmlcommon::Increment_PrgWin($r,\%prog_state, &mt('last student')); } &Apache::lonhtmlcommon::Close_PrgWin($r,\%prog_state); $r->rflush(); return; } #################################################### #################################################### =pod =item &submission_report_form Input: The originating reportSelected value for the current stats page. Output: Scalar containing HTML with needed form elements and a link to the student submission reports page. =cut #################################################### #################################################### sub submission_report_form { my ($original_report) = @_; # Note: In the link below we change the reportSelected value. If # the user hits the 'back' button on the browser after getting their # student submissions report, this value may still be around. So we # output a script block to set it properly. If the $original_report # value is unset, you are just asking for trouble. if (! defined($original_report)) { &Apache::lonnet::logthis ('someone called lonstathelpers::submission_report_form without '. ' enough input.'); } my $html = $/. '<script type="Text/JavaScript">'. "document.Statistics.reportSelected.value='$original_report';". '</script>'. '<input type="hidden" name="correctans" value="true" />'. '<input type="hidden" name="prob_status" value="true" />'. '<input type="hidden" name="all_sub" value="true" />'; my $output_selector = $/.'<select name="output">'.$/; foreach ('HTML','Excel','CSV') { $output_selector .= ' <option value="'.lc($_).'"'; if ($env{'form.output'} eq lc($_)) { $output_selector .= ' selected '; } $output_selector .='>'.&mt($_).'</option>'.$/; } $output_selector .= '</select>'.$/; my $link = '<a href="javascript:'. q{document.Statistics.reportSelected.value='student_submission_reports';}. 'document.Statistics.submit();">'; $html.= &mt('View data as [_1] [_2]go[_3]',$output_selector, $link,'</a>').$/; return $html } #################################################### #################################################### =pod =back =cut #################################################### #################################################### 1; __END__