R/test-exercise.R

In Data-Camp/testwhat: Easily write submission correctness tests for R exercises

#' Run all tests for an exercise
#'
#' Run all tests for an exercise and report the results (including feedback).
#' This function is run by R Backend and should not be used by course creators.
#'
#' @param sct Submission correctness tests as a character string.
#' @param ex_type Type of the exercise
#' @param pec pre-exercise-code
#' @param student_code character string representing the student code
#' @param solution_code character string representing the solution code
#' @param student_env environment containing the objects defined by the student.
#' @param solution_env environment containing the objects defined by solution code
#' @param output_list the output structure that is generated by RBackend
#' @param allow_errors whether or not errors are allowed by RBackend (FALSE by default)
#' @param force_diagnose whether diagnose tests have to pass even if the checks pass (FALSE by default)
#' @param seed random seed that is used for SCTs that run expressions (42 by default).
#'
#' @return A list with components \code{passed} that indicates whether all
#' tests were sucessful, and \code{feedback} that contains a feedback message.
#'
#' @export
test_exercise <- function(sct, 
                          ex_type, 
                          pec,
                          student_code,
                          solution_code,
                          student_env,
                          solution_env,
                          output_list,
                          allow_errors = FALSE,
                          force_diagnose = FALSE,
                          seed = 42) {
  # backwards compatibility with older versions of RBackend
  if (missing(student_env)) {
    student_env <- globalenv()
  }
  
  # First check if parsing worked out
  if (any(sapply(output_list, `[[`, "type") == "parse-error")) {
    report <- tryCatch(do_parse(student_code),
                       error = function(e) {
                         list(message = parse_fallback_msg)
                       })
    return(c(list(correct = FALSE), report))
  } else {
    # Store everything that's needed locally (initialize does a full reset)
    tw$clear()
    tw$set(success_msg = sample(c("Good Job!", "Well done!", "Great work!"), 1))
    state <- RootState$new(pec = pec,
                           student_code = student_code,
                           student_pd = build_pd(student_code),
                           student_env = student_env,
                           solution_code = solution_code,
                           solution_pd = build_pd(solution_code),
                           solution_env = solution_env,
                           output_list = output_list,
                           test_env = new.env(parent = environment()),
                           force_diagnose = force_diagnose)
    tw$set(state = state,
           stack = TRUE,
           seed = seed)
    on.exit(tw$clear())
    
    # Execute sct with the DataCamp reporter such that it collects test results
    res <- run_until_fail(parse(text = sct))

    # If the SCT passed, check whether there is an error as the last step
    if (isTRUE(res$correct) && !allow_errors) {
      res <- run_until_fail(ex() %>% check_error())
    }

    return(post_process(res, ex_type))
  }
}

#' Run SCT until it fails
#'
#' @param code the SCT script to run as an expression
#'
#' @export
run_until_fail <- function(code) {
  tryCatch({
    # Run the SCT
    eval(code, envir = tw$get("state")$get("test_env"))
    # If it got here, the SCT passed
    return(list(correct = TRUE, message = tw$get("success_msg")))
  }, sct_failure = function(e) {
    return(list(correct = FALSE,
                message = e$message,
                feedback = attr(e, "feedback")))
  })
}


post_process <- function(res, ex_type) {
  # convert to HTML
  res$message <- to_html(res$message)
  
  # Only add line info if:
  # - message is incorrect, and
  # - exercise is not markdown / rcpp (post-processing of code chunks gives strange things)
  if (!res$correct && !(ex_type %in% c("MarkdownExercise", "RCppExercise"))) {
    line_info <- get_line_info(res$feedback)
    if (!is.null(line_info)) {
      res <- c(res, line_info)
    }
  }
  res$feedback <- NULL
  return(res)
}