R/utils_assert.R

Defines functions tar_assert_watch_packages tar_assert_unique_targets tar_assert_unique tar_assert_true tar_assert_script tar_assert_target_list tar_assert_target tar_assert_store tar_assert_scalar tar_assert_resources tar_assert_positive tar_assert_nonmissing tar_assert_match tar_assert_path tar_assert_package tar_assert_nzchar tar_assert_not_expr tar_assert_none_na tar_assert_nonempty tar_assert_names tar_assert_name tar_assert_lgl tar_assert_list tar_assert_le tar_assert_lang tar_assert_internet tar_assert_int tar_assert_inherits tar_assert_not_in tar_assert_not_dir tar_assert_not_dirs tar_assert_in tar_assert_identical_chr tar_assert_identical tar_assert_ge tar_assert_function tar_assert_format tar_assert_flag tar_assert_expr tar_assert_envir tar_assert_equal_lengths tar_assert_df tar_assert_dbl tar_assert_target_dag tar_assert_correct_fields tar_assert_chr_no_delim tar_assert_chr tar_assert_callr_function

Documented in tar_assert_chr tar_assert_dbl tar_assert_df tar_assert_envir tar_assert_equal_lengths tar_assert_expr tar_assert_flag tar_assert_function tar_assert_ge tar_assert_identical tar_assert_in tar_assert_inherits tar_assert_int tar_assert_internet tar_assert_lang tar_assert_le tar_assert_lgl tar_assert_list tar_assert_match tar_assert_name tar_assert_names tar_assert_nonempty tar_assert_nonmissing tar_assert_not_dir tar_assert_not_dirs tar_assert_not_expr tar_assert_not_in tar_assert_nzchar tar_assert_package tar_assert_path tar_assert_positive tar_assert_scalar tar_assert_target tar_assert_target_list tar_assert_true tar_assert_unique tar_assert_unique_targets

#' @title Assertions
#' @name tar_assert
#' @family utilities to extend targets
#' @description These functions assert the correctness of user inputs
#'   and generate custom error conditions as needed. Useful
#'   for writing packages built on top of `targets`.
#' @param x R object, input to be validated. The kind of object depends on the
#'   specific assertion function called.
#' @param msg Character of length 1, a message to be printed to the console
#'   if `x` is invalid.
#' @param choices Character vector of choices of `x` for certain assertions.
#' @param threshold Numeric of length 1, lower/upper bound for
#'   assertions like `tar_assert_le()`/`tar_assert_ge()`.
#' @param y R object, value to compare against `x`.
#' @param class Character vector of expected class names.
#' @param package Character of length 1, name of an R package.
#' @param path Character, file path.
#' @param pattern Character of length 1, a `grep` pattern for certain
#'   assertions.
#' @examples
#' tar_assert_chr("123")
#' try(tar_assert_chr(123))
NULL

tar_assert_callr_function <- function(callr_function) {
  if (!is.null(callr_function)) {
    tar_assert_function(
      callr_function,
      "callr_function must be a function or NULL."
    )
  }
}

#' @export
#' @rdname tar_assert
tar_assert_chr <- function(x, msg = NULL) {
  if (!is.character(x)) {
    default <- paste(deparse(substitute(x)), "must be a character.")
    tar_throw_validate(msg %|||% default)
  }
}

tar_assert_chr_no_delim <- function(x, msg = NULL) {
  tar_assert_chr(x, paste(deparse(substitute(x)), "must be a character"))
  if (any(grepl("|", x, fixed = TRUE) | grepl("*", x, fixed = TRUE))) {
    default <- paste(deparse(substitute(x)), "must not contain | or *")
    tar_throw_validate(msg %|||% default)
  }
}

tar_assert_correct_fields <- function(object, constructor) {
  tar_assert_identical_chr(
    sort(names(object)),
    sort(names(formals(constructor)))
  )
}

tar_assert_target_dag <- function(x, msg = NULL) {
  if (!inherits(x, "igraph") || !igraph::is_dag(x)) {
    default <- paste(
      "dependency graph contains a cycle.",
      "If target x depends on target y, then",
      "target y must not depend on target x,",
      "either directly or indirectly."
    )
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_dbl <- function(x, msg = NULL) {
  if (!is.numeric(x)) {
    default <- paste(deparse(substitute(x)), "must be numeric.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_df <- function(x, msg = NULL) {
  if (!is.data.frame(x)) {
    default <- paste(deparse(substitute(x)), "must be a data frame.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_equal_lengths <- function(x, msg = NULL) {
  lengths <- map_int(x, length)
  if (length(unique(lengths)) > 1L) {
    targets::tar_throw_validate(msg %|||% "x must have equal-length elements.")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_envir <- function(x, msg = NULL) {
  if (!is.environment(x)) {
    default <- paste(deparse(substitute(x)), "must be an environment.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_expr <- function(x, msg = NULL) {
  if (!is.expression(x)) {
    default <- paste(deparse(substitute(x)), "must be an expression.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_flag <- function(x, choices, msg = NULL) {
  tar_assert_chr(
    x,
    msg %|||% paste(deparse(substitute(x)), "must be a character")
  )
  tar_assert_scalar(
    x,
    msg %|||% paste(deparse(substitute(x)), "must have length 1")
  )
  if (!all(x %in% choices)) {
    msg <- msg %|||% paste(
      deparse(substitute(x)),
      "equals",
      deparse(x),
      "but must be in",
      deparse(choices)
    )
    tar_throw_validate(msg)
  }
}

tar_assert_format <- function(format) {
  tar_assert_scalar(format)
  tar_assert_chr(format)
  store_assert_format_setting(as_class(format))
}

#' @export
#' @rdname tar_assert
tar_assert_function <- function(x, msg = NULL) {
  if (!is.function(x)) {
    tar_throw_validate(msg %|||% "input must be a function.")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_ge <- function(x, threshold, msg = NULL) {
  if (any(x < threshold)) {
    default <- paste(
      deparse(substitute(x)),
      "must be less than or equal to",
      threshold
    )
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_identical <- function(x, y, msg = NULL) {
  if (!identical(x, y)) {
    default <- paste(
      deparse(substitute(x)),
      "and",
      deparse(substitute(y)),
      "must be identical."
    )
    tar_throw_validate(msg %|||% default)
  }
}

tar_assert_identical_chr <- function(x, y, msg = NULL) {
  if (!identical(x, y)) {
    msg_x <- paste0(deparse(x), collapse = "")
    msg_y <- paste0(deparse(y), collapse = "")
    tar_throw_validate(msg %|||% paste(msg_x, "and", msg_y, "not identical."))
  }
}

#' @export
#' @rdname tar_assert
tar_assert_in <- function(x, choices, msg = NULL) {
  if (!all(x %in% choices)) {
    msg <- msg %|||% paste(
      deparse(substitute(x)),
      "equals",
      deparse(x),
      "but must be in",
      deparse(choices)
    )
    tar_throw_validate(msg)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_not_dirs <- function(x, msg = NULL) {
  lapply(x, tar_assert_not_dir, msg = msg)
}

#' @export
#' @rdname tar_assert
tar_assert_not_dir <- function(x, msg = NULL) {
  if (dir.exists(x)) {
    tar_throw_validate(msg %|||% paste(deparse(x), "must not be a directory."))
  }
}

#' @export
#' @rdname tar_assert
tar_assert_not_in <- function(x, choices, msg = NULL) {
  if (any(x %in% choices)) {
    tar_throw_validate(msg %|||% paste(deparse(x), "is in", deparse(choices)))
  }
}

#' @export
#' @rdname tar_assert
tar_assert_inherits <- function(x, class, msg = NULL) {
  if (!inherits(x, class)) {
    default <- paste(deparse(substitute(x)), "x does not inherit from", class)
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_int <- function(x, msg = NULL) {
  if (!is.integer(x)) {
    default <- paste(deparse(substitute(x)), "must have mode integer.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_internet <- function(msg = NULL) {
  tar_assert_package("curl")
  if (!curl::has_internet()) {
    # This line cannot be covered in automated tests
    # because internet is usually on.
    tar_throw_run("no internet") # nocov
  }
}

#' @export
#' @rdname tar_assert
tar_assert_lang <- function(x, msg = NULL) {
  if (!is.language(x)) {
    tar_throw_validate(msg %|||% "x must be a language object")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_le <- function(x, threshold, msg = NULL) {
  if (any(x > threshold)) {
    default <- paste(
      deparse(substitute(x)),
      "must be less than or equal to",
      threshold
    )
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_list <- function(x, msg = NULL) {
  if (!is.list(x)) {
    default <- paste(deparse(substitute(x)), "must be a list.")
    tar_throw_validate(msg %|||% "x must be a list.")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_lgl <- function(x, msg = NULL) {
  if (!is.logical(x)) {
    default <- paste(deparse(substitute(x)), "must be logical.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_name <- function(x) {
  tar_assert_chr(x)
  tar_assert_scalar(x)
  if (!nzchar(x)) {
    tar_throw_validate("name must be a nonempty string.")
  }
  if (!identical(x, make.names(x))) {
    tar_throw_validate(x, " is not a valid symbol name.")
  }
  if (grepl("\\.$", x)) {
    tar_throw_validate(x, " ends with a dot.")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_names <- function(x, msg = NULL) {
  if (any(x != make.names(x, unique = FALSE))) {
    tar_throw_validate(msg %|||% "x must legal symbol names.")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_nonempty <- function(x, msg = NULL) {
  if (!length(x)) {
    default <- paste(deparse(substitute(x)), "must be nonempty.")
    tar_throw_validate(msg %|||% default)
  }
}

tar_assert_none_na <- function(x, msg = NULL) {
  if (anyNA(x)) {
    default <- paste(deparse(substitute(x)), "must have no missing values.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_not_expr <- function(x, msg = NULL) {
  if (is.expression(x)) {
    tar_throw_validate(msg %|||% "x must not be an expression object")
  }
}

#' @export
#' @rdname tar_assert
tar_assert_nzchar <- function(x, msg = NULL) {
  if (any(!nzchar(x))) {
    default <- paste(deparse(substitute(x)), "has empty character strings.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_package <- function(package) {
  tryCatch(
    rlang::check_installed(package),
    error = function(e) {
      tar_throw_validate(conditionMessage(e))
    }
  )
}

#' @export
#' @rdname tar_assert
tar_assert_path <- function(path, msg = NULL) {
  missing <- !file.exists(path)
  if (any(missing)) {
    tar_throw_validate(
      msg %|||% paste0(
        "missing files: ",
        paste(path[missing], collapse = ", ")
      )
    )
  }
}

#' @export
#' @rdname tar_assert
tar_assert_match <- function(x, pattern, msg = NULL) {
  if (!grepl(pattern = pattern, x = x)) {
    default <- paste(deparse(substitute(x)), "does not match pattern", pattern)
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_nonmissing <- function(x, msg = NULL) {
  if (rlang::is_missing(x)) {
    default <- paste(deparse(substitute(x)), "is missing with no default.")
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_positive <- function(x, msg = NULL) {
  if (any(x <= 0)) {
    default <- paste(deparse(substitute(x)), "is not all positive.")
    tar_throw_validate(msg %|||% default)
  }
}

tar_assert_resources <- function(resources) {
  tar_assert_list(resources, "resources must be list. Use tar_resources().")
  if (length(resources)) {
    tar_assert_nonempty(names(resources), "resources list must have names.")
    tar_assert_nzchar(names(resources), "resources names must be nonempty")
    tar_assert_unique(names(resources), "resources names must be unique.")
  }
  for (name in names(resources)) {
    if (!(name %in% names(formals(tar_resources)))) {
      tar_warn_deprecate(
        "found non-standard resource group ",
        name,
        " in resources list. Unstructrued resources list are deprecated ",
        "in targets >= 0.5.0.9000 (2021-06-07). Use tar_resources() ",
        "and various tar_resources_*() helper functions to create the ",
        "resources argument to tar_target() and tar_option_set()."
      )
    } else if (!inherits(resources[[name]], "tar_resources")) {
      tar_warn_deprecate(
        "found incorrectly formatted resource group ",
        name,
        " in resources list. Unstructrued resources list are deprecated ",
        "in targets >= 0.5.0.9000 (2021-06-07). Use tar_resources_clustermq()",
        " and various other tar_resources_*() helper functions to create ",
        "arguments to tar_resources()."
      )
    }
  }
}

#' @export
#' @rdname tar_assert
tar_assert_scalar <- function(x, msg = NULL) {
  if (length(x) != 1) {
    default <- paste(deparse(substitute(x)), "must have length 1.")
    tar_throw_validate(msg %|||% default)
  }
}

tar_assert_store <- function(store) {
  tar_assert_path(
    store,
    paste(
      "data store path", store, "not found.",
      "utility functions like tar_read() and tar_progress() require a",
      "data store (default: _targets/) produced by tar_make() or similar."
    )
  )
}

#' @export
#' @rdname tar_assert
tar_assert_target <- function(x, msg = NULL) {
  msg <- msg %|||% paste(
    "Found a non-target object. The target script file (default: _targets.R)",
    "must end with a list of tar_target() objects (recommended)",
    "or a tar_pipeline() object (deprecated)."
  )
  tar_assert_inherits(x = x, class = "tar_target", msg = msg)
}

#' @export
#' @rdname tar_assert
tar_assert_target_list <- function(x) {
  msg <- paste(
    "The target script file (default: _targets.R)",
    "must end with a list of tar_target() objects (recommended)",
    "or a tar_pipeline() object (deprecated). Each element of the target list",
    "must be a target object or nested list of target objects."
  )
  tar_assert_list(x, msg = msg)
  map(x, tar_assert_target, msg = msg)
}

tar_assert_script <- function(script) {
  msg <- paste0(
    "could not find file ",
    script,
    ". Main functions like tar_make() require a target script file ",
    "(default: _targets.R) to define the pipeline. ",
    "Functions tar_edit() and tar_script() can help. "
  )
  tar_assert_path(script, msg)
  vars <- all.vars(parse(file = script), functions = TRUE)
  exclude <- c(
    "glimpse",
    "make",
    "manifest",
    "network",
    "outdated",
    "prune",
    "renv",
    "sitrep",
    "validate",
    "visnetwork"
  )
  pattern <- paste(paste0("^tar_", exclude), collapse = "|")
  choices <- grep(pattern, getNamespaceExports("targets"), value = TRUE)
  msg <- paste(
    "The target script file",
    script,
    "must not call tar_make() or similar functions",
    "that would source the target script again and cause infinite recursion."
  )
  tar_assert_not_in(vars, choices, msg)
  msg <- paste(
    "Do not use %s() from {devtools} or {pkgload} to load",
    "packages or custom functions/globals for {targets}. If you do,",
    "custom functions will go to a package environment where {targets}",
    "may not track them, and the loaded data will not be available in",
    "parallel workers created by tar_make_clustermq() or tar_make_future().",
    "Read https://books.ropensci.org/targets/practices.html#loading-and-configuring-r-packages", # nolint
    "and https://books.ropensci.org/targets/practices.html#packages-based-invalidation", # nolint
    "for the correct way to load packages for {targets} pipelines.",
    "Warnings like this one are important, but if you must suppress them, ",
    "you can do so with Sys.setenv(TAR_WARN = \"false\")."
  )
  for (loader in c("load_all", "load_code", "load_data", "load_dll")) {
    if (!identical(Sys.getenv("TAR_WARN"), "false") && loader %in% vars) {
      tar_warn_validate(sprintf(msg, loader))
    }
  }
}

#' @export
#' @rdname tar_assert
tar_assert_true <- function(x, msg = NULL) {
  if (!x) {
    default <- paste(
      deparse(substitute(x)),
      "does not evaluate not TRUE."
    )
    tar_throw_validate(msg %|||% default)
  }
}

#' @export
#' @rdname tar_assert
tar_assert_unique <- function(x, msg = NULL) {
  if (anyDuplicated(x)) {
    dups <- paste(unique(x[duplicated(x)]), collapse = ", ")
    default <- paste(
      deparse(substitute(x)),
      "has duplicated entries:",
      dups
    )
    tar_throw_validate(paste(msg %|||% default))
  }
}

#' @export
#' @rdname tar_assert
tar_assert_unique_targets <- function(x) {
  tar_assert_unique(x, "duplicated target names:")
}

# nocov start
# tested in tests/interactive/test-tar_watch.R
tar_assert_watch_packages <- function() {
  pkgs <- c(
    "bs4Dash",
    "DT",
    "gt",
    "markdown",
    "pingr",
    "shiny",
    "shinybusy",
    "shinyWidgets",
    "visNetwork"
  )
  tar_assert_package(pkgs)
}
# nocov end

Try the targets package in your browser

Any scripts or data that you put into this service are public.

targets documentation built on Sept. 21, 2021, 5:09 p.m.