Development branch housing stable API (rstudio#53 rstudio#48 rstudio#47

rstudio#57)

* Message creation changes in check_result (rstudio#48)

* changes + tests to check_result messages

* I think I covered all message cases for check_result

* remove test_message_check_result.R

* unit tests for checking messages [wip]

* add default gradethis options to .onLoad

* correct message changes + tests for check_result

* uncomment incorrect tests and fix them

* rename match/correct to .is_match/.is_correct

* res returns a single bool using `all` and raises warning (rstudio#47)

* make sure res returns a single bool using `all`

* add reshape2, tibble, and tidyr to suggests section of DESCRPTION

* user/solution into fxns and skip tests if no pkg

* move common custom expect fxns to helper-expect.R

* add a warning before calling all() when length(res) >

* add documentation about == and identical

* remove dependencies only from billboard test

rstudio#47 (comment)

* Glue message upgrade + tests (rstudio#57), doc+DESCRIPTION changes

* upgrade glue_message ability (pair with barret)

* upgrade glue message generation for check result/code

* upgrade glue_message ability (pair with barret)

* upgrade glue message generation for check result/code

* fix R CMD check warnings

* small doc changes + lint fixes

* add \link to docs

* add \code brackets

* add \link

* add \code brackets to docs

* barret review changes

.Rbuildignore

@@ -9,3 +9,4 @@
 ^man-roxygen$
 ^\.lintr$
 ^\.vscode$
+^scripts/

DESCRIPTION

@@ -26,7 +26,6 @@ Imports:
     knitr,
     callr,
     learnr (>= 0.9.2.9001),
-    stringr,
     readr,
     checkmate,
     testthat

R/check_code.R

@@ -24,35 +24,31 @@
 #'
 #' For best results, name all arguments provided in the solution code.
 #'
-#' @param correct A character string to display if the student answer matches
-#'   the solution code.
-#'   This character string will be run through \code{glue::\link[glue]{glue_data}} with
-#'   \code{list(correct = TRUE, message = NULL)}.
-#' @param incorrect A character string to display if the student answer matches
-#'   the solution code.
-#'   This character string will be run through \code{glue::\link[glue]{glue_data}} with
-#'   \code{list(correct = FALSE, message = "<STRING>")}
-#'   where message is the error found while comparing the user solution to the known solution.
+#' @template correct
+#' @template incorrect
 #' @template grader_args
 #' @template learnr_args
+#' @template glue_correct
+#' @template glue_incorrect
+#' @param glue_pipe A glue string that returns the final message displayed when a user uses a pipe,
+#'    \code{$>$}. Defaults to \code{getOption("gradethis_glue_pipe")}.
 #'
 #' @return a \code{grader_graded} structure from \code{\link{result}}.
 #'   An incorrect message will describe the first way that the answer differs,
 #'   the message will be the content of the \code{correct}
 #'   argument.
 #'
-#'
-#'
-#'
-#'
 #' @export
 #' @examples
 #' \dontrun{grading_demo()}
 check_code <- function(
-  correct = "{random_praise()} Correct!",
-  incorrect = "{message} {random_encourage()}",
-  grader_args = list(), # provided by `grade_learnr`
-  learnr_args = list() # provided by `grade_learnr`
+  correct = NULL,
+  incorrect = NULL,
+  grader_args = list(),
+  learnr_args = list(),
+  glue_correct = getOption("gradethis_glue_correct"),
+  glue_incorrect = getOption("gradethis_glue_incorrect"),
+  glue_pipe = getOption("gradethis_glue_pipe")
 ) {
   chkm8_single_character(correct)
   chkm8_single_character(incorrect)
@@ -66,33 +62,28 @@ check_code <- function(
     return(
       graded(
         correct = TRUE,
-        message = glue::glue_data(
-          list(
-            correct = TRUE,
-            message = NULL
-          ),
-          correct
+        message = glue_message(
+          glue_correct,
+          .is_correct = TRUE,
+          .message = NULL,
+          .correct = correct
         )
       )
     )
   }
 
-  message <- glue::glue_data(
-    list(
-      correct = FALSE,
-      message = is_same_info$message
-    ),
-    incorrect
+  message <- glue_message(
+    glue_incorrect,
+    .is_correct = FALSE,
+    .message = is_same_info$message,
+    .incorrect = incorrect
   )
   if (uses_pipe(user)) {
-    message <- glue::glue_data(
-      list(
-        user = user,
-        message = message
-      ),
-      "I see that you are using pipe operators (e.g. %>%), ",
-      "so I want to let you know that this is how I am interpretting your code ",
-      "before I check it:\n\n{deparse(unpipe_all(user))}\n\n{message}"
+    message <- glue_message(
+      glue_pipe,
+      .user = user,
+      .message = message,
+      .incorrect = incorrect
     )
   }
 

R/check_result.R

@@ -5,16 +5,13 @@
 #' If the user result exactly matches a known \code{result}, \code{check_result}
 #' returns the matching message value.
 #'
+#' @param ... \code{\link{pass_if}} or \code{\link{fail_if}} conditions to check
 #' @template correct
-#' @param incorrect A character string to display if the student answer matches
-#'   a known answer.
-#'   This character string will be run through
-#'   \code{glue::\link[glue]{glue_data}} with
-#'   \code{list(correct = FALSE, message = "<result message>")}.
-#'   where message is the matched result message.
+#' @template incorrect
 #' @template grader_args
 #' @template learnr_args
-#' @param ... ignored
+#' @template glue_correct
+#' @template glue_incorrect
 #'
 #' @return a \code{grader_graded} structure from either
 #'   \code{\link{pass_if}} or \code{\link{fail_if}} containing a formatted
@@ -25,22 +22,23 @@
 #' \dontrun{grading_demo()}
 check_result <- function(
   ...,
-  correct = "{paste0(random_praise(), if (nchar(message) > 0) \" \", message)}",
-  incorrect = "{paste0(message, if(nchar(message) > 0) \" \", random_encourage())}",
-  grader_args = list(), # provided by `grade_learnr`
-  learnr_args = list() # provided by `grade_learnr`
+  correct = NULL,
+  incorrect = NULL,
+  grader_args = list(),
+  learnr_args = list(),
+  glue_correct = getOption("gradethis_glue_correct"),
+  glue_incorrect = getOption("gradethis_glue_incorrect")
 ) {
+
   results <- list(...)
   chkm8_item_class(results, "grader_condition")
-  chkm8_single_character(correct)
-  chkm8_single_character(incorrect)
 
   if (!any(vapply(results, `[[`, logical(1), "correct"))) {
     stop("At least one correct result must be provided")
   }
 
   # init final answer as not found
-  final_result <- graded(correct = FALSE, NULL)
+  final_result <- graded(correct = FALSE, message = NULL)
   found_match <- FALSE
 
   for (resu in results) {
@@ -52,13 +50,13 @@ check_result <- function(
     }
   }
 
-  message <- glue::glue_data(
-    list(
-      matched = found_match,
-      correct = final_result$correct,
-      message = final_result$message
-    ),
-    {if (final_result$correct) correct else incorrect} # nolint
+  message <- glue_message(
+    {if (final_result$correct) glue_correct else glue_incorrect}, # nolint
+    .is_match = found_match,
+    .is_correct = final_result$correct,
+    .message = final_result$message,
+    .correct = correct,
+    .incorrect = incorrect
   )
 
   return(graded(

R/glue.R

@@ -0,0 +1,30 @@
+#' Generate Glue string from expression
+#'
+#' Checks and validates arguments passed into \code{glue}.
+#'
+#' @param glue_expression A glue character expression string.
+#' @param ... Values to be inserted into glue expression.
+#' @noRd
+glue_message <- function(
+  glue_expression,
+  ...
+) {
+  params <- list(...)
+  param_names <- names(params)
+  is_bool <- grepl("^\\.is_", param_names)
+  bool_names <- param_names[is_bool]
+  char_names <- param_names[!is_bool]
+
+  if (length(bool_names) > 1) {
+    params[bool_names] <- lapply(params[bool_names], function(x){x %||% NA}) # nolint
+  }
+
+  params[char_names] <- lapply(char_names, function(char_name) {
+    x <- params[[char_name]] %||% "" # convert NULL strings to "" to work with glue
+    chkm8_single_character(x, char_name)
+    x
+  })
+
+  ret <- glue::glue_data(params, glue_expression)
+  return(ret)
+}

R/pass_fail_condi.R

@@ -1,13 +1,13 @@
 #' Pass if condition matches
-#' @param x a formula, function, or value, that returns \code{TRUE} or \code{FALSE}
+#' @template pass_fail_x_condition
 #' @param message chracter string for message returned
 #' @export
 pass_if <- function(x, message = NULL) {
   condition(x, message, correct = TRUE)
 }
 
 #' Fail if condition matches
-#' @param x a formula, function, or value, that returns \code{TRUE} or \code{FALSE}
+#' @template pass_fail_x_condition
 #' @param message chracter string for message returned
 #' @export
 fail_if <- function(x, message = NULL) {
@@ -67,6 +67,15 @@ evaluate_condition <- function(condi, grader_args, learnr_args) {
            "value" = evaluate_condi_value(condi$x, learnr_args$last_value)
          )
 
+  # if we compare something like a vector or dataframes to one another
+  # we need to collapse the result down to a single boolean value
+  if (length(res) > 1) {
+    ## this isn't the best way to handle NA values so we raise a warning.
+    ## https://github.com/rstudio-education/grader/issues/46 # nolint
+    warning(glue::glue("I got a length of {length(res)}, instead of 1 during the conditional check.\n Did you use == ? If so, consider using idential()")) # nolint
+    res <- !all(is.na(res)) && all(res, na.rm = TRUE)
+  }
+
   # implement when we add a `exec`/`expect` api to check_result
   # will account for function returns
   # if (inherits(res, 'grader_graded')) {return(res)} # nolint

R/test_result.R

@@ -30,13 +30,9 @@
 test_result <- function(
   ...,
   correct = "{num_correct}/{num_total} correct! {random_praise()}",
-  incorrect = paste0(
-    "{num_correct}/{num_total} correct. ",
-    "Fix this first: '{errors[1]}'. ",
-    "{random_encourage()}"
-  ),
-  grader_args = list(), # provided by `grade_learnr`
-  learnr_args = list() # provided by `grade_learnr`
+  incorrect = "",
+  grader_args = list(),
+  learnr_args = list()
 ) {
   tests <- grader_tests(...)
   chkm8_class(tests, "grader_tests")

R/view_tutorial.R

@@ -92,7 +92,7 @@ add_tutorial <- function(name, package) {
   # Check that the .Rprofile does not already load a tutorial
   if (file.exists(rprofile)) {
     text <- readr::read_file(rprofile)
-    if (stringr::str_detect(text, "view_tutorial\\(")) {
+    if (grepl("view_tutorial(", text, fixed = TRUE)) {
       stop(
         "This project already loads a tutorial upon opening.\n",
         "Please remove the tutorial by manually opening the ",

R/zzz.R

@@ -0,0 +1,17 @@
+gradethis_default_options <- list(
+  gradethis_glue_correct = "{ random_praise() } { .message } { .correct }",
+  gradethis_glue_incorrect = "{ .message } { .incorrect } { random_encourage() }",
+
+  gradethis_glue_pipe = paste0(
+    "I see that you are using pipe operators (e.g. %>%), ",
+    "so I want to let you know that this is how I am interpretting your code ",
+    "before I check it:\n\n{deparse(unpipe_all(.user))}\n\n{.message}")
+)
+
+.onLoad <- function(libname, pkgname) {
+  op <- options()
+  toset <- !(names(gradethis_default_options) %in% names(op))
+  if (any(toset)) options(gradethis_default_options[toset])
+
+  invisible()
+}

inst/tutorials/grading-demo/grading-demo.Rmd

@@ -19,7 +19,8 @@ knitr::opts_chunk$set(echo = FALSE)
 
 ### Check Exercise Result
 
-`gradethis` can check for the final returned value.  This grading approach does not inspect the code. It only inspects the final result.
+`gradethis` can check for the final returned value.
+This grading approach does not inspect the code. It only inspects the final result.
 
 See `?check_result` for more information.
 

man-roxygen/correct.R

@@ -1,4 +1 @@
-#' @param correct A character string to display if the student answer matches
-#'   a known answer.
-#'   This character string will be run through \code{glue::\link[glue]{glue_data}} with \code{list(correct = TRUE, message = "<result message>")}. where message is the matched result message.
-#'   \code{matched} is a boolean value about whether the submitted is found in a set of provided values.
+#' @param correct A character string to display if the student answer matches a known correct answer.

man-roxygen/glue_correct.R

@@ -0,0 +1,2 @@
+#' @param glue_correct A glue string that returns the final correct message displayed.
+#'    Defaults to \code{getOption("gradethis_glue_correct")}.

man-roxygen/glue_incorrect.R

@@ -0,0 +1,2 @@
+#' @param glue_incorrect A glue string that returns the final incorrect message displayed.
+#'    Defaults to \code{getOption("gradethis_glue_incorrect")}.

man-roxygen/grader_args.R

@@ -1,4 +1,5 @@
-#' @param grader_args A list of parameters passed to \code{grader} functions (provided by \code{grade_learnr}).  This contains: \describe{
+#' @param grader_args A list of parameters passed to \code{grader} functions (provided by \code{\link{grade_learnr}}).
+#'   This contains: \describe{
 #'    \item{\code{user_quo}}{Quoted R code submitted by the user.  Ex: \code{rlang::\link[rlang]{quo}(1)} }
 #'    \item{\code{solution_quo}}{[Optional] Quoted solution R code provided by the \code{*-solution} chunk for an exercise.}
 #'   }

man-roxygen/incorrect.R

@@ -0,0 +1 @@
+#' @param incorrect A character string to display if the student answer matches a known incorrect answer.

man-roxygen/learnr_args.R

@@ -1 +1,2 @@
-#' @param learnr_args A list of all parameters passed to \code{\link{grade_learnr}} by \code{learnr}. See \url{https://rstudio.github.io/learnr/exercises.html#exercise_checking} for more details.
+#' @param learnr_args A list of all parameters passed to \code{\link{grade_learnr}} by \code{learnr}.
+#'    See \url{https://rstudio.github.io/learnr/exercises.html#exercise_checking} for more details.

man-roxygen/pass_fail_x_condition.R

@@ -0,0 +1,5 @@
+#' @param x A formula, function, or value, that returns \code{TRUE} or \code{FALSE}.
+#'    When comparing objects that are greater than length 1 (e.g., vectors, dataframes, matricies, etc)
+#'    A boolean vector will be returned if the user uses \code{==}, not a single boolean value.
+#'    \code{grader} will run the vector through \code{all(..., na.rm = TRUE)} to check for the boolean value.
+#'    It is advised that the user use \code{identical()} instead of \code{==} in this case.