[system] / trunk / pg / macros / PGasu.pl Repository:
ViewVC logotype

View of /trunk/pg/macros/PGasu.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7080 - (download) (as text) (annotate)
Fri Oct 28 23:00:08 2011 UTC (8 years, 2 months ago) by jj
File size: 15799 byte(s)
Fixed weighted_answer_grader to account for new way of labelling answer blanks.

    1 ###
    2 
    3 =head1 NAME
    4 
    5         PGasu.pl -- located in the pg/macros directory
    6 
    7 =head1 SYNPOSIS
    8 
    9 
   10   Macros contributed by John Jones
   11 
   12 =cut
   13 
   14 
   15 # Answer evaluator which always marks things correct
   16 
   17 =head3 auto_right()
   18 
   19 =pod
   20 
   21   Usage: ANS(auto_right());
   22           or
   23                ANS(auto_right("this answer can be left blank"));
   24 
   25 This answer checker marks any answer correct.  It is useful when you want
   26 to leave multiple answer blanks, only some of which will be used.  If you
   27 turn off showing partial correct answers and partial credit, the effect is
   28 not visible to the students.  The comment in the second case is what will
   29 be displayed as the correct answer.  This helps avoid confusion.
   30 
   31 =cut
   32 
   33 # ^function auto_right
   34 # ^uses AnswerEvaluator::new
   35 # ^uses auto_right_checker
   36 sub auto_right {
   37         my $cmt = shift;
   38         my %params = @_;
   39         $cmt = '' unless defined($cmt);
   40 
   41         my $answerEvaluator = new AnswerEvaluator;
   42         $answerEvaluator->ans_hash(
   43             type => "auto_right",
   44             correct_ans => "$cmt"
   45         );
   46         $answerEvaluator->install_pre_filter('reset');
   47         $answerEvaluator->install_evaluator(\&auto_right_checker,%params);
   48 
   49         return $answerEvaluator;
   50 }
   51 
   52 # used in auto_right above
   53 
   54 # ^function auto_right_checker
   55 sub auto_right_checker {
   56  my $ans = shift;
   57  $ans->score(1);
   58  return($ans);
   59 }
   60 
   61 
   62 =head3  no_decs()
   63 
   64 =pod
   65 
   66 Can be wrapped around an numerical evaluation.  It marks the answer wrong
   67 if it contains a decimal point.  Usage:
   68 
   69   ANS(no_decs(num_cmp("sqrt(3)")));
   70 
   71 This will accept "sqrt(3)" or "3^(1/2)" as answers, but not 1.7320508
   72 
   73 =cut
   74 
   75 # ^function no_decs
   76 # ^uses must_have_filter
   77 # ^uses raw_student_answer_filter
   78 # ^uses catch_errors_filter
   79 sub no_decs {
   80   my ($old_evaluator) = @_;
   81 
   82   my $msg= "Your answer contains a decimal.  You must provide an exact answer, e.g. sqrt(5)/3";
   83   $old_evaluator->install_pre_filter(must_have_filter(".", 'no', $msg));
   84   $old_evaluator->install_post_filter(\&raw_student_answer_filter);
   85   $old_evaluator->install_post_filter(\&catch_errors_filter);
   86 
   87   return $old_evaluator;
   88   }
   89 
   90 =head3     must_include()
   91 
   92 =pod
   93 
   94 Wrapper for other answer evaluators.  It insists that a string is part of
   95 the answer to be marked right.
   96 
   97 =cut
   98 
   99 # ^function must_include
  100 # ^uses must_have_filter
  101 # ^uses raw_student_answer_filter
  102 # ^uses catch_errors_filter
  103 sub must_include {
  104   my ($old_evaluator) = shift;
  105   my $muststr = shift;
  106 
  107   $old_evaluator->install_pre_filter(must_have_filter($muststr));
  108   $old_evaluator->install_post_filter(\&raw_student_answer_filter);
  109   $old_evaluator->install_post_filter(\&catch_errors_filter);
  110   return $old_evaluator;
  111   }
  112 
  113 =head3      no_trig_fun()
  114 
  115 Wrapper for other answer evaluators.  It marks the answer wrong if
  116 it contains one of the six basic trig functions.
  117 
  118 This is useful if you want students to report the value of sin(pi/4),
  119 but you don't want to allow "sin(pi/4)" as the answer.
  120 
  121 A similar effect can be accomplished with Contexts() by undefining
  122 the trig functions.
  123 See http://webwork.maa.org/wiki/Modifying_contexts_%28advanced%29#.282.29_Functions
  124 
  125 
  126 =cut
  127 
  128 # ^function no_trig_fun
  129 # ^uses fun_cmp
  130 # ^uses must_have_filter
  131 # ^uses catch_errors_filter
  132 sub no_trig_fun {
  133   my ($ans) = shift;
  134   my $new_eval = fun_cmp($ans);
  135   my ($msg) = "Your answer to this problem may not contain a trig function.";
  136   $new_eval->install_pre_filter(must_have_filter("sin", 'no', $msg));
  137   $new_eval->install_pre_filter(must_have_filter("cos", 'no', $msg));
  138   $new_eval->install_pre_filter(must_have_filter("tan", 'no', $msg));
  139   $new_eval->install_pre_filter(must_have_filter("sec", 'no', $msg));
  140   $new_eval->install_pre_filter(must_have_filter("csc", 'no', $msg));
  141   $new_eval->install_pre_filter(must_have_filter("cot", 'no', $msg));
  142 
  143   $new_eval->install_post_filter(\&catch_errors_filter);
  144   return $new_eval;
  145 }
  146 
  147 =head3      no_trig()
  148 
  149 
  150 
  151 =cut
  152 
  153 # ^function no_trig
  154 # ^uses num_cmp
  155 # ^uses must_have_filter
  156 # ^uses catch_errors_filter
  157 sub no_trig {
  158   my ($ans) = shift;
  159   my $new_eval = num_cmp($ans);
  160   my ($msg) = "Your answer to this problem may not contain a trig function.";
  161   $new_eval->install_pre_filter(must_have_filter("sin", 'no', $msg));
  162   $new_eval->install_pre_filter(must_have_filter("cos", 'no', $msg));
  163   $new_eval->install_pre_filter(must_have_filter("tan", 'no', $msg));
  164   $new_eval->install_pre_filter(must_have_filter("sec", 'no', $msg));
  165   $new_eval->install_pre_filter(must_have_filter("csc", 'no', $msg));
  166   $new_eval->install_pre_filter(must_have_filter("cot", 'no', $msg));
  167 
  168   $new_eval->install_post_filter(\&catch_errors_filter);
  169   return $new_eval;
  170 }
  171 
  172 =head3      exact_no_trig()
  173 
  174 
  175 
  176 =cut
  177 
  178 # ^function exact_no_trig
  179 # ^uses num_cmp
  180 # ^uses no_decs
  181 # ^uses must_have_filter
  182 sub exact_no_trig {
  183   my ($ans) = shift;
  184   my $old_eval = num_cmp($ans);
  185   my $new_eval = no_decs($old_eval);
  186   my ($msg) = "Your answer to this problem may not contain a trig function.";
  187   $new_eval->install_pre_filter(must_have_filter("sin", 'no', $msg));
  188   $new_eval->install_pre_filter(must_have_filter("cos", 'no', $msg));
  189   $new_eval->install_pre_filter(must_have_filter("tan", 'no', $msg));
  190   $new_eval->install_pre_filter(must_have_filter("sec", 'no', $msg));
  191   $new_eval->install_pre_filter(must_have_filter("csc", 'no', $msg));
  192   $new_eval->install_pre_filter(must_have_filter("cot", 'no', $msg));
  193 
  194   return $new_eval;
  195 }
  196 
  197 
  198 =head3      must_have_filter()
  199 
  200 =pod
  201 
  202 Filter for checking that an answer has (or doesn't have) a certain
  203 string in it.  This can be used to screen answers where you want them
  204 in a particular form (e.g., if you allow most functions, but not trig
  205 functions in the answer, or if the answer must include some string).
  206 
  207 First argument is the string to have, or not have
  208 Second argument is optional, and tells us whether yes or no
  209 Third argument is the error message to produce (if any).
  210 
  211 A similar effect can be accomplished with Contexts() by undefining
  212 the trig functions.
  213 See http://webwork.maa.org/wiki/Modifying_contexts_%28advanced%29
  214 
  215 =cut
  216 
  217 
  218 # First argument is the string to have, or not have
  219 # Second argument is optional, and tells us whether yes or no
  220 # Third argument is the error message to produce (if any).
  221 # ^function must_have_filter
  222 sub must_have_filter {
  223   my $str = shift;
  224   my $yesno = shift;
  225   my $errm = shift;
  226 
  227   $str =~ s/\./\\./g;
  228   if(!defined($yesno)) {
  229     $yesno=1;
  230   } else {
  231     $yesno = ($yesno eq 'no') ? 0 :1;
  232   }
  233 
  234   my $newfilt = sub {
  235     my $num = shift;
  236     my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
  237     my ($rh_ans);
  238     if ($process_ans_hash) {
  239       $rh_ans = $num;
  240       $num = $rh_ans->{original_student_ans};
  241     }
  242     my $is_ok = 0;
  243 
  244     return $is_ok unless defined($num);
  245 
  246     if (($yesno and ($num =~ /$str/)) or (!($yesno) and !($num=~ /$str/))) {
  247       $is_ok = 1;
  248     }
  249 
  250     if ($process_ans_hash)   {
  251       if ($is_ok == 1 ) {
  252         $rh_ans->{original_student_ans}=$num;
  253         return $rh_ans;
  254       } else {
  255         if(defined($errm)) {
  256           $rh_ans->{ans_message} = $errm;
  257           $rh_ans->{student_ans} = $rh_ans->{original_student_ans};
  258 #         $rh_ans->{student_ans} = "Your answer was \"$rh_ans->{original_student_ans}\". $errm";
  259           $rh_ans->throw_error('SYNTAX', $errm);
  260         } else {
  261           $rh_ans->throw_error('NUMBER', "");
  262         }
  263         return $rh_ans;
  264       }
  265 
  266     } else {
  267       return $is_ok;
  268     }
  269   };
  270   return $newfilt;
  271 }
  272 
  273 =head3      catch_errors_filter()
  274 
  275 =cut
  276 
  277 # ^function catch_errors_filter
  278 sub catch_errors_filter {
  279   my ($rh_ans) = shift;
  280   if ($rh_ans->catch_error('SYNTAX') ) {
  281     $rh_ans->{ans_message} = $rh_ans->{error_message};
  282     $rh_ans->clear_error('SYNTAX');
  283   }
  284   if ($rh_ans->catch_error('NUMBER') ) {
  285     $rh_ans->{ans_message} = $rh_ans->{error_message};
  286     $rh_ans->clear_error('NUMBER');
  287   }
  288   $rh_ans;
  289 }
  290 
  291 =head3      raw_student_answer_filter()
  292 
  293 
  294 
  295 =cut
  296 
  297 # ^function raw_student_answer_filter
  298 sub raw_student_answer_filter {
  299   my ($rh_ans) = shift;
  300 # warn "answer was ".$rh_ans->{student_ans};
  301   $rh_ans->{student_ans} = $rh_ans->{original_student_ans}
  302     unless ($rh_ans->{student_ans} =~ /[a-zA-Z]/);
  303 # warn "2nd time ... answer was ".$rh_ans->{student_ans};
  304 
  305   return $rh_ans;
  306 }
  307 
  308 =head3      no_decimal_list()
  309 
  310 
  311 
  312 =cut
  313 
  314 # ^function no_decimal_list
  315 # ^uses number_list_cmp
  316 sub no_decimal_list {
  317   my ($ans) = shift;
  318   my (%jopts) = @_;
  319   my $old_evaluator = number_list_cmp($ans);
  320 
  321   my $answer_evaluator = sub {
  322     my $tried = shift;
  323     my $ans_hash;
  324       if  ( ref($old_evaluator) eq 'AnswerEvaluator' ) { # new style
  325         $ans_hash = $old_evaluator->evaluate($tried);
  326       } elsif (ref($old_evaluator) eq  'CODE' )     { #old style
  327         $ans_hash = &$old_evaluator($tried);
  328     }
  329     if(defined($jopts{'must'}) && ! ($tried =~ /$jopts{'must'}/)) {
  330       $ans_hash->{score}=0;
  331       $ans_hash->setKeys( 'ans_message' => 'Your answer needs to be exact.');
  332     }
  333     if($tried =~ /\./) {
  334       $ans_hash->{score}=0;
  335       $ans_hash->setKeys( 'ans_message' => 'You may not use decimals in your answer.');
  336     }
  337     return $ans_hash;
  338   };
  339   return $answer_evaluator;
  340 }
  341 
  342 
  343 =head3      no_decimals()
  344 
  345 
  346 
  347 =cut
  348 
  349 # ^function no_decimals
  350 # ^uses std_num_cmp
  351 sub no_decimals {
  352   my ($ans) = shift;
  353   my (%jopts) = @_;
  354   my $old_evaluator = std_num_cmp($ans);
  355 
  356   my $answer_evaluator = sub {
  357     my $tried = shift;
  358     my $ans_hash;
  359       if  ( ref($old_evaluator) eq 'AnswerEvaluator' ) { # new style
  360         $ans_hash = $old_evaluator->evaluate($tried);
  361       } elsif (ref($old_evaluator) eq  'CODE' )     { #old style
  362         $ans_hash = &$old_evaluator($tried);
  363     }
  364     if(defined($jopts{'must'}) && ! ($tried =~ /$jopts{'must'}/)) {
  365       $ans_hash->{score}=0;
  366       $ans_hash->setKeys( 'ans_message' => 'Your answer needs to be exact.');
  367     }
  368     if($tried =~ /\./) {
  369       $ans_hash->{score}=0;
  370       $ans_hash->setKeys( 'ans_message' => 'You may not use decimals in your answer.');
  371     }
  372     return $ans_hash;
  373   };
  374   return $answer_evaluator;
  375 }
  376 
  377 =head3      with_comments()
  378 
  379 
  380   # Wrapper for an answer evaluator which can also supply comments
  381 
  382 =cut
  383 
  384 # Wrapper for an answer evaluator which can also supply comments
  385 
  386 # ^function with_comments
  387 sub with_comments {
  388   my ($old_evaluator, $cmt) = @_;
  389 
  390 #   $mdm = $main::displayMode;
  391 #   $main::displayMode = 'HTML_tth';
  392 #   $cmt = EV2($cmt);
  393 #   $main::displayMode =$mdm;
  394 
  395   my $ans_evaluator =  sub  {
  396     my $tried = shift;
  397     my $ans_hash;
  398 
  399     if  ( ref($old_evaluator) eq 'AnswerEvaluator' ) { # new style
  400       $ans_hash = $old_evaluator->evaluate($tried);
  401     } elsif (ref($old_evaluator) eq  'CODE' )     { #old style
  402       $ans_hash = &$old_evaluator($tried);
  403     } else {
  404       warn "There is a problem using the answer evaluator";
  405     }
  406 
  407     if($ans_hash->{score}>0) {
  408       $ans_hash -> setKeys( 'ans_message' => $cmt);
  409     }
  410     return $ans_hash;
  411   };
  412 
  413   $ans_evaluator;
  414 }
  415 
  416 
  417 =head3      pc_evaluator()
  418 
  419 
  420     # Wrapper for multiple answer evaluators, it takes a list of the following as inputs
  421     # [answer_evaluator, partial credit factor, comment]
  422     # it applies evaluators from the list until it hits one with positive credit,
  423     # weights it by the partial credit factor, and throws in its comment
  424 
  425 
  426 =cut
  427 
  428 
  429 # Wrapper for multiple answer evaluators, it takes a list of the following as inputs
  430 # [answer_evaluator, partial credit factor, comment]
  431 # it applies evaluators from the list until it hits one with positive credit,
  432 # weights it by the partial credit factor, and throws in its comment
  433 # ^function pc_evaluator
  434 sub pc_evaluator {
  435         my @ev_list;
  436         if(ref($_[0]) ne 'ARRAY') {
  437                 warn "Improper input to pc_evaluator";
  438         }
  439         if(ref($_[0]->[0]) ne 'ARRAY') {
  440                 @ev_list = @_;
  441         } else {
  442                 @ev_list = @{$_[0]};
  443         }
  444 
  445         my $ans_evaluator =  sub  {
  446                 my $tried = shift;
  447                 my $ans_hash;
  448                 for($j=0;$j<scalar(@ev_list); $j++) {
  449                         my $old_evaluator = $ev_list[$j][0];
  450                         my $cmt = $ev_list[$j][2];
  451                         my $weight = $ev_list[$j][1];
  452                         $weight = 1 unless defined($weight);
  453 
  454                         if  ( ref($old_evaluator) eq 'AnswerEvaluator' ) { # new style
  455                                 $ans_hash = $old_evaluator->evaluate($tried);
  456                         } elsif (ref($old_evaluator) eq  'CODE' )     { #old style
  457                                 $ans_hash = &$old_evaluator($tried);
  458                         } else {
  459                                 warn "There is a problem using the answer evaluator";
  460                         }
  461 
  462                         if($ans_hash->{score}>0) {
  463                                 $ans_hash -> setKeys( 'ans_message' => $cmt) if defined($cmt);
  464                                 $ans_hash->{score} *= $weight;
  465                                 return $ans_hash;
  466                         };
  467                 };
  468                 return $ans_hash;
  469         };
  470 
  471   $ans_evaluator;
  472 }
  473 
  474 
  475 
  476 =head3      weighted_partial_grader
  477 
  478 =pod
  479 
  480 This is a grader which weights the different parts of the problem
  481 differently.  The weights passed to it through the environment.  In
  482 the problem:
  483 
  484  $ENV{'partial_weights'} = [.2,.2,.2,.3];
  485 
  486 This will soon be superceded by a better grader.
  487 
  488 =cut
  489 
  490 # ^function weighted_partial_grader
  491 # ^uses $ENV{grader_message}
  492 # ^uses $ENV{partial_weights}
  493 sub weighted_partial_grader {
  494     my $rh_evaluated_answers = shift;
  495     my $rh_problem_state = shift;
  496     my %form_options = @_;
  497     my %evaluated_answers = %{$rh_evaluated_answers};
  498         #  The hash $rh_evaluated_answers typically contains:
  499         #      'answer1' => 34, 'answer2'=> 'Mozart', etc.
  500 
  501         # By default the  old problem state is simply passed back out again.
  502     my %problem_state = %$rh_problem_state;
  503 
  504 
  505         # %form_options might include
  506         # The user login name
  507         # The permission level of the user
  508         # The studentLogin name for this psvn.
  509         # Whether the form is asking for a refresh or
  510         #     is submitting a new answer.
  511 
  512         # initial setup of the answer
  513     my      $total=0;
  514         my %problem_result = ( score => 0,
  515                 errors => '',
  516                 type => 'custom_problem_grader',
  517                 msg => $ENV{'grader_message'}
  518                                );
  519 
  520 
  521     # Return unless answers have been submitted
  522     unless ($form_options{answers_submitted} == 1) {
  523         return(\%problem_result,\%problem_state);
  524     }
  525         # Answers have been submitted -- process them.
  526 
  527         ########################################################
  528         # Here's where we compute the score.  The variable     #
  529         # $numright is the number of correct answers.          #
  530         ########################################################
  531 
  532 
  533     my      $numright=0;
  534     my      $i;
  535     my      $ans_ref;
  536 
  537     warn "Partial value weights not defined" if not defined($ENV{'partial_weights'});
  538     my      @partial_weights = @{$ENV{'partial_weights'}};
  539     my      $total_weight=0;
  540 
  541     # Renormalize weights so they add to 1
  542     for $i (@partial_weights) { $total_weight += $i; }
  543     warn("Weights do not add to a positive number") unless ($total_weight >0);
  544     for $i (0..$#partial_weights) { $partial_weights[$i] /= $total_weight; }
  545 
  546     $i = 1;
  547     my $nextanswername = $PG->new_label($i);
  548     while (defined($ans_ref = $evaluated_answers{$nextanswername})) {
  549       $total += $ans_ref->{score}*$partial_weights[$i-1];
  550       $i++;
  551       $nextanswername = $PG->new_label($i);
  552     }
  553 
  554     $problem_result{score} = $total;
  555         # increase recorded score if the current score is greater.
  556     $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score};
  557 
  558     $problem_state{num_of_correct_ans}++ if $total == 1;
  559     $problem_state{num_of_incorrect_ans}++ if $total < 1 ;
  560 
  561     (\%problem_result, \%problem_state);
  562 }
  563 
  564 1;
  565 
  566 ## Local Variables:
  567 ## mode: CPerl
  568 ## font-lock-mode: t
  569 ## End:

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9