Permalink
Fetching contributors…
Cannot retrieve contributors at this time
204 lines (181 sloc) 6.08 KB
#' Create a test.
#'
#' A test encapsulates a series of expectations about small, self-contained
#' set of functionality. Each test is contained in a \link{context} and
#' contains multiple expectations.
#'
#' Tests are evaluated in their own environments, and should not affect
#' global state.
#'
#' When run from the command line, tests return `NULL` if all
#' expectations are met, otherwise it raises an error.
#'
#' @param desc test name. Names should be kept as brief as possible, as they
#' are often used as line prefixes.
#' @param code test code containing expectations
#' @export
#' @examples
#' test_that("trigonometric functions match identities", {
#' expect_equal(sin(pi / 4), 1 / sqrt(2))
#' expect_equal(cos(pi / 4), 1 / sqrt(2))
#' expect_equal(tan(pi / 4), 1)
#' })
#' # Failing test:
#' \dontrun{
#' test_that("trigonometric functions match identities", {
#' expect_equal(sin(pi / 4), 1)
#' })
#' }
test_that <- function(desc, code) {
code <- substitute(code)
test_code(desc, code, env = parent.frame())
}
test_code <- function(test, code, env = test_env(), skip_on_empty = TRUE) {
if (!is.null(test)) {
get_reporter()$start_test(context = get_reporter()$.context, test = test)
on.exit(get_reporter()$end_test(context = get_reporter()$.context, test = test))
}
ok <- TRUE
register_expectation <- function(e) {
calls <- e$expectation_calls
srcref <- find_first_srcref(calls)
e <- as.expectation(e, srcref = srcref)
e$call <- calls
e$start_frame <- attr(calls, "start_frame")
e$end_frame <- e$start_frame + length(calls) - 1L
e$test <- test %||% "(unknown)"
ok <<- ok && expectation_ok(e)
get_reporter()$add_result(context = get_reporter()$.context, test = test, result = e)
}
frame <- sys.nframe()
frame_calls <- function(start_offset, end_offset, start_frame = frame) {
sys_calls <- sys.calls()
start_frame <- start_frame + start_offset
structure(
sys_calls[(start_frame):(length(sys_calls) - end_offset - 1)],
start_frame = start_frame
)
}
# Any error will be assigned to this variable first
# In case of stack overflow, no further processing (not even a call to
# signalCondition() ) might be possible
test_error <- NULL
expressions_opt <- getOption("expressions")
expressions_opt_new <- min(expressions_opt + 500L, 500000L)
# If no handlers are called we skip: BDD (`describe()`) tests are often
# nested and the top level might not contain any expectations, so we need
# some way to disable
handled <- !skip_on_empty
handle_error <- function(e) {
handled <<- TRUE
# First thing: Collect test error
test_error <<- e
# Increase option(expressions) to handle errors here if possible, even in
# case of a stack overflow. This is important for the DebugReporter.
# Call options() manually, avoid withr overhead.
options(expressions = expressions_opt_new)
on.exit(options(expressions = expressions_opt), add = TRUE)
# Capture call stack, removing last calls from end (added by
# withCallingHandlers), and first calls from start (added by
# tryCatch etc).
e$expectation_calls <- frame_calls(11, 2)
test_error <<- e
# Error will be handled by handle_fatal() if this fails; need to do it here
# to be able to debug with the DebugReporter
register_expectation(e)
e$handled <- TRUE
test_error <<- e
}
handle_fatal <- function(e) {
handled <<- TRUE
# Error caught in handle_error() has precedence
if (!is.null(test_error)) {
e <- test_error
if (isTRUE(e$handled)) {
return()
}
}
if (is.null(e$expectation_calls)) {
e$expectation_calls <- frame_calls(0, 0)
}
register_expectation(e)
}
handle_expectation <- function(e) {
handled <<- TRUE
e$expectation_calls <- frame_calls(11, 6)
register_expectation(e)
invokeRestart("continue_test")
}
handle_warning <- function(e) {
# When options(warn) >= 2, a warning will be converted to an error.
# So, do not handle it here so that it will be handled by handle_error.
if (getOption("warn") >= 2) return()
handled <<- TRUE
e$expectation_calls <- frame_calls(11, 5)
register_expectation(e)
invokeRestart("muffleWarning")
}
handle_message <- function(e) {
handled <<- TRUE
invokeRestart("muffleMessage")
}
handle_skip <- function(e) {
handled <<- TRUE
if (inherits(e, "skip_empty")) {
# Need to generate call as if from test_that
e$expectation_calls <- frame_calls(0, 12, frame - 1)
} else {
e$expectation_calls <- frame_calls(11, 2)
}
register_expectation(e)
signalCondition(e)
}
test_env <- new.env(parent = env)
tryCatch(
withCallingHandlers(
{
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
},
expectation = handle_expectation,
skip = handle_skip,
warning = handle_warning,
message = handle_message,
error = handle_error
),
# some errors may need handling here, e.g., stack overflow
error = handle_fatal,
# skip silently terminate code
skip = function(e) {}
)
invisible(ok)
}
#' R package to make testing fun!
#'
#' Try the example below. Have a look at the references and learn more
#' from function documentation such as [expect_that()].
#'
#' @section Options:
#' - `testthat.use_colours`: Should the output be coloured? (Default: `TRUE`).
#' - `testthat.summary.max_reports`: The maximum number of detailed test
#' reports printed for the summary reporter (default: 10).
#' - `testthat.summary.omit_dots`: Omit progress dots in the summary reporter
#' (default: `FALSE`).
#'
#' @import rlang
#' @keywords internal
#' @useDynLib testthat, .registration = TRUE
#' @references Wickham, H (2011). testthat: Get Started with Testing.
#' \strong{The R Journal} \emph{3/1} 5-10.
#' \url{https://journal.r-project.org/archive/2011-1/RJournal_2011-1_Wickham.pdf}
#'
#' \url{http://adv-r.had.co.nz/Testing.html}
#'
#' @examples
#' library(testthat)
#' a <- 9
#' expect_that(a, is_less_than(10))
#' expect_lt(a, 10)
"_PACKAGE"