|
| 1 | +# ============================================================================== |
| 2 | +# The following code is adapted from the 'pedant' package. |
| 3 | +# Source: https://github.com/wurli/pedant |
| 4 | +# Authors: Jacob Scott, Christopher T. Kenny, Sebastian Lammers |
| 5 | +# License: MIT + file LICENSE (See inst/pedant/LICENSE) |
| 6 | +# ============================================================================== |
| 7 | +# |
| 8 | +# nocov start |
| 9 | + |
| 10 | +#' Make function calls explicit |
| 11 | +#' |
| 12 | +#' This function takes a block of code and seeks to make all function calls |
| 13 | +#' 'explicit' through the use of the double-colon operator `::`. This function |
| 14 | +#' is bound to the RStudio addin `"Make function calls explicit"`. See examples |
| 15 | +#' for usage. |
| 16 | +#' |
| 17 | +#' This function behaves differently depending on the context. |
| 18 | +#' - **Not package development**: If the current |
| 19 | +#' context is not package development, then it will make function calls explicit |
| 20 | +#' using the currently attached packages (i.e. the ones attached by calls to |
| 21 | +#' `library()`). |
| 22 | +#' - **Package development**: If it detects that the current context is package |
| 23 | +#' development it will make function calls explicit using packages in the |
| 24 | +#' 'Imports' field of the package `DESCRIPTION`. If the package being developed |
| 25 | +#' imports any packages in their entirety (i.e if `Import pkg` appears in the |
| 26 | +#' `NAMESPACE` file), calls to functions from these packages will be left |
| 27 | +#' unchanged. |
| 28 | +#' See `current_packages()` for more information. |
| 29 | +#' |
| 30 | +#' @param code Code to transform. Either a character vector or `NULL`, in which |
| 31 | +#' case any highlighted code (in RStudio) will be used. |
| 32 | +#' @param use_packages A character vector of package names. The order is |
| 33 | +#' important here - see examples for details. |
| 34 | +#' @param ignore_functions Functions to ignore when applying the transformation |
| 35 | +#' |
| 36 | +#' @return The transformed `code` as a character string |
| 37 | +#' @export |
| 38 | +#' |
| 39 | +#' @examples |
| 40 | +#' code <- " |
| 41 | +#' cars <- as_tibble(mtcars) |
| 42 | +#' cars %>% |
| 43 | +#' filter(mpg > 20) %>% |
| 44 | +#' summarise(across(everything(), n_distinct)) |
| 45 | +#' " |
| 46 | +#' |
| 47 | +#' # Code will be transformed to use the double-colon operator, but notice |
| 48 | +#' # that `n_distinct` is not transformed as it is not followed by `()` |
| 49 | +#' cat(add_double_colons(code, "dplyr")) |
| 50 | +#' |
| 51 | +#' # You can specify functions that shouldn't be transformed: |
| 52 | +#' cat(add_double_colons(code, "dplyr", ignore_functions = "across")) |
| 53 | +#' |
| 54 | +#' # Beware namespace conflicts! The following are not the same, mimicking |
| 55 | +#' # the effects of reordering calls to `library()`: |
| 56 | +#' cat(add_double_colons(code, c("dplyr", "stats"))) |
| 57 | +#' |
| 58 | +#' cat(add_double_colons(code, c("stats", "dplyr"))) |
| 59 | +add_double_colons <- function( |
| 60 | + code = NULL, |
| 61 | + use_packages = current_packages(), |
| 62 | + ignore_functions = imported_functions() |
| 63 | +) { |
| 64 | + # Error trapping + check if we're replacing highlighted code |
| 65 | + if (is.null(code)) { |
| 66 | + if (!requireNamespace("rstudioapi", quietly = TRUE)) { |
| 67 | + stop("{rstudioapi} must be installed") |
| 68 | + } |
| 69 | + if (!rstudioapi::isAvailable()) { |
| 70 | + stop("RStudio is not available") |
| 71 | + } |
| 72 | + replace_selection <- TRUE |
| 73 | + code <- rstudioapi::selectionGet()$value |
| 74 | + } else { |
| 75 | + replace_selection <- FALSE |
| 76 | + } |
| 77 | + |
| 78 | + # Need to make this small adjustment to (very badly styled) code since |
| 79 | + # variable-length lookbehinds aren't possible |
| 80 | + code <- gsub(":: +", "::", code) |
| 81 | + |
| 82 | + # Regular expression to extract function calls |
| 83 | + backticks_fns <- "`[^`]+`(?= *[(])" |
| 84 | + syntactic_fns <- "(?<=[^a-zA-Z._]|^)[a-zA-Z._]+(?= *[(])" |
| 85 | + exclude_dcs <- "(?<!::)" |
| 86 | + funs_regex <- sprintf("%s(%s|%s)", exclude_dcs, backticks_fns, syntactic_fns) |
| 87 | + |
| 88 | + all_calls <- str_extract_all(code, funs_regex) |
| 89 | + called_funs <- unique(all_calls) |
| 90 | + |
| 91 | + # Get a lookup list of names = packages, values = namespace exports |
| 92 | + pkg_lookup <- lapply(use_packages, getNamespaceExports) |
| 93 | + names(pkg_lookup) <- use_packages |
| 94 | + |
| 95 | + # Helper to retrieve the `pkg::fun` text for a function `fun` |
| 96 | + get_pkg <- function(fun) { |
| 97 | + fun1 <- gsub("(^`)|(`$)", "", fun) |
| 98 | + |
| 99 | + for (pkg in use_packages) { |
| 100 | + if (fun1 %in% pkg_lookup[[pkg]]) { |
| 101 | + if (pkg == "base" || fun1 %in% ignore_functions) { |
| 102 | + return(fun) |
| 103 | + } else { |
| 104 | + return(paste0(pkg, "::", fun)) |
| 105 | + } |
| 106 | + } |
| 107 | + } |
| 108 | + NA_character_ |
| 109 | + } |
| 110 | + |
| 111 | + # Get the replacement text for each function call |
| 112 | + called_funs_pkgs <- vapply(called_funs, get_pkg, character(1)) |
| 113 | + no_pkg <- is.na(called_funs_pkgs) |
| 114 | + |
| 115 | + # Warn about any unfound functions |
| 116 | + if (any(no_pkg) > 0) { |
| 117 | + warning( |
| 118 | + sprintf( |
| 119 | + "Couldn't find packages exporting %d function(s): `%s()`", |
| 120 | + sum(no_pkg), |
| 121 | + paste(called_funs[no_pkg], collapse = "()`, `") |
| 122 | + ), |
| 123 | + call. = FALSE |
| 124 | + ) |
| 125 | + |
| 126 | + called_funs_pkgs[no_pkg] <- names(called_funs_pkgs)[no_pkg] |
| 127 | + } |
| 128 | + |
| 129 | + # Get the full vector of replacements for the regex matches |
| 130 | + replacements <- called_funs_pkgs[ |
| 131 | + vapply( |
| 132 | + all_calls, |
| 133 | + function(x) which(names(called_funs_pkgs) == x), |
| 134 | + integer(1) |
| 135 | + ) |
| 136 | + ] |
| 137 | + out <- str_replace_all(code, funs_regex, replacements) |
| 138 | + |
| 139 | + if (replace_selection) { |
| 140 | + rstudioapi::insertText(out) |
| 141 | + return(invisible(out)) |
| 142 | + } |
| 143 | + |
| 144 | + out |
| 145 | +} |
| 146 | + |
| 147 | +get_imports <- function(dir = ".") { |
| 148 | + if (!requireNamespace("pkgload", quietly = TRUE)) { |
| 149 | + return(NULL) |
| 150 | + } |
| 151 | + |
| 152 | + imports <- tryCatch( |
| 153 | + pkgload::parse_ns_file(dir)$imports, |
| 154 | + error = function(e) NULL |
| 155 | + ) |
| 156 | + |
| 157 | + if (is.null(imports)) { |
| 158 | + return(NULL) |
| 159 | + } |
| 160 | + |
| 161 | + out <- list( |
| 162 | + packages = lapply(imports, function(x) if (length(x) == 1) x else NULL), |
| 163 | + functions = lapply(imports, function(x) x[-1]) |
| 164 | + ) |
| 165 | + |
| 166 | + lapply(out, unlist, use.names = FALSE) |
| 167 | +} |
| 168 | + |
| 169 | +get_dependencies <- function( |
| 170 | + dir = ".", |
| 171 | + types = c("Imports", "Depends", "Suggests", "Enhances", "LinkingTo") |
| 172 | +) { |
| 173 | + if (!requireNamespace("pkgload", quietly = TRUE)) { |
| 174 | + return(NULL) |
| 175 | + } |
| 176 | + |
| 177 | + types <- match.arg(types, several.ok = TRUE) |
| 178 | + |
| 179 | + deps <- tryCatch( |
| 180 | + pkgload::pkg_desc(dir)$get_deps(), |
| 181 | + error = function(e) NULL |
| 182 | + ) |
| 183 | + |
| 184 | + if (is.null(deps)) { |
| 185 | + return(NULL) |
| 186 | + } |
| 187 | + |
| 188 | + deps$package[deps$type %in% types] |
| 189 | +} |
| 190 | + |
| 191 | +#' @rdname current_packages |
| 192 | +#' @export |
| 193 | +is_dev_context <- function(dir = ".") { |
| 194 | + if (!requireNamespace("pkgload", quietly = TRUE)) { |
| 195 | + return(FALSE) |
| 196 | + } |
| 197 | + tryCatch( |
| 198 | + { |
| 199 | + pkgload::pkg_name(dir) |
| 200 | + TRUE |
| 201 | + }, |
| 202 | + error = function(e) FALSE |
| 203 | + ) |
| 204 | +} |
| 205 | + |
| 206 | +imported_packages <- function(dir = ".") { |
| 207 | + get_imports(dir)$packages |
| 208 | +} |
| 209 | + |
| 210 | +dev_context_pkgs <- function(dir = ".", types = "Imports") { |
| 211 | + setdiff(get_dependencies(dir, types), imported_packages(dir)) |
| 212 | +} |
| 213 | + |
| 214 | +loaded_packages <- function() { |
| 215 | + search_path <- search() |
| 216 | + out <- search_path[grepl("^package:", search_path)] |
| 217 | + sub("^package:", "", out) |
| 218 | +} |
| 219 | + |
| 220 | +#' @rdname current_packages |
| 221 | +#' @export |
| 222 | +imported_functions <- function(dir = ".") { |
| 223 | + get_imports(dir)$functions |
| 224 | +} |
| 225 | + |
| 226 | +#' Get packages from the current context |
| 227 | +#' |
| 228 | +#' These functions find the packages/functions to use when running |
| 229 | +#' `add_double_colons()`. |
| 230 | +#' |
| 231 | +#' - `current_packages()` first checks if the current context is package |
| 232 | +#' development. If it is, then it returns the packages which are listed in the |
| 233 | +#' package `DESCRIPTION` as dependencies, but will not return any packages also |
| 234 | +#' listed as imports in the package `NAMESPACE`. If the current context is not |
| 235 | +#' package development, the currently attached packages (as given by `search()`) |
| 236 | +#' are used. Note that if `{pkgload}` is not installed then the latter option is |
| 237 | +#' always used. |
| 238 | +#' - `imported_functions()` looks for a package `NAMESPACE` file and returns the |
| 239 | +#' names of all imported functions. If a `NAMESPACE` file is not found, or if |
| 240 | +#' `{pkgload}` is not loaded, `NULL` is returned. |
| 241 | +#' |
| 242 | +#' @param dir The current working directory |
| 243 | +#' @param base_packages Default packages to include |
| 244 | +#' @param include_types The types of package imports to return if the current |
| 245 | +#' context is package development. Should be a subset of |
| 246 | +#' `c("Imports", "Depends", "Suggests", "Enhances", "LinkingTo")` |
| 247 | +#' |
| 248 | +#' @export |
| 249 | +current_packages <- function( |
| 250 | + dir = ".", |
| 251 | + base_packages = getOption("defaultPackages"), |
| 252 | + include_types = "Imports" |
| 253 | +) { |
| 254 | + out <- if (is_dev_context()) { |
| 255 | + dev_context_pkgs(dir, include_types) |
| 256 | + } else { |
| 257 | + loaded_packages() |
| 258 | + } |
| 259 | + |
| 260 | + unique(c(out, base_packages, "base")) |
| 261 | +} |
| 262 | + |
| 263 | +str_extract_all <- function(x, pattern, invert = FALSE) { |
| 264 | + regmatches(x, gregexpr(pattern, x, perl = TRUE), invert)[[1]] |
| 265 | +} |
| 266 | + |
| 267 | +str_replace_all <- function(x, pattern, replacement) { |
| 268 | + regex <- gregexpr(pattern, x, perl = TRUE) |
| 269 | + regmatches(x, regex)[[1]] <- replacement |
| 270 | + x |
| 271 | +} |
| 272 | + |
| 273 | +# nocov end |
0 commit comments