#' Check whether a student correctly called a function/operator
#'
#' Check whether a student called a function correctly. Note:
#' \code{test_function} and \code{test_function_v2} are now identical and either
#' can be used.
#'
#' @param state state to start from
#' @param name name of the function/operator as a string, e.g. \code{"mean"} or
#' \code{"+"}
#' @param index integer that specifies which call of \code{name} in the
#' solution code will be checked.
#' @param eval logical vector indicating whether and how to compare arguments.
#' If \code{eval} is \code{NA}, student and solution argument are not
#' compared. If \code{eval} is \code{FALSE}, the string versions of the
#' arguments are compared. If \code{eval} is \code{TRUE}, the argument in the
#' student code is evaluated in the student environment and the argument in
#' the solution code is evaluated in the solution environment, and their
#' results are compared. Setting this to \code{FALSE} can be useful, e.g., to
#' check whether the student supplied a large predefined object, or when
#' you're in a sub-SCT where the environments are not unambiguously available.
#' @param eq_condition character vector indicating how to perform the
#' comparison for each argument. See \code{\link{is_equal}}.
#' @param eq_fun optional argument to specify a custom equality function. The
#' function should take two arguments and always return a single boolean
#' value: \code{TRUE} or \code{FALSE}.
#' @param not_called_msg custom feedback message in case the student did not
#' call the function often enough.
#' @param incorrect_msg custom feedback message in case the student did not call
#' the function with the same argument values as in the sample solution. You
#' can specify a vector of arguments with the same length as \code{args}, to
#' have argument-specific custom feedback.
#' @param append Whether or not to append the feedback to feedback built in
#' previous states
#' @param ... S3 stuff
#' @param arg_not_specified_msg custom message in case argument was not
#' specified (for \code{check_arg})
#' @param arg name or position of argument to specify
#' ... Arguments can be accessed using '..<INDEX>' (see example 5) (for \code{check_arg})
#'
#' @examples
#' \dontrun{
#' # Example 1
#' mean(1:3)
#'
#' # SCT
#' ex() %>% check_function("mean") %>% check_arg("x") %>% check_equal()
#'
#' # Example 2
#' mean(c(NA, 1, 2), na.rm = TRUE)
#'
#' # SCT
#' ex() %>% check_function("mean") %>% {
#' check_arg(., "x") %>% check_equal()
#' check_arg(., "na.rm") %>% check_equal()
#' }
#'
#' # Example 3
#' 5 + 4
#'
#' # SCT
#' ex() %>% check_operator("+") %>% check_result() %>% check_equal()
#'
#' # Example 4: Positional argument check
#' cor(rnorm(10), rnorm(10))
#'
#' # SCT
#' ex() %>% check_function("cor") %>% {
#' check_arg(., 1) %>% check_equal()
#' check_arg(., 2) %>% check_equal()
#' }
#'
#' # Example 5: ... in check_args
#'
#' soln <- "std_dev <- purrr::compose(sqrt, var, .dir='forward')"
#' state <- setup_state(soln, soln)
#' state %>% check_function(., "compose") %>% {
#' check_arg(., '..1') %>% check_equal() # sqrt
#' check_arg(., '..2') %>% check_equal() # var
#' check_arg(., '.dir') %>% check_equal()
#' }
#'
#' }
#' @name check_function
#' @rdname check_function
#' @export
check_function <- function(state, name, index = 1, not_called_msg = NULL, append = TRUE) {
assert_state(state)
state$assert_is_not("ObjectState", "check_object")
check_fun_op_helper(state, name = name, index = index, not_called_msg = not_called_msg, append = append, type = "function")
}
#' @rdname check_function
#' @export
check_operator <- function(state, name, index = 1, append = TRUE, not_called_msg = NULL) {
assert_state(state)
state$assert_is_not("ObjectState", "check_object")
check_fun_op_helper(state, name = name, index = index, not_called_msg = not_called_msg, append = append, type = "operator")
}
check_fun_op_helper <- function(state, name, index, not_called_msg, append, type = c("function", "operator")) {
type <- match.arg(type)
finder <- switch(type, `function` = find_function_calls, operator = find_operators)
CallState <- switch(type, `function` = FunctionState, operator = OperationState)
call_state <- CallState$new(state)
call_state$add_details(type = type,
case = "called",
name = name,
index = index,
message = not_called_msg,
append = append,
pd = NULL)
student_calls <- finder(pd = state$get("student_pd"),
name = name,
env = state$get("student_env"))
solution_calls <- finder(pd = state$get("solution_pd"),
name = name,
env = state$get("solution_env"))
check_sufficient(solution_calls, index, name)
solution_call <- solution_calls[[index]]
check_that(is_true(length(student_calls) >= index), feedback = call_state$details)
student_call <- student_calls[[index]]
# update the case for future tests
call_state$set_details(case = "correct",
message = NULL)
call_state$set(solution_call = solution_call)
call_state$set(student_call = student_call)
return(call_state)
}
#' @rdname check_function
#' @export
check_arg <- function(state, arg, arg_not_specified_msg = NULL, append = TRUE) {
assert_state(state)
state$assert_is("CallState", "check_function")
solution_call <- state$get("solution_call")
student_call <- state$get("student_call")
arg_state <- ArgumentState$new(state)
arg_state$add_details(type = "argument",
case = "specified",
name = arg,
message = arg_not_specified_msg,
pd = student_call$pd,
append = append)
if(is.numeric(arg)) {
if(!arg %in% seq_along(solution_call$args)) {
msg <- sprintf(
"A numeric 'arg' should be between 1 and the number of arguments (%d). You specified %d.",
length(solution_call$args),
arg
)
stop(msg)
}
arg <- names(solution_call$args)[arg]
}
index = NULL
if (!arg %in% names(solution_call$args)) {
index = as.integer(substr(arg, 3, nchar(arg)))
if (substr(arg, 1, 2) == ".." &
index %in% seq_along(solution_call$args[["..."]])) {
arg <- "..."
} else {
stop(" Make sure that the arguments you specify are actually specified",
" by the corresponding function call in the solution code.")
}
}
# Check if the function is called with the right arg
check_that(is_true(arg %in% names(student_call$args)), feedback = arg_state$details)
if (!is.null(index)) {
check_that(is_true(index %in% seq_along(student_call$args[["..."]])), feedback = arg_state$details)
}
sol_arg = solution_call$args[[arg]]
stu_arg = student_call$args[[arg]]
if (!is.null(index)) {
sol_arg = sol_arg[[index]]
stu_arg = stu_arg[[index]]
}
arg_state$set(solution_arg = sol_arg)
arg_state$set(solution_pd = sol_arg$pd)
arg_state$set(solution_code = deparse(sol_arg$expr))
arg_state$set(student_arg = stu_arg)
arg_state$set(student_pd = stu_arg$pd)
arg_state$set(student_code = deparse(stu_arg$expr))
arg_state$set_details(case = "correct",
message = NULL)
return(arg_state)
}
#' @rdname check_function
#' @export
check_equal.ArgumentState <- function(state, incorrect_msg = NULL, eval = TRUE, eq_condition = "equivalent", eq_fun = NULL, append = TRUE, ...) {
assert_state(state)
solution_arg <- state$get("solution_arg")
student_arg <- state$get("student_arg")
state$add_details(type = "argument",
case = "equal",
eval = eval,
eq_condition = eq_condition,
message = incorrect_msg,
pd = student_arg$pd,
append = append)
# Evaluate the solution argument and see if no error
solution_obj <- eval_argument(solution_arg,
eval = eval,
env = state$get("solution_env"))
if (isTRUE(try(all.equal(solution_obj, tryerrorstring), silent = TRUE))) {
stop("check_equal() found an argument that causes an error when evaluated.")
}
if (is.null(eq_fun)) {
eq_fun <- function(x, y) is_equal(x, y, eq_condition)
}
# Evaluate the student argument
student_obj <- eval_argument(student_arg,
eval = eval,
env = state$get("student_env"))
state$set_details(student = student_obj,
solution = solution_obj,
is_dots = is_dots(student_arg))
check_that(is_true(eq_fun(student_obj, solution_obj)), feedback = state$details)
return(state)
}
tryerrorstring <- "try-error-in-evaluation"
eval_argument <- function(arg, eval, env) {
if (is_dots(arg)) {
return(lapply(arg, eval_argument, eval, env))
}
if (eval) {
obj <- try(eval(arg$expr, envir = env), silent = TRUE)
if (inherits(obj, "try-error")) {
obj <- tryerrorstring
}
} else {
obj <- stringify(arg$expr)
}
return(obj)
}
is_dots <- function(arg) {
is.list(arg) && ! "expr" %in% names(arg)
}
stringify <- function(arg) {
x <- deparse(arg)
x <- gsub("\\s|;", "", x)
x <- gsub("'", "\"", x)
x <- gsub("FALSE", "F", x)
x <- gsub("TRUE", "T", x)
return(x)
}
## Deprecated functions
test_function <- function(name,
args = NULL,
index = 1,
eval = TRUE,
eq_condition = "equivalent",
not_called_msg = NULL,
args_not_specified_msg = NULL,
incorrect_msg = NULL) {
fail_if_v2_only()
n_args <- length(args)
if (!is.null(args_not_specified_msg) && length(args_not_specified_msg) < n_args) {
args_not_specified_msg <- rep(args_not_specified_msg[1], n_args)
}
if (!is.null(incorrect_msg) && length(incorrect_msg) < n_args) {
incorrect_msg <- rep(incorrect_msg[1], n_args)
}
eval <- rep(eval, length.out = n_args)
eq_condition <- rep(eq_condition, length.out = n_args)
fun_state <- check_function(ex(), name, index = index,
not_called_msg = not_called_msg,
append = is.null(not_called_msg))
for (i in seq_along(args)) {
arg_state <- check_arg(fun_state,
arg = args[i],
arg_not_specified_msg = args_not_specified_msg[i],
append = is.null(args_not_specified_msg))
if (!is.na(eval[i])) {
check_equal(arg_state,
incorrect_msg = incorrect_msg[i],
eval = eval[i],
eq_condition = eq_condition[i],
append = is.null(incorrect_msg[i]))
}
}
}
test_function_v2 <- test_function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.