R/skip.R

In testthat: Unit Testing for R

#' Skip a test for various reasons
#'
#' @description
#' `skip_if()` and `skip_if_not()` allow you to skip tests, immediately
#' concluding a [test_that()] block without executing any further expectations.
#' This allows you to skip a test without failure, if for some reason it
#' can't be run (e.g. it depends on the feature of a specific operating system,
#' or it requires a specific version of a package).
#'
#' See `vignette("skipping")` for more details.
#'
#' @section Helpers:
#'
#' * `skip_if_not_installed("pkg")` skips tests if package "pkg" is not
#'   installed or cannot be loaded (using `requireNamespace()`). Generally,
#'   you can assume that suggested packages are installed, and you do not
#'   need to check for them specifically, unless they are particularly
#'   difficult to install.
#'
#' * `skip_if_offline()` skips if an internet connection is not available
#'   (using [curl::nslookup()]) or if the test is run on CRAN. Requires
#'   \{curl\} to be installed and included in the dependencies of your package.
#'
#' * `skip_if_translated("msg")` skips tests if the "msg" is translated.
#'
#' * `skip_on_bioc()` skips on Bioconductor (using the `IS_BIOC_BUILD_MACHINE`
#'    env var).
#'
#' * `skip_on_cran()` skips on CRAN (using the `NOT_CRAN` env var set by
#'    devtools and friends). `local_on_cran()` gives you the ability to
#'    easily simulate what will happen on CRAN.
#'
#' * `skip_on_covr()` skips when covr is running (using the `R_COVR` env var).
#'
#' * `skip_on_ci()` skips on continuous integration systems like GitHub Actions,
#'    travis, and appveyor (using the `CI` env var).
#'
#' * `skip_on_os()` skips on the specified operating system(s) ("windows",
#'   "mac", "linux", or "solaris").
#'
#' @param message A message describing why the test was skipped.
#' @param host A string with a hostname to lookup
#' @export
#' @examples
#' if (FALSE) skip("Some Important Requirement is not available")
#'
#' test_that("skip example", {
#'   expect_equal(1, 1L)    # this expectation runs
#'   skip('skip')
#'   expect_equal(1, 2)     # this one skipped
#'   expect_equal(1, 3)     # this one is also skipped
#' })
skip <- function(message = "Skipping") {
  message <- paste0(message, collapse = "\n")
  cond <- structure(
    list(message = paste0("Reason: ", message)),
    class = c("skip", "condition")
  )
  stop(cond)
}

# Called automatically if the test contains no expectations
skip_empty <- function() {
  cond <- structure(
    list(message = "Reason: empty test"),
    class = c("skip_empty", "skip", "condition")
  )
  stop(cond)
}

#' @export
#' @rdname skip
#' @param condition Boolean condition to check. `skip_if_not()` will skip if
#'   `FALSE`, `skip_if()` will skip if `TRUE`.
skip_if_not <- function(condition, message = NULL) {
  if (is.null(message)) {
    message <- paste0(deparse1(substitute(condition)), " is not TRUE")
  }
  if (!isTRUE(condition)) {
    skip(message)
  } else {
    invisible()
  }
}

#' @export
#' @rdname skip
skip_if <- function(condition, message = NULL) {
  if (is.null(message)) {
    message <- paste0(deparse1(substitute(condition)), " is TRUE")
  }
  if (isTRUE(condition)) {
    skip(message)
  } else {
    invisible()
  }
}

#' @export
#' @param pkg Name of package to check for
#' @param minimum_version Minimum required version for the package
#' @rdname skip
skip_if_not_installed <- function(pkg, minimum_version = NULL) {
  # most common case: it's not installed
  tryCatch(
    find.package(pkg),
    error = function(e) skip(paste0("{", pkg, "} is not installed"))
  )
  # rarer: it's installed, but fails to load
  if (!requireNamespace(pkg, quietly = TRUE)) {
    skip(paste0("{", pkg, "} cannot be loaded"))
  }

  if (!is.null(minimum_version)) {
    installed_version <- package_version(pkg)
    if (installed_version < minimum_version) {
      skip(paste0(
        "Installed ",
        pkg,
        " is version ",
        installed_version,
        "; ",
        "but ",
        minimum_version,
        " is required"
      ))
    }
  }

  invisible()
}
package_version <- function(x) {
  utils::packageVersion(x)
}

#' @export
#' @param spec A version specification like '>= 4.1.0' denoting that this test
#'   should only be run on R versions 4.1.0 and later.
#' @rdname skip
skip_unless_r <- function(spec) {
  check_string(spec)

  parts <- unlist(strsplit(spec, " ", fixed = TRUE))
  if (length(parts) != 2L) {
    cli::cli_abort(
      "{.arg spec} must be an valid version specification, like {.str >= 4.0.0}, not {.str {spec}}."
    )
  }
  comparator <- match.fun(parts[1L])
  required_version <- numeric_version(parts[2L])

  current_version <- getRversion()
  skip_if_not(
    comparator(current_version, required_version),
    sprintf(
      "Current R version (%s) does not satisfy requirement (%s %s)",
      current_version,
      parts[1L],
      required_version
    )
  )
}
# for mocking
getRversion <- NULL

#' @export
#' @rdname skip
skip_if_offline <- function(host = "captive.apple.com") {
  skip_on_cran()
  check_installed("curl")

  skip_if_not(has_internet(host), "offline")
}
has_internet <- function(host) {
  !is.null(curl::nslookup(host, error = FALSE))
}

#' @export
#' @rdname skip
skip_on_cran <- function() {
  skip_if(on_cran(), "On CRAN")
}

#' @export
#' @rdname skip
#' @param on_cran Pretend we're on CRAN (`TRUE`) or not (`FALSE`).
#' @param frame Calling frame to tie change to; expect use only.
local_on_cran <- function(on_cran = TRUE, frame = caller_env()) {
  check_bool(on_cran)
  withr::local_envvar(NOT_CRAN = tolower(!on_cran), .local_envir = frame)
}

# Assert that we're not on CRAN, but don't override the user's setting
local_assume_not_on_cran <- function(frame = caller_env()) {
  if (Sys.getenv("NOT_CRAN") != "") {
    return()
  }
  withr::local_envvar("NOT_CRAN" = "true", .local_envir = frame)
}

#' @export
#' @param os Character vector of one or more operating systems to skip on.
#'   Supported values are `"windows"`, `"mac"`, `"linux"`, `"solaris"`,
#'   and `"emscripten"`.
#' @param arch Character vector of one or more architectures to skip on.
#'   Common values include `"i386"` (32 bit), `"x86_64"` (64 bit), and
#'   `"aarch64"` (M1 mac). Supplying `arch` makes the test stricter; i.e. both
#'   `os` and `arch` must match in order for the test to be skipped.
#' @rdname skip
skip_on_os <- function(os, arch = NULL) {
  os <- match.arg(
    os,
    choices = c("windows", "mac", "linux", "solaris", "emscripten"),
    several.ok = TRUE
  )

  msg <- switch(
    system_os(),
    windows = if ("windows" %in% os) "On Windows",
    darwin = if ("mac" %in% os) "On Mac",
    linux = if ("linux" %in% os) "On Linux",
    sunos = if ("solaris" %in% os) "On Solaris",
    emscripten = if ("emscripten" %in% os) "On Emscripten"
  )

  if (!is.null(arch) && !is.null(msg)) {
    if (!is.character(arch)) {
      cli::cli_abort("{.arg arch} must be a character vector.")
    }

    if (system_arch() %in% arch) {
      msg <- paste(msg, system_arch())
    } else {
      msg <- NULL
    }
  }

  if (is.null(msg)) {
    invisible(TRUE)
  } else {
    skip(msg)
  }
}

system_os <- function() tolower(Sys.info()[["sysname"]])
system_arch <- function() R.version$arch

#' @export
#' @rdname skip
skip_on_ci <- function() {
  skip_if(on_ci(), "On CI")
}

#' @export
#' @rdname skip
skip_on_covr <- function() {
  skip_if(in_covr(), "On covr")
}

#' @export
#' @rdname skip
skip_on_bioc <- function() {
  skip_if(on_bioc(), "On Bioconductor")
}

#' @export
#' @param msgid R message identifier used to check for translation: the default
#'   uses a message included in most translation packs. See the complete list in
#'   [`R-base.pot`](https://github.com/wch/r-source/blob/master/src/library/base/po/R-base.pot).
#' @rdname skip
skip_if_translated <- function(msgid = "'%s' not found") {
  skip_if(
    gettext(msgid) != msgid,
    paste0("\"", msgid, "\" is translated")
  )
}

gettext <- function(msgid, domain = "R") {
  base::gettext(msgid, domain = domain)
}


#' Superseded skip functions
#'
#' @description
#' `r lifecycle::badge("superseded")`
#'
#' * `skip_on_travis()` and `skip_on_appveyor()` have been superseded by
#'   [skip_on_ci()].
#'
#' @export
#' @keywords internal
skip_on_travis <- function() {
  skip_if(env_var_is_true("TRAVIS"), "On Travis")
}

#' @export
#' @rdname skip_on_travis
skip_on_appveyor <- function() {
  skip_if(env_var_is_true("APPVEYOR"), "On Appveyor")
}

# helpers -----------------------------------------------------------------

on_ci <- function() {
  env_var_is_true("CI")
}
in_covr <- function() {
  env_var_is_true("R_COVR")
}
on_bioc <- function() {
  env_var_is_true("IS_BIOC_BUILD_MACHINE")
}
on_cran <- function() {
  env <- Sys.getenv("NOT_CRAN")
  if (identical(env, "")) {
    !interactive()
  } else {
    !isTRUE(as.logical(env))
  }
}

env_var_is_true <- function(x) {
  isTRUE(as.logical(Sys.getenv(x, "false")))
}

env_var_is_false <- function(x) {
  isFALSE(as.logical(Sys.getenv(x, "true")))
}