1# Given the name or vector of names, returns a named vector reporting
2# whether each exists and is a directory.
3dir.exists <- function(x) {
4  res <- file.exists(x) & file.info(x)$isdir
5  stats::setNames(res, x)
6}
7
8compact <- function(x) {
9  is_empty <- vapply(x, function(x) length(x) == 0, logical(1))
10  x[!is_empty]
11}
12
13"%||%" <- function(a, b) if (!is.null(a)) a else b
14
15"%:::%" <- function(p, f) {
16  get(f, envir = asNamespace(p))
17}
18
19is_installed <- function(package, version = 0) {
20  installed_version <- tryCatch(utils::packageVersion(package), error = function(e) NA)
21  !is.na(installed_version) && installed_version >= version
22}
23
24#' Check that the version of an suggested package satisfies the requirements
25#'
26#' @param package The name of the suggested package
27#' @param version The version of the package
28#' @param compare The comparison operator used to check the version
29#' @keywords internal
30#' @export
31check_suggested <- function(package, version = NULL, compare = NA, path = inst("pkgload")) {
32
33  if (is.null(version)) {
34    if (!is.na(compare)) {
35      stop("Cannot set ", sQuote(compare), " without setting ",
36           sQuote(version), call. = FALSE)
37    }
38
39    version <- suggests_dep(package, path = path)
40  }
41
42  if (!is_installed(package) || !check_dep_version(package, version)) {
43    msg <- paste0(sQuote(package),
44      if (is.na(version)) "" else paste0(" ", version),
45      " must be installed for this functionality.")
46
47    if (interactive()) {
48      cli::cli_alert_info(msg)
49      cli::cli_alert_danger("Would you like to install it?")
50      if (utils::menu(c("Yes", "No")) == 1) {
51        utils::install.packages(package)
52      } else {
53        stop(msg, call. = FALSE)
54      }
55    } else {
56      stop(msg, call. = FALSE)
57    }
58  }
59}
60
61suggests_dep <- function(package, path = inst("pkgload")) {
62
63  desc <- pkg_desc(path)$get_deps()
64  found <- desc[desc$type == "Suggests" & desc$package == package, "version"]
65
66  if (!length(found)) {
67     stop("'", package, "' is not in Suggests: for '", pkg_name(path), "'", call. = FALSE)
68  }
69  found
70}
71
72all_named <- function (x) {
73  if (length(x) == 0) return(TRUE)
74  !is.null(names(x)) && all(names(x) != "")
75}
76
77make_function <- function (args, body, env = parent.frame()) {
78  args <- as.pairlist(args)
79  stopifnot(all_named(args), is.language(body))
80  eval(call("function", args, body), env)
81}
82
83comp_lang <- function(x, y, idx = seq_along(y)) {
84  if (is.symbol(x) || is.symbol(y)) {
85    return(identical(x, y))
86  }
87
88  if (length(x) < length(idx)) return(FALSE)
89
90  identical(x[idx], y[idx])
91}
92
93extract_lang <- function(x, f, ...) {
94  recurse <- function(y) {
95    unlist(compact(lapply(y, extract_lang, f = f, ...)), recursive = FALSE)
96  }
97
98  # if x matches predicate return it
99  if (isTRUE(f(x, ...))) {
100    return(x)
101  }
102
103  if (is.call(x)) {
104    res <- recurse(x)[[1]]
105    if (top_level_call <- identical(sys.call()[[1]], as.symbol("extract_lang"))
106        && is.null(res)) {
107      warning("pkgload is incompatible with the current version of R. `load_all()` may function incorrectly.", call. = FALSE)
108    }
109    return(res)
110  }
111
112  NULL
113}
114
115modify_lang <- function(x, f, ...) {
116  recurse <- function(x) {
117    lapply(x, modify_lang, f = f, ...)
118  }
119
120  x <- f(x, ...)
121
122  if (is.call(x)) {
123    as.call(recurse(x))
124  } else if (is.function(x)) {
125     formals(x) <- modify_lang(formals(x), f, ...)
126     body(x) <- modify_lang(body(x), f, ...)
127  } else {
128    x
129  }
130}
131
132strip_internal_calls <- function(x, package) {
133  if (is.call(x) && identical(x[[1L]], as.name(":::")) && identical(x[[2L]], as.name(package))) {
134    x[[3L]]
135  } else {
136    x
137  }
138}
139
140sort_ci <- function(x) {
141  withr_with_collate("C", x[order(tolower(x), x)])
142}
143
144dev_packages <- function() {
145  packages <- vapply(loadedNamespaces(),
146    function(x) !is.null(dev_meta(x)), logical(1))
147
148  names(packages)[packages]
149}
150
151copy_env <- function(src, dest = new.env(parent = emptyenv()),
152  ignore = NULL) {
153
154  srclist <- as.list(src, all.names = TRUE)
155  srclist <- srclist[ !(names(srclist) %in% ignore) ]
156  list2env(srclist, envir = dest)
157
158  dest
159}
160
161copy_env_lazy <- function(src, dest = new.env(parent = emptyenv()),
162  ignore = NULL) {
163
164  nms <- ls(src, all.names = TRUE)
165  nms <- nms[ !(nms %in% ignore) ]
166  for (nme in nms) {
167    delayed_assign(nme, as.symbol(nme), eval.env = src, assign.env = dest)
168  }
169
170  dest
171}
172
173# A version of delayedAssign which does _not_ use substitute
174delayed_assign <- function(x, value, eval.env = parent.frame(1), assign.env = parent.frame(1)) {
175  (get(".Internal", baseenv()))(delayedAssign(x, value, eval.env, assign.env))
176}
177
178last <- function(x) utils::tail(x, n = 1L)
179
180single_quote <- function(x) {
181  encodeString(x, quote = "'")
182}
183
184ns_s3_methods <- function(pkg) {
185 ns_env(pkg)$.__S3MethodsTable__.
186}
187