R/utils.R

In klmr/roxydoxy: Documentation for non-package R code

internal_f <- function(p, f) {
  stopifnot(is.character(p), length(p) == 1)
  stopifnot(is.character(f), length(f) == 1)

  get(f, envir = asNamespace(p))
}

"%||%" <- function(a, b) {
  if (length(a) > 0) a else b
}

subs <- matrix(ncol = 2, byrow = T, c(
  # Common special function names
  '[<-', 'subset',
  '[', 'sub',
  '<-', 'set',

  # Infix verbs
  '!', 'not',
  '&', 'and',
  '|', 'or',
  '*', 'times',
  '+', 'plus',
  '^', 'pow',

  # Others
  '"', 'quote',
  '#', 'hash',
  '$', 'cash',
  '%', 'grapes',
  "'", 'single-quote',
  '(', 'open-paren',
  ')', 'close-paren',
  ':', 'colon',
  ';', 'semi-colon',
  '<', 'less-than',
  '==', 'equals',
  '=', 'equals',
  '>', 'greater-than',
  '?', 'help',
  '@', 'at',
  ']', 'close-brace',
  '\\', 'backslash',
  '/', 'slash',
  '`', 'tick',
  '{', 'open-curly',
  '}', 'close',
  '~', 'twiddle'
))
subs[, 2] <- paste0("-", subs[, 2], "-")

nice_name <- function(x) {
  x <- stringi::stri_replace_all_fixed(x, subs[, 1], subs[, 2],
    vectorize_all = FALSE)

  # Clean up any remaining
  x <- str_replace_all(x, "[^A-Za-z0-9_.-]+", "-")
  x <- str_replace_all(x, "-+", "-")
  x <- str_replace_all(x, "^-|-$", "")
  x
}

write_if_different <- function(path, contents, check = TRUE) {
  if (!file.exists(dirname(path))) {
    dir.create(dirname(path), showWarnings = FALSE)
  }

  if (check && !made_by_roxygen(path)) {
    warning("The existing '", basename(path),
      "' file was not generated by roxydoxy, and will not be overwritten.",
      call. = FALSE, immediate. = TRUE)
    return(FALSE)
  }

  if (same_contents(path, contents)) return(FALSE)

  name <- basename(path)
  if (!str_detect(name, "^[a-zA-Z][a-zA-Z0-9_.-]*$")) {
    cat("Skipping invalid path: ", name, "\n")
    FALSE
  } else {
    cat(sprintf('Writing %s\n', name))
    writeLines(contents, path, useBytes = TRUE)
    TRUE
  }
}

same_contents <- function(path, contents) {
  if (!file.exists(path)) return(FALSE)

  contents <- paste0(paste0(contents, collapse = "\n"), "\n")
  if (.Platform$OS.type == "windows") {
    contents <- gsub("\n", "\r\n", contents, fixed = TRUE)
  }

  text_hash <- digest::digest(contents, serialize = FALSE)
  file_hash <- digest::digest(file = path)

  identical(text_hash, file_hash)
}

r_files <- function(path) {
  sort_c(dir(file.path(path, "R"), "[.Rr]$", full.names = TRUE))
}

ignore_files <- function(rfiles, path) {
  rbuildignore <- file.path(path, ".Rbuildignore")
  if (!file.exists(rbuildignore))
    return(rfiles)

  # Strip leading directory and slashes
  rfiles_relative <- sub(normalizePath(path, winslash = "/"), "", normalizePath(rfiles, winslash = "/"), fixed = TRUE)
  rfiles_relative <- sub("^[/]*", "", rfiles_relative)

  # Remove any files that match any perl-compatible regexp
  patterns <- readLines(rbuildignore, warn = FALSE)
  matches <- lapply(patterns, grepl, rfiles_relative, perl = TRUE)
  matches <- Reduce("|", matches)
  rfiles[!matches]
}


compact <- function(x) {
  null <- vapply(x, is.null, logical(1))
  x[!null]
}

block_warning <- function(block, ...) {
  warning(
    srcref_location(block$srcref), ": ", ...,
    call. = FALSE,
    immediate. = TRUE
  )
  NULL
}

srcref_location <- function(srcref = NULL) {
  if (is.null(srcref)) return()
  paste0(basename(srcref$filename), ":", srcref$lloc[1])
}

# Parse DESCRIPTION into convenient format
read.description <- function(file) {
  dcf <- read.dcf(file, keep.white = "Authors@R")

  dcf_list <- setNames(as.list(dcf[1, ]), colnames(dcf))
  lapply(dcf_list, str_trim)
}


wrap_string <- function(x) UseMethod("wrap_string")
wrap_string.NULL <- function(x) return(x)
wrap_string.default <- function(x) {
  y <- wrapString(x)
  y <- gsub("\u{A0}", " ", y, useBytes = TRUE)
  Encoding(y) <- "UTF-8"
  class(y) <- class(x)
  y
}

invert <- function(x) {
  if (length(x) == 0) return()
  stacked <- utils::stack(x)
  tapply(as.character(stacked$ind), stacked$values, list)
}

has_colons <- function(x) {
   grepl("::", x, fixed = TRUE)
}

# Collapse the values associated with duplicated keys
collapse <- function(key, value, fun, ...) {
  stopifnot(is.character(key))
  stopifnot(length(key) == length(value))

  dedup <- tapply(value, key, fun, ..., simplify = FALSE)
  # tapply orders alphabetically, so reorder to match original order
  dedup <- dedup[unique(key)]

  list(
    key = names(dedup),
    value = unname(dedup)
  )
}