R/utils.R

Defines functions ask_yes_no tcltk_yesno supports_tcltk find parse_renviron file_info path_info file_size nlines is_file is_dir eof_ok stop_if_not

stop_if_not <- function(...) {
  res <- list(...)
  n <- length(res)
  if (n == 0L) return()

  for (ii in 1L:n) {
    res_ii <- .subset2(res, ii)
    if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) {
        mc <- match.call()
        call <- deparse(mc[[ii + 1]], width.cutoff = 60L)
        if (length(call) > 1L) call <- paste(call[1L], "...")
        stop(sQuote(call), " is not TRUE", call. = FALSE, domain = NA)
    }
  }
}

eof_ok <- function(file) {
  size <- file_size(file)
  ## On Windows, symbolic links, e.g. by file.symlink(), give size = 0
  ## although below readBin() return a non-empty vector
  if (.Platform$OS.type == "windows" && size == 0L) size <- 1e9
  bfr <- readBin(file, what = "raw", n = size)
  n <- length(bfr)
  if (n == 0L) return(TRUE)
  is.element(bfr[n], charToRaw("\n\r"))
}

is_dir <- function(f) {
  if (length(f) != 1L) {
    stop(sprintf("INTERNAL ERROR in startup:::is_dir(): only scalar input is supported: [n=%d] %s", length(f), paste(squote(f), collapse = ", ")))
  }
  nzchar(f) && file.exists(f) && file.info(f)$isdir
}

is_file <- function(f) {
  if (length(f) != 1L) {
    stop(sprintf("INTERNAL ERROR in startup:::is_file(): only scalar input is supported: [n=%d] %s", length(f), paste(squote(f), collapse = ", ")))
  }
  nzchar(f) && file.exists(f) && !file.info(f)$isdir
}

nlines <- function(f) {
  oopts <- options(encoding = "native.enc")
  on.exit(options(oopts))
  bfr <- readLines(f, warn = FALSE)
  bfr <- grep("^[ \t]*#", bfr, value = TRUE, invert = TRUE)
  bfr <- grep("^[ \t]*$", bfr, value = TRUE, invert = TRUE)
  length(bfr)
}

## base::file.size() was only introduced in R 3.2.0
file_size <- function(...) file.info(..., extra_cols = FALSE)$size

path_info <- function(f, extra = NULL) {
  if (!nzchar(f)) return(squote(""))
  fx <- path.expand(f)
  if (!is.null(extra)) {
    extra <- paste("; ", extra, sep = "")
  } else {
    extra <- ""
  }

  if (!is_dir(f)) {
    return(sprintf("%s (non-existing directory%s)", squote(f), extra))
  }

  if (fx == f) {
    sprintf("%s (existing folder%s)", squote(f), extra)
  } else {
    sprintf("%s => %s (existing folder%s)", squote(f), squote(fx), extra)
  }
}


file_info <- function(f, type = "txt", extra = NULL, validate = FALSE) {
  if (!nzchar(f)) return(squote(""))
  fx <- path.expand(f)
  if (length(extra) > 0L) {
    extra <- paste("; ", extra, sep = "")
  } else {
    extra <- ""
  }
  
  if (!is_file(f)) {
    return(sprintf("%s (non-existing file%s)", squote(f), extra))
  }

  if (fx == f) {
    prefix <- squote(f)
  } else {
    prefix <- sprintf("%s => %s", squote(f), squote(fx))
  }
  if (type == "binary") {
    sprintf("%s (binary file; %d bytes%s)", prefix, file_size(f), extra)
  } else if (type == "env") {
    warn <- NULL
    vars <- names(parse_renviron(f))
    nvars <- length(vars)
    if (nvars > 0) {
      if (validate && !any(vars %in% names(Sys.getenv()))) {
        prefix <- sprintf("[WARNING: It appears that R never processed this file] %s", prefix)
      }
      vars <- sprintf(" (%s)", paste(squote(vars), collapse = ", "))
    } else {
      vars <- ""
    }
    sprintf("%s (%d lines; %d bytes%s) setting %d environment variables%s",
            prefix, nlines(f), file_size(f), extra, nvars, vars)
  } else if (type == "r") {
    sprintf("%s (%d code lines; %d bytes%s)",
            prefix, nlines(f), file_size(f), extra)
  } else {
    sprintf("%s (%d lines; %d bytes%s)",
            prefix, nlines(f), file_size(f), extra)
  }
}

parse_renviron <- function(f) {
  bfr <- readLines(f, warn = FALSE)
  bfr <- grep("^[ \t]*#", bfr, value = TRUE, invert = TRUE)
  bfr <- grep("^[ \t]*$", bfr, value = TRUE, invert = TRUE)
  bfr <- grep("=.*$", bfr, value = TRUE)
  pattern <- "^([^=]*)[ \t]*=[ \t]*(.*)$"
  bfr <- grep(pattern, bfr, value = TRUE)
  names <- gsub(pattern, "\\1", bfr)
  values <- gsub(pattern, "\\2", bfr)
  names(values) <- names
  values
}

find <- function(what, mode) {
  paths <- search()
  for (pos in seq_along(paths)) {
    if (exists(what, mode = mode, where = pos, inherits = FALSE)) {
      return(structure(pos, names = names(paths)[pos]))
    }
  }
  -1L
}

## sQuote() without fancy quotes, if possible
squote <- if (getRversion() >= "3.6.0") {
  function(x) sQuote(x, q = FALSE)
} else {
  function(x) sQuote(x)
}

supports_tcltk <- function() {
  (capabilities("X11") && capabilities("tcltk") &&
   requireNamespace("tcltk") && suppressWarnings(tcltk::.TkUp))
}

tcltk_yesno <- function(question) {
  if (!supports_tcltk()) {
    warning("[startup::startup()]: Your R setup does not support X11 or tcltk dialogs. Because of this, the answer to the question ", sQuote(question), " was defaulted to ", sQuote("yes"), ".", call. = FALSE)
    return(TRUE)
  }  
  ans <- tcltk::tk_messageBox("yesno", message = question)
  (ans == "yes")
}

ask_yes_no <- function(question, rdata_workaround = TRUE) {
  ## RStudio Console workarounds?
  if (is_rstudio_console()) {
    if (rdata_workaround) {
      ## WORKAROUND: RStudio Console will load any .RData file as soon as
      ## base::readline() or utils::menu(..., graphics = FALSE) is called
      ## during startup process (https://github.com/rstudio/rstudio/issues/5844)
      ## Instead, we use a TclTk dialog.  If this is not possible, we will
      ## produce a warning and default to 'Yes'.
      return(tcltk_yesno(question))
    }
    
    ## WORKAROUND: RStudio Console does not show the base::readline() prompt
    ## during startup process (https://github.com/rstudio/rstudio/issues/5842)
    readline <- function(prompt) {
      ## Comment: appendLF = FALSE makes no difference. The "readline"
      ## will trigger a "> " prompt to be display on the next line
      message(prompt, appendLF = FALSE)
      base::readline(prompt = "")
    }
  }

  prompt <- sprintf("%s [Y/n]: ", question)
  res <- TRUE
  repeat({
    ans <- readline(prompt)
    ans <- gsub("(^[[:space:]]*|[[:space:]]*$)", "", ans)
    ans <- tolower(ans)
    if (ans %in% c("", "y", "yes")) {
      res <- TRUE
      break
    } else if (ans %in% c("n", "no")) {
      res <- FALSE
      break
    }
  })

  res
}

Try the startup package in your browser

Any scripts or data that you put into this service are public.

startup documentation built on April 3, 2023, 5:48 p.m.