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