R/expect-condition.R

In r-lib/testthat: Unit Testing for R

#' Does code throw an error, warning, message, or other condition?
#'
#' @description
#' `expect_error()`, `expect_warning()`, `expect_message()`, and
#' `expect_condition()` check that code throws an error, warning, message,
#' or condition with a message that matches `regexp`, or a class that inherits
#' from `class`. See below for more details.
#'
#' In the 3rd edition, these functions match (at most) a single condition. All
#' additional and non-matching (if `regexp` or `class` are used) conditions
#' will bubble up outside the expectation. If these additional conditions
#' are important you'll need to catch them with additional
#' `expect_message()`/`expect_warning()` calls; if they're unimportant you
#' can ignore with [suppressMessages()]/[suppressWarnings()].
#'
#' It can be tricky to test for a combination of different conditions,
#' such as a message followed by an error. [expect_snapshot()] is
#' often an easier alternative for these more complex cases.
#'
#' @section Testing `message` vs `class`:
#' When checking that code generates an error, it's important to check that the
#' error is the one you expect. There are two ways to do this. The first
#' way is the simplest: you just provide a `regexp` that match some fragment
#' of the error message. This is easy, but fragile, because the test will
#' fail if the error message changes (even if its the same error).
#'
#' A more robust way is to test for the class of the error, if it has one.
#' You can learn more about custom conditions at
#' <https://adv-r.hadley.nz/conditions.html#custom-conditions>, but in
#' short, errors are S3 classes and you can generate a custom class and check
#' for it using `class` instead of `regexp`.
#'
#' If you are using `expect_error()` to check that an error message is
#' formatted in such a way that it makes sense to a human, we recommend
#' using [expect_snapshot()] instead.
#'
#' @export
#' @family expectations
#' @inheritParams expect_that
#' @param regexp Regular expression to test against.
#'   * A character vector giving a regular expression that must match the
#'     error message.
#'   * If `NULL`, the default, asserts that there should be an error,
#'     but doesn't test for a specific value.
#'   * If `NA`, asserts that there should be no errors, but we now recommend
#'     using [expect_no_error()] and friends instead.
#'
#'   Note that you should only use `message` with errors/warnings/messages
#'   that you generate. Avoid tests that rely on the specific text generated by
#'   another package since this can easily change. If you do need to test text
#'   generated by another package, either protect the test with `skip_on_cran()`
#'   or use `expect_snapshot()`.
#' @inheritDotParams expect_match -object -regexp -info -label -all
#' @param class Instead of supplying a regular expression, you can also supply
#'   a class name. This is useful for "classed" conditions.
#' @param inherit Whether to match `regexp` and `class` across the
#'   ancestry of chained errors.
#' @param all *DEPRECATED* If you need to test multiple warnings/messages
#'   you now need to use multiple calls to `expect_message()`/
#'   `expect_warning()`
#' @seealso [expect_no_error()], `expect_no_warning()`,
#'   `expect_no_message()`, and `expect_no_condition()` to assert
#'   that code runs without errors/warnings/messages/conditions.
#' @return If `regexp = NA`, the value of the first argument; otherwise
#'   the captured condition.
#' @examples
#' # Errors ------------------------------------------------------------------
#' f <- function() stop("My error!")
#' expect_error(f())
#' expect_error(f(), "My error!")
#'
#' # You can use the arguments of grepl to control the matching
#' expect_error(f(), "my error!", ignore.case = TRUE)
#'
#' # Note that `expect_error()` returns the error object so you can test
#' # its components if needed
#' err <- expect_error(rlang::abort("a", n = 10))
#' expect_equal(err$n, 10)
#'
#' # Warnings ------------------------------------------------------------------
#' f <- function(x) {
#'   if (x < 0) {
#'     warning("*x* is already negative")
#'     return(x)
#'   }
#'   -x
#' }
#' expect_warning(f(-1))
#' expect_warning(f(-1), "already negative")
#' expect_warning(f(1), NA)
#'
#' # To test message and output, store results to a variable
#' expect_warning(out <- f(-1), "already negative")
#' expect_equal(out, -1)
#'
#' # Messages ------------------------------------------------------------------
#' f <- function(x) {
#'   if (x < 0) {
#'     message("*x* is already negative")
#'     return(x)
#'   }
#'
#'   -x
#' }
#' expect_message(f(-1))
#' expect_message(f(-1), "already negative")
#' expect_message(f(1), NA)
expect_error <- function(object,
                         regexp = NULL,
                         class = NULL,
                         ...,
                         inherit = TRUE,
                         info = NULL,
                         label = NULL) {

  if (edition_get() >= 3) {
    expect_condition_matching("error", {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label
    )
  } else {
    act <- quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
    msg <- compare_condition_2e(
      act$cap,
      act$lab,
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit
    )

    # Access error fields with `[[` rather than `$` because the
    # `$.Throwable` from the rJava package throws with unknown fields
    expect(is.null(msg), msg, info = info, trace = act$cap[["trace"]])
    invisible(act$val %||% act$cap)
  }
}


#' @export
#' @rdname expect_error
expect_warning <- function(object,
                           regexp = NULL,
                           class = NULL,
                           ...,
                           inherit = TRUE,
                           all = FALSE,
                           info = NULL,
                           label = NULL) {

  if (edition_get() >= 3) {
    if (!missing(all)) {
      warn("The `all` argument is deprecated")
    }

    expect_condition_matching("warning", {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label,
      trace_env = caller_env()
    )
  } else {
    act <- quasi_capture(enquo(object), label, capture_warnings, ignore_deprecation = identical(regexp, NA))
    msg <- compare_messages(
      act$cap, act$lab, regexp = regexp, all = all, ...,
      cond_type = "warnings"
    )
    expect(is.null(msg), msg, info = info)

    invisible(act$val)
  }
}

#' @export
#' @rdname expect_error
expect_message <- function(object,
                           regexp = NULL,
                           class = NULL,
                           ...,
                           inherit = TRUE,
                           all = FALSE,
                           info = NULL,
                           label = NULL) {

  if (edition_get() >= 3) {
    expect_condition_matching("message", {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label,
      trace_env = caller_env()
    )
  } else {
    act <- quasi_capture(enquo(object), label, capture_messages)
    msg <- compare_messages(act$cap, act$lab, regexp = regexp, all = all, ...)
    expect(is.null(msg), msg, info = info)

    invisible(act$val)
  }
}

#' @export
#' @rdname expect_error
expect_condition <- function(object,
                             regexp = NULL,
                             class = NULL,
                             ...,
                             inherit = TRUE,
                             info = NULL,
                             label = NULL) {

  if (edition_get() >= 3) {
    expect_condition_matching("condition", {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label,
      trace_env = caller_env()
    )
  } else {

    act <- quasi_capture(enquo(object), label, capture_condition, entrace = TRUE)
    msg <- compare_condition_2e(
      act$cap,
      act$lab,
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      cond_type = "condition"
    )
    expect(is.null(msg), msg, info = info, trace = act$cap[["trace"]])

    invisible(act$val %||% act$cap)
  }
}

expect_condition_matching <- function(base_class,
                                      object,
                                      regexp = NULL,
                                      class = NULL,
                                      ...,
                                      inherit = TRUE,
                                      info = NULL,
                                      label = NULL,
                                      trace_env = caller_env(),
                                      error_call = caller_env()) {
  check_dots_used(error = function(cnd) {
    warn(conditionMessage(cnd), call = error_call)
  })

  matcher <- cnd_matcher(
    base_class,
    class,
    regexp,
    ...,
    inherit = inherit,
    ignore_deprecation = base_class == "warning" && identical(regexp, NA),
    error_call = trace_env
  )

  act <- quasi_capture(
    enquo(object),
    label,
    capture_matching_condition,
    matches = matcher
  )

  expected <- !identical(regexp, NA)
  msg <- compare_condition_3e(base_class, act$cap, act$lab, expected)

  # Access error fields with `[[` rather than `$` because the
  # `$.Throwable` from the rJava package throws with unknown fields
  expect(is.null(msg), msg, info = info, trace = act$cap[["trace"]], trace_env = trace_env)

  # If a condition was expected, return it. Otherwise return the value
  # of the expression.
  invisible(if (expected) act$cap else act$val)
}

# -------------------------------------------------------------------------

cnd_matcher <- function(base_class,
                        class = NULL,
                        pattern = NULL,
                        ...,
                        inherit = TRUE,
                        ignore_deprecation = FALSE,
                        error_call = caller_env()) {
  check_string(class, allow_null = TRUE, call = error_call)
  check_string(pattern, allow_null = TRUE, allow_na = TRUE, call = error_call)

  function(cnd) {
    if (!inherit) {
      cnd$parent <- NULL
    }

    if (ignore_deprecation && is_deprecation(cnd)) {
      return(FALSE)
    }

    matcher <- function(x) {
      if (!inherits(x, base_class)) {
        return(FALSE)
      }
      if (!is.null(class) && !inherits(x, class)) {
        return(FALSE)
      }
      if (!is.null(pattern) && !isNA(pattern)) {
        grepl(pattern, conditionMessage(x), ...)
      } else {
        TRUE
      }
    }
    cnd_some(cnd, matcher)
  }
}

has_classes <- function(x, classes) {
  all(classes %in% class(x))
}

is_deprecation <- function(x) {
  inherits(x, "lifecycle_warning_deprecated")
}

cnd_some <- function(.cnd, .p, ...) {
  .p <- as_function(.p)

  while (is_condition(.cnd)) {
    if (.p(.cnd, ...)) {
      return(TRUE)
    }

    .cnd <- .cnd$parent
  }

  FALSE
}

capture_matching_condition <- function(expr, matches) {
  matched <- NULL
  tl <- current_env()

  withCallingHandlers(expr, condition = function(cnd) {
    if (!is.null(matched) || !matches(cnd)) {
      return()
    }

    if (can_entrace(cnd)) {
      cnd <- cnd_entrace(cnd)
    }
    matched <<- cnd

    if (inherits(cnd, "message") || inherits(cnd, "warning")) {
      cnd_muffle(cnd)
    } else if (inherits(cnd, "error") || inherits(cnd, "skip")) {
      return_from(tl, cnd)
    }
  })

  matched
}

# Helpers -----------------------------------------------------------------

compare_condition_3e <- function(cond_type, cond, lab, expected) {
  if (expected) {
    if (is.null(cond)) {
      sprintf("%s did not throw the expected %s.", lab, cond_type)
    } else {
      NULL
    }
  } else {
    if (!is.null(cond)) {
      sprintf(
        "%s threw an unexpected %s.\nMessage: %s\nClass:   %s",
        lab,
        cond_type,
        cnd_message(cond),
        paste(class(cond), collapse = "/")
      )
    } else {
      NULL
    }
  }
}

compare_condition_2e <- function(cond,
                                 lab,
                                 regexp = NULL,
                                 class = NULL,
                                 ...,
                                 inherit = TRUE,
                                 cond_type = "error") {

  # Expecting no condition
  if (identical(regexp, NA)) {
    if (!is.null(cond)) {
      return(sprintf(
        "%s threw an %s.\nMessage: %s\nClass:   %s",
        lab,
        cond_type,
        cnd_message(cond),
        paste(class(cond), collapse = "/")
      ))
    } else {
      return()
    }
  }

  # Otherwise we're definitely expecting a condition
  if (is.null(cond)) {
    return(sprintf("%s did not throw an %s.", lab, cond_type))
  }

  matches <- cnd_matches_2e(cond, class, regexp, inherit, ...)
  ok_class <- matches[["class"]]
  ok_msg <- matches[["msg"]]

  # All good
  if (ok_msg && ok_class) {
    return()
  }

  problems <- c(if (!ok_class) "class", if (!ok_msg) "message")
  message <- cnd_message(cond)

  details <- c(
    if (!ok_class) {
      sprintf(
        "Expected class: %s\nActual class:   %s\nMessage:        %s",
        paste0(class, collapse = "/"),
        paste0(class(cond), collapse = "/"),
        message
      )
    },
    if (!ok_msg) {
      sprintf(
        "Expected match: %s\nActual message: %s",
        encodeString(regexp, quote = '"'),
        encodeString(message, quote = '"')
      )
    }
  )

  sprintf(
    "%s threw an %s with unexpected %s.\n%s",
    lab,
    cond_type,
    paste(problems, collapse = " and "),
    paste(details, collapse = "\n")
  )
}

cnd_matches_2e <- function(cnd, class, regexp, inherit, ...) {
  if (!inherit) {
    cnd$parent <- NULL
  }

  ok_class <- is.null(class) || cnd_inherits(cnd, class)
  ok_msg <- is.null(regexp) || cnd_some(cnd, function(x) {
    any(grepl(regexp, cnd_message(x), ...))
  })

  c(class = ok_class, msg = ok_msg)
}


compare_messages <- function(messages,
                             lab,
                             regexp = NA, ...,
                             all = FALSE,
                             cond_type = "messages") {
  bullets <- paste0("* ", messages, collapse = "\n")
  # Expecting no messages
  if (identical(regexp, NA)) {
    if (length(messages) > 0) {
      return(sprintf("%s generated %s:\n%s", lab, cond_type, bullets))
    } else {
      return()
    }
  }

  # Otherwise we're definitely expecting messages
  if (length(messages) == 0) {
    return(sprintf("%s did not produce any %s.", lab, cond_type))
  }

  if (is.null(regexp)) {
    return()
  }

  matched <- grepl(regexp, messages, ...)

  # all/any ok
  if ((all && all(matched)) || (!all && any(matched))) {
    return()
  }

  sprintf(
    "%s produced unexpected %s.\n%s\n%s",
    lab,
    cond_type,
    paste0("Expected match: ", encodeString(regexp)),
    paste0("Actual values:\n", bullets)
  )
}

# Disable rlang backtrace reminders so they don't interfere with
# expected error messages
cnd_message <- function(x) {
  withr::local_options(rlang_backtrace_on_error = "none")
  conditionMessage(x)
}