R/utils.R

In r-lib/pkgman: Another Approach to Package Installation

`%||%` <- function(l, r) if (is.null(l)) r else l

# Adapted from withr:::merge_new
merge_new <- function(old, new, action = c("replace", "prepend", "append")) {
  action <- match.arg(action, c("replace", "prepend", "append"))

  switch(action,
    prepend = c(new, old),
    append = c(old, new),
    replace = new
  )
}

vcapply <- function(X, FUN, ...) {
  vapply(X, FUN, FUN.VALUE = character(1), ...)
}

vlapply <- function(X, FUN, ...) {
  vapply(X, FUN, FUN.VALUE = logical(1), ...)
}

viapply <- function(X, FUN, ...) {
  vapply(X, FUN, FUN.VALUE = integer(1), ...)
}

vdapply <- function(X, FUN, ...) {
  vapply(X, FUN, FUN.VALUE = double(1), ...)
}

is_verbose <- function() {
  env <- Sys.getenv("R_PKG_SHOW_PROGRESS", "")
  if (env != "") {
    tolower(env) == "true"
  } else {
    opt <- getOption("pkg.show_progress")
    if (!is.null(opt)) {
      return(isTRUE(opt))
    } else {
      interactive()
    }
  }
}

backtick <- function (x) {
  encodeString(x, quote = "`", na.encode = FALSE)
}

format_items <- function (x) {
  paste0(cli::ansi_collapse(backtick(x), sep = ", ", last = " and "))
}

str_trim <- function (x) {
  sub("^\\s+", "", sub("\\s+$", "", x))
}

list_files <- function(path) {
  if (!file.exists(path)) return(character())
  fs <- dir(path, full.names = TRUE)
  basename(fs[! is_dir(fs)])
}

file_mtime <- function(...) {
  file.info(..., extra_cols = FALSE)$mtime
}

is_dir <- function(...) {
  file.info(..., extra_cols = FALSE)$isdir
}

get_minor_r_version <- function(x = getRversion()) {
  x <- package_version(x)
  vapply(unclass(x), function(x) paste(x[1:2], collapse = "."), character(1))
}

get_os <- function() {
  if (.Platform$OS.type == "windows") {
    "win"
  } else if (Sys.info()["sysname"] == "Darwin") {
    "mac"
  } else if (.Platform$OS.type == "unix") {
    "unix"
  } else {
    "unknown"
  }
}

user_cache_dir <- function(appname) {
  if (nzchar(cache <- Sys.getenv("R_PKG_CACHE_DIR", ""))) {
    return(cache)
  }
  if (nzchar(cache <- Sys.getenv("R_USER_CACHE_DIR", ""))) {
    return(file.path(cache, "R", appname))
  }
  switch(
    get_os(),
    win = file_path(win_path_local(), "R", "Cache", appname),
    mac = file_path("~/Library/Caches", "org.R-project.R", "R", appname),
    unix = file_path(Sys.getenv("XDG_CACHE_HOME", "~/.cache"), "R", appname),
    unknown = file_path(tempdir(), "r-pkg-cache", appname)
  )
}

file_path <- function(...) {
  normalizePath(do.call("file.path", as.list(c(...))), mustWork = FALSE)
}

win_path_local <- function() {
  if (nzchar(lapp <- Sys.getenv("LOCALAPPDATA", ""))) {
    lapp

  } else if (nzchar(usrprof <- Sys.getenv("USERPROFILE", ""))) {
    file.path(usrprof, "AppData", "Local")

  } else {
    file.path(tempdir(), "r-pkg-cache")
  }
}

cat0 <- function(..., sep = "") {
  cat(..., sep = sep)
}

catln <- function(..., sep = "") {
  cat(..., "\n", sep = "")
}

get_num_workers <- function() {
  n <- tryCatch(
    suppressWarnings(as.integer(getOption("Ncpus", NA_integer_))),
    error = function(e) NA_integer_)

  if (length(n) != 1 || is.na(n)) {
    n <- tryCatch(
      ps::ps_cpu_count(logical = TRUE),
      error = function(e) NA_integer_)
  }

  if (is.na(n)) n <- 1L

  n
}

to_package_name <- function(x) {
  x <- gsub("[^a-zA-Z0-9\\.]", "", x)
  if (nchar(x) < 2) {
    "unknown.package"
  } else if (!grepl("^[a-zA-Z]", x)) {
    paste0("X", x)
  } else {
    x
  }
}

strrep <- function(x, times) {
  x = as.character(x)
  if (length(x) == 0L)
    return(x)
  unlist(.mapply(function(x, times) {
    if (is.na(x) || is.na(times))
      return(NA_character_)
    if (times <= 0L)
      return("")
    paste0(replicate(times, x), collapse = "")
  }, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
}

testthat_testing <- function() {
  identical(Sys.getenv("TESTTHAT"), "true")
}

norm_path <- function(x) {
  normalizePath(x, winslash = "/")
}

drop_nulls <- function(x) {
  is_null <- vlapply(x, is.null)
  x[!is_null]
}

mkdirp <- function(dir, msg = NULL) {
  s <- vlapply(dir, dir.create, recursive = TRUE, showWarnings = FALSE)
  if (any(s) && !is.null(msg) && is_verbose()) {
    cli::cli_alert_info("{msg}: {.path {format_items(dir[s])}}")
  }
  invisible(s)
}

fix_macos_path_in_rstudio <- function() {
  ## Only in RStudio
  if (Sys.getenv("RSTUDIO") != "1") return()
  ## Only on macOS
  if (Sys.info()["sysname"] != "Darwin") return()

  if (!file.exists("/etc/paths")) return()

  path <- Sys.getenv("PATH")
  new_path <- readLines("/etc/paths", n = 1000)
  Sys.setenv(PATH = paste0(path, ":", paste(new_path, collapse = ":")))

  invisible()
}

append_union <- function(path, cnt, msg_new = NULL, msg_done = NULL) {
  lines <- readLines(path)
  new_cnt <- setdiff(cnt, lines)
  if (length(new_cnt)) {
    new_lines <- c(lines, new_cnt)
    if (!is.null(msg_new)) cli::cli_alert_info(msg_new)
    writeLines(new_lines, path)
  } else {
    if (!is.null(msg_done)) cli::cli_alert_info(msg_done)
  }
  invisible()
}

try_add_to_git <- function(path) {
  tryCatch({
    processx::run("git", c("add", path), timeout = 10)
    cli::cli_alert_info("Add {.path {path}} to git.")
  }, error = function(x) x)
}

rimraf <- function(...) {
  x <- file.path(...)
  if ("~" %in% x) stop("Cowardly refusing to delete `~`")
  unlink(x, recursive = TRUE, force = TRUE)
}

msg <- function(..., domain = NULL, appendLF = TRUE) {
  msg <- .makeMessage(..., domain = domain, appendLF = appendLF)

  output <- if (is_interactive()) stdout() else stderr()

  withRestarts(muffleMessage = function() NULL, {
    signalCondition(simpleMessage(msg))
    cat(msg, file = output, sep = "")
  })
}

is_interactive <- function() {
  opt <- getOption("rlib_interactive")
  if (isTRUE(opt)) {
    TRUE
  } else if (identical(opt, FALSE)) {
    FALSE
  } else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
    FALSE
  } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") {
    FALSE
  } else if (identical(Sys.getenv("TESTTHAT"), "true")) {
    FALSE
  } else {
    interactive()
  }
}

loaded_packages <- function(lib) {
  lib <- normalizePath(lib)
  pkgs <- setdiff(loadedNamespaces(), base_packages())
  libs <- vcapply(pkgs, function(x) dirname(getNamespaceInfo(x, "path")))

  bad <- normalizePath(libs) == lib
  pkgs[bad]
}

lapply_with_names <- function(X, FUN, ...) {
  structure(lapply(X, FUN, ...), names = X)
}

na_omit <- function(x) {
  x[!is.na(x)]
}

## TODO: in theory the set of base packages can change over time,
## so we would need an R version specific vector here.
## Not an issue currently, might be in the future.

base_packages <- function() {

  if (is.null(pkg_data$base_packages)) {
    pkg_data$base_packages <-
      c("base", "compiler", "datasets", "graphics", "grDevices", "grid",
        "methods", "parallel", "splines", "stats", "stats4", "tcltk",
        "tools", "utils"
        )
  }
  pkg_data$base_packages
}

is_flag <- function(x) {
  is.logical(x) && length(x) == 1 && !is.na(x)
}

is_string <- function(x) {
  is.character(x) && length(x) == 1 && !is.na(x)
}

map_named <- function(x, fun) {
  mapply(names(x), x, SIMPLIFY = FALSE, FUN = fun)
}

rbind_expand <- function(..., .list = list()) {
  data <- c(list(...), .list)
  cols <- unique(unlist(lapply(data, function(x) colnames(x))))
  for (i in seq_along(data)) {
    miss_cols <- setdiff(cols, colnames(data[[i]]))
    if (length(miss_cols)) {
      na_df <- as_data_frame(structure(
        replicate(
          length(miss_cols),
          if (nrow(data[[i]])) NA else logical(),
          simplify = FALSE),
        names = miss_cols))
      data[[i]] <- as_data_frame(cbind(data[[i]], na_df))
    }
  }

  do.call(rbind, data)
}

cisort <- function(x) {
  x[order(tolower(x))]
}