R/utils.R

Defines functions wait not warnify topfun overlay summon timer wait_until rep_named cancel_if cancel take recycle prof chop env2list env stringify cols rows fsub csort recursing find nth dequote resolve invoke omit_if omit keep_if keep remap convert quietly nullfile comspec rowapply zmap visited fileext endswith trunc nplural plural read deparsed insert menu proceed ask catchall catch compose case trimws trim zlength empty named is_named lines `%&&%` `%NA%` `%>%`

`%>%` <- function(...) {

  dots <- eval(substitute(alist(...)))
  if (length(dots) != 2L)
    stopf("`%>%` called with invalid number of arguments")

  lhs <- dots[[1L]]; rhs <- dots[[2L]]
  if (!is.call(rhs))
    stopf("right-hand side of rhs is not a call")

  data <- c(rhs[[1L]], lhs, as.list(rhs[-1L]))
  call <- as.call(data)

  nm <- names(rhs)
  if (length(nm))
    names(call) <- c("", "", nm[-1L])

  eval(call, envir = parent.frame())

}

`%NA%` <- function(x, y) {
  if (length(x) && is.na(x)) y else x
}

`%&&%` <- function(x, y) {
  if (length(x)) y
}

lines <- function(...) {
  paste(..., sep = "\n")
}

is_named <- function(x) {
  nm <- names(x)
  !is.null(nm) && all(nzchar(nm))
}

named <- function(object, names = object) {
  names(object) <- names
  object
}

empty <- function(x) {
  length(x) == 0L
}

zlength <- function(x) {
  length(x) != 0L
}

trim <- function(x) {
  gsub("^\\s+|\\s+$", "", x, perl = TRUE)
}

trimws <- function(x) {
  gsub("^\\s+|\\s+$", "", x, perl = TRUE)
}

case <- function(...) {

  dots <- eval(substitute(alist(...)))
  for (i in seq_along(dots)) {

    if (identical(dots[[i]], quote(expr = )))
      next

    dot <- eval(dots[[i]], envir = parent.frame())
    if (!inherits(dot, "formula"))
      return(dot)

    # Silence R CMD check note
    expr <- NULL
    cond <- NULL

    # use delayed assignments below so we can allow return statements to
    # be handled in the lexical scope where they were defined
    if (length(dot) == 2L) {
      do.call(delayedAssign, list("expr", dot[[2L]], eval.env = environment(dot)))
      return(expr)
    }

    do.call(delayedAssign, list("cond", dot[[2L]], eval.env = environment(dot)))
    do.call(delayedAssign, list("expr", dot[[3L]], eval.env = environment(dot)))
    if (cond) return(expr)

  }

}

compose <- function(wrapper, callback) {
  function(...) wrapper(callback(...))
}

catch <- function(expr) {
  tryCatch(
    withCallingHandlers(expr, error = renv_error_capture),
    error = renv_error_tag
  )
}

catchall <- function(expr) {
  tryCatch(
    withCallingHandlers(
      expr = expr,
      error = renv_error_capture,
      warning = renv_error_capture
    ),
    error = renv_error_tag,
    warning = renv_error_tag
  )
}

# nocov start

ask <- function(question, default = FALSE) {

  if (renv_tests_running())
    return(TRUE)

  enabled <- getOption("renv.prompt.enabled", default = TRUE)
  if (!enabled)
    return(default)

  if (!interactive())
    return(default)

  # can't prompt for input when autoloading; code run from `.Rprofile` should
  # not attempt to interact with the user
  # from `?Startup`:
  # "It is not intended that there be interaction with the user during startup
  # code. Attempting to do so can crash the R process."
  # https://github.com/rstudio/renv/issues/1879
  if (autoloading())
    return(default)

  # be verbose in this scope, as we're asking the user for input
  renv_scope_options(renv.verbose = TRUE)

  repeat {

    # solicit user's answer
    selection <- if (default) "[Y/n]" else "[y/N]"
    prompt <- sprintf("%s %s: ", question, selection)
    response <- tryCatch(
      tolower(trimws(readline(prompt))),
      interrupt = identity
    )

    # check for interrupts; treat as abort request
    cancel_if(inherits(response, "interrupt"))

    # use default when no response
    if (!nzchar(response))
      return(default)

    # check for 'yes' responses
    if (response %in% c("y", "yes")) {
      writef("")
      return(TRUE)
    }

    # check for 'no' responses
    if (response %in% c("n", "no")) {
      writef("")
      return(FALSE)
    }

    # ask the user again
    writef("- Unrecognized response: please enter 'y' or 'n', or type Ctrl + C to cancel.")

  }

}

proceed <- function(default = TRUE) {
  ask("Do you want to proceed?", default = default)
}

menu <- function(choices, title, default = 1L) {

  testing <- getOption("renv.menu.choice", integer())
  selected <- if (length(testing)) {
    options(renv.menu.choice = testing[-1L])
    testing[[1L]]
  } else if (testing()) {
    default
  }

  if (!is.null(selected)) {
    title <- paste(title, collapse = "\n")
    body <- paste(sprintf("%i: %s", seq_along(choices), choices), collapse = "\n")
    footer <- sprintf("Selection: %s\n", selected)
    writef(paste(c(title, body, footer), collapse = "\n\n"))
    return(names(choices)[selected])
  }

  if (!interactive()) {
    value <- if (is.numeric(default)) names(choices)[default] else default
    return(value)
  }

  idx <- tryCatch(
    utils::menu(choices, paste(title, collapse = "\n"), graphics = FALSE),
    interrupt = function(cnd) 0L
  )

  if (idx == 0L)
    return("cancel")

  names(choices)[idx]

}

# nocov end

insert <- function(contents,
                   pattern,
                   replacement,
                   anchor = NULL,
                   fixed  = FALSE)
{
  # first, check to see if the pattern matches a line
  index <- grep(pattern, contents, perl = !fixed, fixed = fixed)
  if (length(index)) {
    contents[index] <- replacement
    return(contents)
  }

  # otherwise, check for the anchor, and insert after
  index <- if (!is.null(anchor))
    grep(anchor, contents, perl = !fixed, fixed = fixed)

  if (!length(index))
    return(c(contents, replacement))

  c(
    head(contents, n = index),
    replacement,
    tail(contents, n = -index)
  )
}

deparsed <- function(value, width = 60L) {
  paste(deparse(value, width.cutoff = width), collapse = "\n")
}

read <- function(file) {
  renv_scope_options(warn = -1L)
  contents <- readLines(file, warn = FALSE)
  paste(contents, collapse = "\n")
}

plural <- function(word, n) {
  suffixes <- c("", "s")
  indices <- as.integer(n != 1L) + 1L
  paste0(word, suffixes[indices])
}

nplural <- function(word, n) {
  paste(n, plural(word, n))
}

trunc <- function(text, n = 78) {
  long <- nchar(text) > n
  text[long] <- sprintf("%s <...>", substring(text[long], 1, n - 6))
  text
}

endswith <- function(string, suffix) {
  substring(string, nchar(string) - nchar(suffix) + 1) == suffix
}

# like tools::file_ext, but includes leading '.', and preserves
# '.tar.gz', '.tar.bz' and so on
fileext <- function(path, default = "") {
  indices <- regexpr("[.]((?:tar[.])?[[:alnum:]]+)$", path, perl = TRUE)
  ifelse(indices > -1L, substring(path, indices), default)
}

visited <- function(name, envir) {
  value <- envir[[name]] %||% FALSE
  envir[[name]] <- TRUE
  value
}

zmap <- function(x, f) {
  callback <- function(x) do.call(f, x)
  lapply(x, callback)
}

rowapply <- function(X, FUN, ...) {
  lapply(seq_len(NROW(X)), function(I) {
    FUN(X[I, , drop = FALSE], ...)
  })
}

comspec <- function() {
  Sys.getenv("COMSPEC", unset = Sys.which("cmd.exe"))
}

nullfile <- function() {
  if (renv_platform_windows()) "NUL" else "/dev/null"
}

quietly <- function(expr, sink = TRUE) {

  if (sink) {
    sink(file = nullfile())
    defer(sink(NULL))
  }

  withCallingHandlers(
    expr,
    warning               = function(c) invokeRestart("muffleWarning"),
    message               = function(c) invokeRestart("muffleMessage"),
    packageStartupMessage = function(c) invokeRestart("muffleMessage")
  )

}

# NOTE: This function can be used in preference to `as.*()` if you'd like
# to preserve attributes on the incoming object 'x'.
convert <- function(x, type) {
  storage.mode(x) <- type
  x
}

remap <- function(x, map) {

  # TODO: use match?
  remapped <- x
  enumerate(map, function(key, val) {
    remapped[remapped == key] <<- val
  })
  remapped

}

keep <- function(x, keys) {
  x[intersect(keys, names(x))]
}

keep_if <- function(x, f) {
  x[f(x)]
}

omit <- function(x, keys) {
  x[setdiff(names(x), keys)]
}

omit_if <- function(x, f) {
  x[!f(x)]
}

invoke <- function(callback, ...) {
  callback(...)
}

resolve <- function(object) {

  while (is.function(object))
    object <- object()

  object

}

dequote <- function(strings) {

  for (quote in c("'", '"')) {

    # find strings matching pattern
    pattern <- paste0(quote, "(.*)", quote)
    matches <- grep(pattern, strings, perl = TRUE)
    if (empty(matches))
      next

    # remove outer quotes
    strings[matches] <- gsub(pattern, "\\1", strings[matches], perl = TRUE)

    # un-escape inner quotes
    pattern <- paste0("\\", quote)
    strings[matches] <- gsub(pattern, quote, strings[matches], fixed = TRUE)
  }

  strings

}

nth <- function(x, i) {
  x[[i]]
}

find <- function(x, f, ...) {
  for (i in seq_along(x))
    if (!is.null(value <- f(x[[i]], ...)))
      return(value)
}

recursing <- function() {

  nf <- sys.nframe()
  if (nf < 2L)
    return(FALSE)

  np <- sys.parent()
  fn <- sys.function(np)
  for (i in seq_len(np - 1L))
    if (identical(fn, sys.function(i)))
      return(TRUE)

  FALSE

}

csort <- function(x, decreasing = FALSE, ...) {
  renv_scope_locale("LC_COLLATE", "C")
  sort(x, decreasing, ...)
}

fsub <- function(pattern, replacement, x, ignore.case = FALSE, useBytes = FALSE) {
  sub(pattern, replacement, x, ignore.case = ignore.case, useBytes = useBytes, fixed = TRUE)
}

rows <- function(data, indices) {

  if (is.null(data))
    return(data_frame())

  # convert logical values
  if (is.logical(indices)) {
    if (length(indices) < nrow(data))
      indices <- rep(indices, length.out = nrow(data))
    indices <- which(indices, useNames = FALSE)
  }

  # build output list
  output <- vector("list", length(data))
  for (i in seq_along(data))
    output[[i]] <- .subset2(data, i)[indices]

  # copy relevant attributes
  attrs <- attributes(data)
  attrs[["row.names"]] <- .set_row_names(length(indices))
  attributes(output) <- attrs

  # return new data.frame
  output

}

cols <- function(data, indices) {

  # perform subset
  output <- .subset(data, indices)

  # copy relevant attributes
  attrs <- attributes(data)
  attrs[["names"]] <- attr(output, "names", exact = TRUE)
  attributes(output) <- attrs

  # return output
  output

}

stringify <- function(object, collapse = " ") {

  if (is.symbol(object))
    return(as.character(object))

  paste(
    deparse(object, width.cutoff = 500L),
    collapse = collapse
  )

}

env <- function(...) {
  list2env(list(...), envir = new.env(parent = emptyenv()))
}

env2list <- function(env) {
  as.list.environment(env, all.names = TRUE)
}

chop <- function(x, split = "\n", fixed = TRUE, perl = FALSE, useBytes = FALSE) {
  strsplit(x, split, !perl, perl, useBytes)[[1L]]
}

prof <- function(expr, ...) {

  profile <- tempfile("renv-profile-", fileext = ".Rprof")

  Rprof(profile, ...)
  result <- expr
  Rprof(NULL)
  print(summaryRprof(profile))

  invisible(result)

}

recycle <- function(data) {

  # compute number of columns
  n <- lengths(data, use.names = FALSE)
  nrow <- max(n)

  # start recycling
  for (i in seq_along(data)) {
    if (n[[i]] == 0L) {
      length(data[[i]]) <- nrow
    } else if (n[[i]] != nrow) {
      data[[i]] <- rep.int(data[[i]], nrow / n[[i]])
    }
  }

  data

}

take <- function(data, index = NULL) {
  if (is.null(index)) data else .subset2(data, index)
}

cancel <- function(verbose = TRUE) {

  renv_snapshot_auto_suppress_next()
  if (testing())
    stop("Operation canceled", call. = FALSE)

  if (verbose)
    message("- Operation canceled.")
  invokeRestart("abort")

}

cancel_if <- function(cnd) {
  if (cnd) cancel()
}

rep_named <- function(names, x) {
  values <- rep_len(x, length(names))
  names(values) <- names
  values
}

wait_until <- function(callback, ...) {
  repeat if (callback(...)) return(TRUE)
}

timer <- function(units = "secs") {

  .time <- Sys.time()
  .units <- units

  list(

    now = function() {
      Sys.time()
    },

    elapsed = function() {
      difftime(Sys.time(), .time, units = .units)
    }
  )

}

summon <- function() {
  envir <- do.call(attach, list(what = NULL, name = "renv"))
  renv <- renv_envir_self()
  list2env(as.list(renv), envir = envir)
}

overlay <- function(lhs, rhs) {
  modifyList(as.list(lhs), as.list(rhs))
}

# the 'top' renv function in the call stack
topfun <- function() {

  self <- renv_envir_self()
  frames <- sys.frames()

  for (i in seq_along(frames))
    if (identical(self, parent.env(frames[[i]])))
      return(sys.function(i))

}

warnify <- function(cnd) {
  class(cnd) <- c("warning", "condition")
  warning(cnd)
}

# note: also handles stringy values like 'True'
not <- function(value) {
  if (value) FALSE else TRUE
}

wait <- function(predicate, ...) {
  while (TRUE)
    if (predicate(...))
      break
}
rstudio/renv documentation built on June 2, 2025, 4:16 a.m.