R/utils.R

In roxygen2: In-Line Documentation for R

internal_f <- function(p, f) {
  check_string(p)
  check_string(f)

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

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

subs <- 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-"
)

nice_name <- function(x) {
  for (i in seq_along(subs)) {
    x <- gsub(names(subs)[[i]], subs[[i]], x, fixed = TRUE)
  }

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

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

  name <- basename(path)
  if (check && !made_by_roxygen(path)) {
    cli::cli_inform(c(
      x = "Skipping {.href [{name}](file://{path})}",
      i = "It already exists and was not generated by {.pkg roxygen2}."
    ))
    return(FALSE)
  }

  line_ending <- detect_line_ending(path)
  contents <- paste0(paste0(contents, collapse = line_ending), line_ending)
  contents <- enc2utf8(gsub("\r?\n", line_ending, contents))
  if (same_contents(path, contents)) {
    # Touch so mtime reflects last run, even though file wasn't changed
    Sys.setFileTime(path, Sys.time())
    return(FALSE)
  }

  if (!grepl("^[a-zA-Z][a-zA-Z0-9_.-]*$", name)) {
    cli::cli_inform(c(
      x = "Skipping {.path {name}}",
      i = "Invalid file name"
    ))
    FALSE
  } else {
    if (!is.null(command)) {
      scheme <- "x-r-run"
      url <- paste0(scheme, ":", command)
      name <- cli::style_hyperlink(name, url)
    }
    cli::cli_inform("Writing {.path {name}}")

    writeBin(charToRaw(contents), path)
    TRUE
  }
}

same_contents <- function(path, contents) {
  if (length(contents) != 1) {
    cli::cli_abort("{.arg contents} must be a single string.", .internal = TRUE)
  }
  if (!file.exists(path)) {
    return(FALSE)
  }

  text_hash <- cli::hash_sha256(contents)

  path <- normalizePath(path, mustWork = TRUE)
  file_hash <- cli::hash_file_sha256(path)

  identical(text_hash, file_hash)
}

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

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

is_namespaced <- function(x) {
  tryCatch(
    {
      expr <- parse_expr(x)
      is_call(expr, "::", n = 2)
    },
    error = function(err) FALSE
  )
}

# Collapse the values associated with duplicated keys
collapse <- function(key, value, fun, ...) {
  check_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)
  )
}

cat_line <- function(...) {
  cat(paste0(..., "\n", collapse = ""))
}

tag_aliases <- function(f) {
  paste0("@aliases ", paste0("@", names(f()), collapse = " "))
}

pkg_env <- function() {
  env <- new.env(parent = globalenv())
  env$.packageName <- "roxygen2"
  env
}

uuid <- function(nchar = 8) {
  paste(
    sample(c(letters, LETTERS, 0:9), nchar, replace = TRUE),
    collapse = ""
  )
}

paste_c <- function(...) {
  paste(c(...), collapse = "")
}

# quoting -----------------------------------------------------------------
auto_backtick <- function(x) {
  needs_backtick <- !has_quotes(x) & !is_syntactic(x)
  x[needs_backtick] <- encodeString(x[needs_backtick], quote = "`")
  x
}

auto_quote <- function(x) {
  needs_quotes <- !has_quotes(x) & !is_syntactic(x)
  x[needs_quotes] <- encodeString(x[needs_quotes], quote = '"')
  x
}

re_split_half <- function(x, pattern) {
  m <- regexpr(pattern, x)
  if (m > 0L) {
    left <- substr(x, 1, m - 1)
    right <- substr(x, m + attr(m, "match.length"), nchar(x))
  } else {
    left <- x
    right <- ""
  }
  c(left, right)
}

re_count <- function(x, pattern, fixed = FALSE) {
  m <- gregexpr(pattern, x, fixed = fixed)
  vapply(m, \(i) sum(i > 0L), integer(1))
}

re_replace_all <- function(x, pattern, fun) {
  m <- gregexpr(pattern, x, perl = TRUE)
  regmatches(x, m) <- lapply(regmatches(x, m), \(matches) {
    vapply(matches, fun, character(1))
  })
  x
}

is_syntactic <- function(x) make.names(x) == x
has_quotes <- function(x) grepl(r"[^(`|'|").*\1$]", x)
strip_quotes <- function(x) sub(r"[^(`|'|")(.*)\1$]", r"(\2)", x)