R/staticimports.R

In shiny: Web Application Framework for R

# Generated by staticimports; do not edit by hand.
# ======================================================================
# Imported from pkg:staticimports
# ======================================================================

# Given a vector, return TRUE if any elements are named, FALSE otherwise.
# For zero-length vectors, always return FALSE.
any_named <- function(x) {
  if (length(x) == 0) return(FALSE)
  nms <- names(x)
  !is.null(nms) && any(nzchar(nms))
}

# Given a vector, return TRUE if any elements are unnamed, FALSE otherwise.
# For zero-length vectors, always return FALSE.
any_unnamed <- function(x) {
  if (length(x) == 0) return(FALSE)
  nms <- names(x)
  is.null(nms) || !all(nzchar(nms))
}

# Borrowed from pkgload:::dev_meta, with some modifications.
# Returns TRUE if `pkg` was loaded with `devtools::load_all()`.
devtools_loaded <- function(pkg) {
  ns <- .getNamespace(pkg)
  if (is.null(ns) || is.null(ns$.__DEVTOOLS__)) {
    return(FALSE)
  }
  TRUE
}

get_package_version <- function(pkg) {
  # `utils::packageVersion()` can be slow, so first try the fast path of
  # checking if the package is already loaded.
  ns <- .getNamespace(pkg)
  if (is.null(ns)) {
    utils::packageVersion(pkg)
  } else {
    as.package_version(ns$.__NAMESPACE__.$spec[["version"]])
  }
}

is_installed <- function(pkg, version = NULL) {
  installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg))

  if (is.null(version)) {
    return(installed)
  }

  if (!is.character(version) && !inherits(version, "numeric_version")) {
    # Avoid https://bugs.r-project.org/show_bug.cgi?id=18548
    alert <- if (identical(Sys.getenv("TESTTHAT"), "true")) stop else warning
    alert("`version` must be a character string or a `package_version` or `numeric_version` object.")

    version <- numeric_version(sprintf("%0.9g", version))
  }

  installed && isTRUE(get_package_version(pkg) >= version)
}

# Simplified version rlang:::s3_register() that just uses
# warning() instead of rlang::warn() when registration fails
# https://github.com/r-lib/rlang/blob/main/R/compat-s3-register.R
s3_register <- function(generic, class, method = NULL) {
  stopifnot(is.character(generic), length(generic) == 1)
  stopifnot(is.character(class), length(class) == 1)

  pieces <- strsplit(generic, "::")[[1]]
  stopifnot(length(pieces) == 2)
  package <- pieces[[1]]
  generic <- pieces[[2]]

  caller <- parent.frame()

  get_method_env <- function() {
    top <- topenv(caller)
    if (isNamespace(top)) {
      asNamespace(environmentName(top))
    } else {
      caller
    }
  }
  get_method <- function(method, env) {
    if (is.null(method)) {
      get(paste0(generic, ".", class), envir = get_method_env())
    } else {
      method
    }
  }

  register <- function(...) {
    envir <- asNamespace(package)

    # Refresh the method each time, it might have been updated by
    # `devtools::load_all()`
    method_fn <- get_method(method)
    stopifnot(is.function(method_fn))

    # Only register if generic can be accessed
    if (exists(generic, envir)) {
      registerS3method(generic, class, method_fn, envir = envir)
    } else {
      warning(
        "Can't find generic `", generic, "` in package ", package,
        " register S3 method. Do you need to update ", package,
        " to the latest version?", call. = FALSE
      )
    }
  }

  # Always register hook in case package is later unloaded & reloaded
  setHook(packageEvent(package, "onLoad"), function(...) {
    register()
  })

  # Avoid registration failures during loading (pkgload or regular).
  # Check that environment is locked because the registering package
  # might be a dependency of the package that exports the generic. In
  # that case, the exports (and the generic) might not be populated
  # yet (#1225).
  if (isNamespaceLoaded(package) && environmentIsLocked(asNamespace(package))) {
    register()
  }

  invisible()
}

# Borrowed from pkgload::shim_system.file, with some modifications. This behaves
# like `system.file()`, except that (1) for packages loaded with
# `devtools::load_all()`, it will return the path to files in the package's
# inst/ directory, and (2) for other packages, the directory lookup is cached.
# Also, to keep the implementation simple, it doesn't support specification of
# lib.loc or mustWork.
system_file <- function(..., package = "base") {
  if (!devtools_loaded(package))  {
    return(system_file_cached(..., package = package))
  }

  if (!is.null(names(list(...)))) {
    stop("All arguments other than `package` must be unnamed.")
  }

  # If package was loaded with devtools (the package loaded with load_all),
  # also search for files under inst/, and don't cache the results (it seems
  # more likely that the package path will change during the development
  # process)
  pkg_path <- find.package(package)

  # First look in inst/
  files_inst <- file.path(pkg_path, "inst", ...)
  present_inst <- file.exists(files_inst)

  # For any files that weren't present in inst/, look in the base path
  files_top <- file.path(pkg_path, ...)
  present_top <- file.exists(files_top)

  # Merge them together. Here are the different possible conditions, and the
  # desired result. NULL means to drop that element from the result.
  #
  # files_inst:   /inst/A  /inst/B  /inst/C  /inst/D
  # present_inst:    T        T        F        F
  # files_top:      /A       /B       /C       /D
  # present_top:     T        F        T        F
  # result:       /inst/A  /inst/B    /C       NULL
  #
  files <- files_top
  files[present_inst] <- files_inst[present_inst]
  # Drop cases where not present in either location
  files <- files[present_inst | present_top]
  if (length(files) == 0) {
    return("")
  }
  # Make sure backslashes are replaced with slashes on Windows
  normalizePath(files, winslash = "/")
}

# A wrapper for `system.file()`, which caches the package path because
# `system.file()` can be slow. If a package is not installed, the result won't
# be cached.
system_file_cached <- local({
  pkg_dir_cache <- character()

  function(..., package = "base") {
    if (!is.null(names(list(...)))) {
      stop("All arguments other than `package` must be unnamed.")
    }

    not_cached <- is.na(match(package, names(pkg_dir_cache)))
    if (not_cached) {
      pkg_dir <- system.file(package = package)
      if (nzchar(pkg_dir)) {
        pkg_dir_cache[[package]] <<- pkg_dir
      }
    } else {
      pkg_dir <- pkg_dir_cache[[package]]
    }

    file.path(pkg_dir, ...)
  }
})