Incorporate rmatch_calls in omnitest.

NAMESPACE

@@ -1,4 +1,4 @@
-# Generated by roxygen2 (4.0.1): do not edit by hand
+# Generated by roxygen2 (4.0.2): do not edit by hand
 
 export(bye)
 export(email_admin)
@@ -10,10 +10,12 @@ export(install_course_google_drive)
 export(install_course_url)
 export(install_course_zip)
 export(install_from_swirl)
+export(is_robust_match)
 export(main)
 export(nxt)
 export(play)
 export(reset)
+export(rmatch_calls)
 export(skip)
 export(submit)
 export(swirl)

R/answerTests2.R

@@ -126,6 +126,7 @@ NULL
 #' @param correctExpr the correct or expected expression as a string
 #' @param correctVal the correct value (numeric or character)
 #' @param strict a logical value indicating that the expression should be as expected even if the value is correct. If \code{FALSE} (the default) a correct value will pass the test even if the expression is not as expected, but a notification will be issued.
+#' @param eval_for_class a logical value. If TRUE, evaluate the first argument of an S3 method to determine its class. Default=TRUE. Global value may also be set as customTests$EVAL_FOR_CLASS.
 #' @examples
 #' \dontrun{
 #' 
@@ -160,13 +161,29 @@ NULL
 #'   
 #'   }
 #'   @family AnswerTests
-omnitest <- function(correctExpr=NULL, correctVal=NULL, strict=FALSE){
+omnitest <- function(correctExpr=NULL, correctVal=NULL, strict=FALSE, eval_for_class=as.logical(NA)){
   e <- get("e", parent.frame())
   # Trivial case
   if(is.null(correctExpr) && is.null(correctVal))return(TRUE)
+  # If eval_for_class is not specified, default to customTests$EVAL_FOR_CLASS.
+  # If the latter is not set, default to TRUE.
+  if(is.na(eval_for_class)){
+    if(exists(customTests$EVAL_FOR_CLASS)){
+       eval_for_class <- isTRUE(customTests$EVAL_FOR_CLASS)
+    } else {
+      eval_for_class <- TRUE
+    }
+  }
+  # If eval_for_class is TRUE, create a parent environment for that in
+  # in which evaluations for class are to be made.
+  eval_env <- ifelse(eval_for_class, as.environment(e$snapshot), NULL)
   # Testing for correct expression only
   if(!is.null(correctExpr) && is.null(correctVal)){
-    return(expr_identical_to(correctExpr))
+    err <- try({
+      good_expr <- parse(text=correctExpr)[[1]]
+      ans <- is_robust_match(good_expr, e$expr, eval_for_class, eval_for_class)
+    }, silent=TRUE)
+    return(ifelse(is(err, "try-error"), expr_identical_to(correctExpr)), ans)
   }
   # Testing for both correct expression and correct value
   # Value must be character or single number
@@ -188,7 +205,15 @@ omnitest <- function(correctExpr=NULL, correctVal=NULL, strict=FALSE){
       valGood <- valResults$passed
     }
   }
-  exprGood <- ifelse(is.null(correctExpr), TRUE, expr_identical_to(correctExpr))
+  # If a correct expression is given attempt a robust match with user's expression.
+  exprGood <- TRUE
+  if(!is.null(correctExpr)){
+    err <- try({
+      good_expr <- parse(text=correctExpr)[[1]]
+      ans <- is_robust_match(good_expr, e$expr, eval_for_class, eval_for_class)
+    }, silent=TRUE)
+    exprGood <- ifelse(is(err, "try-error"), expr_identical_to(correctExpr), ans)
+  }
   if(valGood && exprGood){
     return(TRUE)
   } else if (valGood && !exprGood && !strict){

R/rmatch_calls.R

@@ -0,0 +1,144 @@
+# Reference: Creating a More Robust Version of Omnitest, https://github.com/swirldev/swirl/issues/196
+
+#' Recursively expand both the correct expression and the user's expression and
+#' test for a match. CAUTION: May raise errors, as in rmatch_calls.
+#' 
+#' @export
+#' @param expr1 expression
+#' @param expr2 expression
+#' @param eval_for_class TRUE or FALSE. If TRUE, evaluate the first argument of an S3 method to determine its class. Default=FALSE.
+#' @param eval_env parent environment for evaluations to determine class. Ignored if eval_for_class=FALSE
+#' @return TRUE or FALSE according to whether expanded expressions match.
+#' @examples
+#' \dontrun{
+#'   
+#'   expr1 <- quote(print(paste("my_name_is", "mud")))
+#'   expr2 <- quote(print(paste("my_name_is", "mud", sep=" ")))
+#'   err <- try(ans <- is_robust_match(expr1, expr2, eval_for_class=TRUE), silent=TRUE)
+#'   if(is(ans, "try-error")){
+#'     ans <- isTRUE(all.equal())
+#'   }
+#' }
+is_robust_match <- function(expr1, expr2, eval_for_class, eval_env=NULL){
+  expr1 <- rmatch_calls(expr1, eval_for_class, eval_env)
+  expr2 <- rmatch_calls(expr2, eval_for_class, eval_env)
+  isTRUE(all.equal(expr1, expr2))
+}
+
+#' Recursively expand match calls in an expression from the bottom up.
+#' 
+#' Given an expression, expr, traverse the syntax tree from the
+#' bottom up, expanding the call to include default values of
+#' named formals as appropriate, and applying match.call to the result.
+#' Functionality is limited to expressions containing ordinary functions
+#' or S3 methods. If parameter eval_for_class has its default value of FALSE,
+#' an error will be raised for any S3 method whose first argument (as an expression) 
+#' is not atomic. If eval_for_class is TRUE, the first argument will be evaluated
+#' to determine its class. Evaluation will take place in the environment given by
+#' parameter eval_env. 
+#' CAUTION: eval_for_class=TRUE is likely to result in multiple evaluations of the same code.
+#' Expressions containing S4 or reference class methods will also raise errors.
+#' @export
+#' @param expr an R expression (a.k.a. abstract syntax tree)
+#' @param eval_for_class TRUE or FALSE. If TRUE, evaluate the first argument of an S3 method to determine its class. Default=FALSE.
+#' @param eval_env environment in which to evaluate for class. Ignored if eval_for_class=FALSE
+#' @return an equivalent R expression with function or method calls in canonical form.
+#' @examples
+#' \dontrun{
+#' 
+#' # Function
+#' > rmatch_calls(quote(help("print")))
+#' help(topic = "print", package = NULL, lib.loc = NULL, verbose = getOption("verbose"), 
+#' try.all.packages = getOption("help.try.all.packages"), help_type = getOption("help_type"))
+#' 
+#' # S3 method with atomic first argument
+#' > rmatch_calls(quote(seq(0, 1, by=.5)))
+#' seq(from = 0, to = 1, by = 0.5, length.out = NULL, along.with = NULL)
+#' 
+#' # S3 method with non-atomic first argument, eval_for_class = FALSE (default)
+#' > rmatch_calls(quote(seq(as.Date("2014-02-01"), as.Date("2014-03-01"))))
+#' Error in rmatch_calls(quote(seq(as.Date("2014-02-01"), as.Date("2014-03-01")))) : 
+#'  Illegal expression, seq(as.Date(x = "2014-02-01"), as.Date(x = "2014-03-01")): 
+#'  The first argument, as.Date(x = "2014-02-01"), to S3 method 'seq', is a call, 
+#'  which (as an expression) is not atomic, hence its class can't be determined in an 
+#'  abstract syntax tree without additional information.
+#'  
+#' # S3 method with non-atomic first argument, eval_for_class = TRUE
+#' > rmatch_calls(quote(seq(as.Date("2014-02-01"), as.Date("2014-03-01"))), eval_for_class=TRUE)
+#' seq(from = as.Date(x = "2014-02-01"), to = as.Date(x = "2014-03-01"), 
+#'     length.out = NULL, along.with = NULL)  
+#' }
+rmatch_calls <- function(expr, eval_for_class=FALSE, eval_env=NULL){
+  # If expr is not a call, just return it.
+  if(!is.call(expr))return(expr)
+  # Replace expr's components with matched versions.
+  for(n in 1:length(expr)){
+    expr[[n]] <- rmatch_calls(expr[[n]],eval_for_class)
+  }
+  # If match.fun(expr[[1]]) raises an exception here, the code which follows
+  # would be likely to give a misleading result. Catch the error merely to
+  # produce a better diagnostic.
+  tryCatch(fct <- match.fun(expr[[1]]),
+           error=function(e)stop(paste0("Illegal expression ", dprs(expr), 
+                                        ": ", dprs(expr[[1]]), " is not a function.\n")))
+  # If fct is a special function such as `$`, or builtin such as `+`, return expr.
+  if(is.primitive(fct)){
+    return(expr)
+  }
+  # If fct is an (S4) standardGeneric, match.call is likely to give a misleading result,
+  # so raise an exception. (Note that builtins were handled earlier.)
+  if(is(fct, "standardGeneric")){
+    stop(paste0("Illegal expression, ", dprs(expr), ": ", dprs(expr[[1]]), " is a standardGeneric.\n"))
+  }
+  # At this point, fct should be an ordinary function or an S3 method.
+  if(isS3(fct)){
+    # If the S3 method's first argument, expr[[2]], is anything but atomic 
+    # its class can't be determined here without evaluation.
+    if(!is.atomic(expr[[2]]) & !eval_for_class){
+      stop(paste0("Illegal expression, ", dprs(expr),": The first argument, ", dprs(expr[[2]]), 
+                  ", to S3 method '", dprs(expr[[1]]), 
+                  "', is a ", class(expr[[2]]) , ", which (as an expression) is not atomic,",
+                  " hence its class can't be determined in an abstract",
+                  " syntax tree without additional information.\n"))
+    }
+    # Otherwise, attempt to find the appropriate method.
+    if(is.null(eval_env)){
+      eval_env <- new.env()
+    } else {
+      eval_env <- new.env(parent=eval_env)
+    }
+    temp <- eval(expr[[2]], envir = eval_env)
+    classes <- try(class(temp), silent=TRUE)
+    for(cls in classes){
+      err <- try(fct <- getS3method(as.character(expr[[1]]), cls), silent=TRUE)
+      if(!is(err, "try-error"))break
+    }
+    # If there was no matching method, attempt to find the default method. If that fails,
+    # raise an error
+    if(is(err, "try-error")){
+      tryCatch(fct <- getS3method(as.character(expr[[1]]), "default"),
+               error = function(e)stop(paste0("Illegal expression ", dprs(expr), ": ",
+                                              "There is no matching S3 method or default for object, ",
+                                              dprs(expr[[2]]), ", of class, ", cls,".\n")))
+    }
+  }
+  # Form preliminary match. If match.call raises an error here, the remaining code is
+  # likely to give a misleading result. Catch the error merely to give a better diagnostic.
+  tryCatch(expr <- match.call(fct, expr),
+           error = function(e)stop(paste0("Illegal expression ", dprs(expr), ": ", 
+                                          dprs(expr[[1]]), " is not a function.\n")))
+  # Append named formals with default values which are not included
+  # in the preliminary match
+  fmls <- formals(fct)
+  for(n in names(fmls)){
+    if(!isTRUE(fmls[[n]] == quote(expr=)) && !(n %in% names(expr[-1]))){
+      expr[n] <- fmls[n]
+    }
+  }
+  # match call again, for order
+  expr <- match.call(fct, expr)
+  return(expr)
+}
+# Helpers
+isS3 <- function(fct)isTRUE(grep("UseMethod", body(fct)) > 0)
+dprs <- function(expr)deparse(expr, width.cutoff=500)

man/AnswerTests.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{AnswerTests}
 \alias{AnswerTests}
 \title{Answer Tests}

man/InstallCourses.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{InstallCourses}
 \alias{InstallCourses}
 \title{Installing Courses}

man/any_of_exprs.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{any_of_exprs}
 \alias{any_of_exprs}
 \title{Test that the user has entered one of several possible expressions.}

man/bye.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{bye}
 \alias{bye}
 \title{Exit swirl.}

man/email_admin.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{email_admin}
 \alias{email_admin}
 \title{Send diagnostic email to swirl admin}

man/expr_creates_var.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{expr_creates_var}
 \alias{expr_creates_var}
 \title{Test that a new variable has been created.}

man/expr_identical_to.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{expr_identical_to}
 \alias{expr_identical_to}
 \title{Test that the user has entered a particular expression.}

man/expr_is_a.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{expr_is_a}
 \alias{expr_is_a}
 \title{Test that the expression itself is of a specific \code{class}.}

man/expr_uses_func.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{expr_uses_func}
 \alias{expr_uses_func}
 \title{Test that a particular function has been used.}

man/func_of_newvar_equals.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{func_of_newvar_equals}
 \alias{func_of_newvar_equals}
 \title{Test the result of a computation applied to a specific (user-named)

man/info.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{info}
 \alias{info}
 \title{Display a list of special commands.}

man/install_course_directory.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_course_directory}
 \alias{install_course_directory}
 \title{Install a course from a course directory}

man/install_course_dropbox.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_course_dropbox}
 \alias{install_course_dropbox}
 \title{Install a course from a zipped course directory shared on Dropbox}

man/install_course_github.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_course_github}
 \alias{install_course_github}
 \title{Install a course from a GitHub repository}

man/install_course_google_drive.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_course_google_drive}
 \alias{install_course_google_drive}
 \title{Install a course from a zipped course directory shared on Google Drive}

man/install_course_url.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_course_url}
 \alias{install_course_url}
 \title{Install a course from a url that points to a zip file}

man/install_course_zip.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_course_zip}
 \alias{install_course_zip}
 \title{Install a course from a zipped course folder}

man/install_from_swirl.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{install_from_swirl}
 \alias{install_from_swirl}
 \title{Install a course from the official course repository}

man/is_robust_match.Rd

@@ -0,0 +1,36 @@
+% Generated by roxygen2 (4.0.2): do not edit by hand
+\name{is_robust_match}
+\alias{is_robust_match}
+\title{Recursively expand both the correct expression and the user's expression and
+test for a match. CAUTION: May raise errors, as in rmatch_calls.}
+\usage{
+is_robust_match(expr1, expr2, eval_for_class, eval_env = NULL)
+}
+\arguments{
+\item{expr1}{expression}
+
+\item{expr2}{expression}
+
+\item{eval_for_class}{TRUE or FALSE. If TRUE, evaluate the first argument of an S3 method to determine its class. Default=FALSE.}
+
+\item{eval_env}{parent environment for evaluations to determine class. Ignored if eval_for_class=FALSE}
+}
+\value{
+TRUE or FALSE according to whether expanded expressions match.
+}
+\description{
+Recursively expand both the correct expression and the user's expression and
+test for a match. CAUTION: May raise errors, as in rmatch_calls.
+}
+\examples{
+\dontrun{
+
+  expr1 <- quote(print(paste("my_name_is", "mud")))
+  expr2 <- quote(print(paste("my_name_is", "mud", sep=" ")))
+  err <- try(ans <- is_robust_match(expr1, expr2, eval_for_class=TRUE), silent=TRUE)
+  if(is(ans, "try-error")){
+    ans <- isTRUE(all.equal())
+  }
+}
+}
+

man/main.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{main}
 \alias{main}
 \title{Return to swirl's main menu.}

man/nxt.Rd

@@ -1,4 +1,4 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{nxt}
 \alias{nxt}
 \title{Begin the upcoming question or unit of instruction.}

man/omnitest.Rd

@@ -1,16 +1,19 @@
-% Generated by roxygen2 (4.0.1): do not edit by hand
+% Generated by roxygen2 (4.0.2): do not edit by hand
 \name{omnitest}
 \alias{omnitest}
 \title{Test for a correct expression, a correct value, or both.}
 \usage{
-omnitest(correctExpr = NULL, correctVal = NULL, strict = FALSE)
+omnitest(correctExpr = NULL, correctVal = NULL, strict = FALSE,
+  eval_for_class = as.logical(NA))
 }
 \arguments{
 \item{correctExpr}{the correct or expected expression as a string}
 
 \item{correctVal}{the correct value (numeric or character)}
 
 \item{strict}{a logical value indicating that the expression should be as expected even if the value is correct. If \code{FALSE} (the default) a correct value will pass the test even if the expression is not as expected, but a notification will be issued.}
+
+\item{eval_for_class}{a logical value. If TRUE, evaluate the first argument of an S3 method to determine its class. Default=TRUE. Global value may also be set as customTests$EVAL_FOR_CLASS.}
 }
 \description{
 Omnitest can test for a correct expression, a correct value,