Extension for template-based practice problems

.travis.yaml

@@ -0,0 +1,9 @@
+language: R
+cache: packages
+sudo: false
+
+notifications:
+  email:
+    on_success: always
+    on_failure: always
+

NAMESPACE

@@ -19,6 +19,7 @@ export(play)
 export(reset)
 export(restart)
 export(rmatch_calls)
+export(rpt)
 export(select_language)
 export(skip)
 export(submit)

R/actions.R

@@ -4,6 +4,7 @@ do_submit <- function(e)UseMethod("do_submit")
 do_play <- function(e)UseMethod("do_play")
 do_main <- function(e)UseMethod("do_main")
 do_restart <- function(e)UseMethod("do_restart")
+do_repeat <- function(e)UseMethod("do_repeat")
 
 do_nxt.default <- function(e) {
   ## Using the stored list of "official" swirl variables and values,
@@ -24,14 +25,49 @@ do_reset.default <- function(e) {
             skip_after = TRUE)
 }
 
+do_repeat.default <-function(e) {
+     e$playing <- FALSE
+     e$iptr <- 1
+
+
+     go_back = TRUE
+     while(go_back) {
+	if (e$row == 1) {
+          swirl_out("This is the beginning of the lesson.", skip_after = FALSE)
+          return()
+     	}  
+     	# if current question has not been repeated yet, 
+     	# then go to previous question 
+ 	num = as.integer(e$les[e$row,]$TimesRepeated)
+  	if (num == 0) {
+     	   e$row <- e$row - 1
+  	}
+
+  	# update TimesRepeated counter in all cases 
+   	num = as.integer(e$les[e$row,]$TimesRepeated)
+    	num = max(num - 1,0)
+   	e$les[e$row,]$TimesRepeated = num
+
+	# if this is a text block, keep repeating
+	if (e$les[e$row,]$Class == "text") go_back = TRUE
+	else go_back = FALSE
+
+     }
+     swirl_out("Repeating the previous question.", skip_after = FALSE)
+}
+
 do_submit.default <- function(e) {
   e$playing <- FALSE
-  # Get contents from user's submitted script
-  e$script_contents <- readLines(e$script_temp_path, warn = FALSE)
-  # Save expr to e
-  e$expr <- try(parse(text = e$script_contents), silent = TRUE)
-  swirl_out(s()%N%"Sourcing your script...", skip_after = TRUE)
-  try(source(e$script_temp_path, encoding = "UTF-8"))
+
+  # if script question, then source the script
+  if (e$current.row$Class=="script") {
+    # Get contents from user's submitted script
+    e$script_contents <- readLines(e$script_temp_path, warn = FALSE)
+    # Save expr to e
+    e$expr <- try(parse(text = e$script_contents), silent = TRUE)
+    swirl_out(s()%N%"Sourcing your script...", skip_after = TRUE)
+    try(source(e$script_temp_path, encoding = "UTF-8"))
+  }
 }
 
 do_play.default <- function(e) {
@@ -49,4 +85,4 @@ do_main.default <- function(e) {
 
 do_restart.default <- function(e) {
   swirl_out(s()%N%"This feature is not implemented yet for Swirl.")
-}
+}

R/answerTests2.R

@@ -328,6 +328,36 @@ any_of_exprs <- function(...){
   any(sapply(c(...), function(expr) omnitest(expr)))
 }
 
+#' Test that the user has created an object with a specific 
+#' numerical value.
+#' 
+#' Returns \code{TRUE} if the object with the given name 
+#' has the specified value, within a certain error tolerance
+#' @param var an object name as a string
+#' @param val the desired value
+#' @param eps the error tolerance  
+#' @return \code{TRUE} or \code{FALSE}
+#' @note error tolerance is needed since seemingly identical numerical 
+#'    calculations may differ, such as 1-pnorm(3) and 
+#'    pnorm(3, lower.tail = FALSE)
+#' @examples
+#' \dontrun{
+#' 
+#' # Test that a user has set X = P(Z < 1.4), where Z ~ N(0,1) 
+#'   var_has_value('X', pnorm(1.4), 1e-10)
+#' }
+#' @family AnswerTests
+var_has_value <- function(var, val, eps = 0) {
+  var <- str_trim(var)
+  if(exists(var, globalenv())){
+    var <- get(var, globalenv())
+    return (identical(abs(val-var)<=eps, TRUE))
+  } else {
+    swirl_out(paste0("Error: ", var, " does not exist. Make sure to store your answer in ", var, "."))
+    return(FALSE)
+  }
+}
+
 #' Test that the value of the expression is of a specific class.
 #' 
 #' Returns \code{TRUE} if a variable of the given name exists

R/instructionSet.R

@@ -101,6 +101,14 @@ waitUser.cmd_question <- function(current.row, e){
   e$iptr <- 1 + e$iptr
 }
 
+waitUser.multi_cmd_question <-function(current.row, e) {
+ e$prompt <- TRUE
+ # Enter 'play' mode so that user can mess around in the console
+ e$playing <- TRUE
+ # Advance lesson
+ e$iptr <- 1 + e$iptr
+}
+
 #' @importFrom tools file_path_sans_ext
 waitUser.script <- function(current.row, e){
   # If this is the first attempt or the user wants to start over, 
@@ -179,7 +187,15 @@ testResponse.default <- function(current.row, e){
     mes <- praise()
     post_result(e, passed = correct, feedback = mes, hint = NULL)
     e$iptr <- 1
-    e$row <- 1 + e$row
+
+    #update TimesRepeated for this question and i
+    num = as.integer(e$current.row$TimesRepeated)
+    num = num + 1
+    e$les[e$row,]$TimesRepeated = num
+    # move to next row if we are done
+    if (num >= e$current.row$NumTimes) {
+       e$row <- 1 + e$row
+    }
     # Reset attempts counter, since correct
     e$attempts <- 1
   } else {
@@ -197,7 +213,17 @@ testResponse.default <- function(current.row, e){
     if(is(current.row, "cmd_question") && !is(e, "datacamp")) {
       mes <- paste(mes, s()%N%"Or, type info() for more options.")
     }
+
+    save(current.row, file = "tmp.RData")
+    # get hint, possibly using hint function
     hint <- current.row[,"Hint"]
+    if (!is.na(e$current.row$HintFunction)) {
+#         hf = get(e$current.row$HintFunction)
+         hf <- current.row[, "HintFunction"]
+         #hint <- hf()
+         hint <- eval(parse(text = hf))
+    }
+
     post_result(e, passed = correct, feedback = mes, hint = if(is.na(hint)) NULL else hint)
     e$iptr <- e$iptr - 1
   }

R/parse_content.R

@@ -49,7 +49,9 @@ parse_content.yaml <- function(file, e){
     temp <- data.frame(Class=NA, Output=NA, CorrectAnswer=NA,
                        AnswerChoices=NA, AnswerTests=NA, 
                        Hint=NA, Figure=NA, FigureType=NA, 
-                       VideoLink=NA, Script=NA)
+                       VideoLink=NA, Script=NA, 
+		       NumTimes = 1, TimesRepeated = 0, Token = NA,
+	               HintFunction = NA)
     for(nm in names(element)){
       # Only replace NA with value if value is not NULL, i.e. instructor
       # provided a nonempty value

R/swirl.R

@@ -153,6 +153,16 @@ skip <- function(){invisible()}
 #' @export
 reset <- function(){invisible()}
 
+
+#' Repeat the previous question
+#'
+#' During a script question, this will move the pointer back to the previous 
+#' row to repeat the previous question (with new values if question templates
+#' are used. 
+#' @export
+rpt <- function(){invisible()}
+
+
 #' Submit the active R script in response to a question.
 #' 
 #' When a swirl question requires the user to edit an R script, the
@@ -229,6 +239,7 @@ restart <- function(){invisible()}
 info <- function(){
   swirl_out(s()%N%"When you are at the R prompt (>):")
   swirl_out(s()%N%"-- Typing skip() allows you to skip the current question.", skip_before=FALSE)
+  swirl_out(s()%N%"-- Typing rpt() will repeat the previous question (possibly with different values", skip_before = FALSE) 
   swirl_out(s()%N%"-- Typing play() lets you experiment with R on your own; swirl will ignore what you do...", skip_before=FALSE)
   swirl_out(s()%N%"-- UNTIL you type nxt() which will regain swirl's attention.", skip_before=FALSE)
   swirl_out(s()%N%"-- Typing bye() causes swirl to exit. Your progress will be saved.", skip_before=FALSE)
@@ -268,7 +279,12 @@ resume.default <- function(e, ...){
   if(uses_func("reset")(e$expr)[[1]]) {
     do_reset(e)
   }
-
+
+  # The user wants to repeat the previous question 
+  if(uses_func("rpt")(e$expr)[[1]]) {
+    do_repeat(e)
+  }
+
   # The user wants to submit their R script
   if(uses_func("submit")(e$expr)[[1]]){
     do_submit(e)
@@ -391,6 +407,7 @@ resume.default <- function(e, ...){
        !uses_func("testit")(e$expr)[[1]] &&
        !uses_func("demo_lesson")(e$expr)[[1]] &&
        !uses_func("nxt")(e$expr)[[1]] &&
+        !uses_func("rpt")(e$expr)[[1]] &&
        isTRUE(customTests$AUTO_DETECT_NEWVAR)) {
     e$delta <- mergeLists(safeEval(e$expr, e), e$delta)
   }
@@ -457,13 +474,20 @@ resume.default <- function(e, ...){
       e$delta <- list()
       saveProgress(e)
       e$current.row <- e$les[e$row,]
+
+      # generate token values if necessary
+      tt = token.generate(e$current.row, e$token.list)
+      e$token.list <- tt$token.list
+      e$current.row = tt$row
+
       # Prepend the row's swirl class to its class attribute
       class(e$current.row) <- c(e$current.row[,"Class"], 
                                        class(e$current.row))
     }
 
     # Execute the current instruction
     e$instr[[e$iptr]](e$current.row, e)
+
     # Check if a side effect, such as a sourced file, has changed the
     # values of any variables in the official list. If so, add them
     # to the list of changed variables.

R/tokens.R

@@ -0,0 +1,65 @@
+##################################################################
+## generates and assigns values to tokens for a given row
+##################################################################
+token.generate <- function(row, token.list){
+  tokens = NULL 
+  if(!is.na(row$Token)){                #If there's anything in the 'Token' row,
+    token.list <- tokens.create(as.character(row$Token), token.list)  #create the tokens
+    row <- tokens.replace(row, token.list)  #then replace the tokens
+  } else if (!is.null(token.list)){	# if there's anything in the token.list	
+    row <-tokens.replace(row, token.list) # then replace the tokens
+  }
+  ans = list(row = row, token.list = token.list)
+  return(ans)
+}
+
+
+########################################################################
+# executes R code in .token.str and returns a list containing objects
+# in the .token.list as well as any new objects created in the function
+########################################################################
+tokens.create <- function(.token.str, .token.list) {
+
+  # add token.list objects to function namespace,
+  # since these may be used by .token.str
+  if (!is.null(.token.list)) {
+     .n = length(.token.list)
+     for(.i in 1:.n) {
+       .na = names(.token.list)[.i]
+       assign(.na, .token.list[[.na]])
+     }
+   }
+
+  #executes token code
+  eval(parse(text = .token.str))   
+  # creates a vector of tokens in the function environment
+  .tokens = ls() 
+  # creates list of (token,value) pairs
+  .vals = lapply(1:length(.tokens), function(i,t) {get(t[i])}, 
+	t= .tokens)
+  names(.vals) = .tokens
+
+  return(.vals)
+}
+
+###################################################################
+# For given row, replace each token <T> with its value
+# Note: only some token types are valid here (see code below), and 
+#  vectors/matrix values are formatted to be comma-separated   
+###################################################################
+tokens.replace <- function(row,tokens){
+  replace<-function(s,t.name,t.val) {
+	if (is.na(s)) return(NA)
+        gsub(paste0("<",t.name,">"),t.val[1], s)
+  }
+
+  valid = c("logical", "integer", "double", "character")
+  token.names = names(tokens)[which(sapply(tokens, typeof) %in% valid)]
+  for (n in token.names){
+    row = lapply(row, replace,t.name = n,t.val = paste0(tokens[[n]],collapse = ","))
+  }
+  row = data.frame(row, stringsAsFactors = FALSE) 
+  return(row)
+}
+
+