R/utils-local.R

In pakret: Cite 'R' Packages on the Fly in 'R Markdown' and 'Quarto'

dedent <- function(x) {
  indentation <- sub("(?s)\\S*\\R(\\s*).+", "\\1", x, perl = TRUE)
  x <- gsub(paste0("(?m)^", indentation), "", x, perl = TRUE)
  trimws(x)
}

render <- function(...) {
  rmarkdown::render(..., output_format = "md_document", quiet = TRUE)
}

local_rmd <- function(lines = "", ...) {
  withr::local_tempfile(lines = lines, fileext = ".Rmd", ...)
}

local_bib <- function(lines, ...) {
  dir <- withr::local_tempfile(lines = lines, fileext = ".bib", ...)
  basename(dir)
}

local_bibs <- function(settings, ...) {
  if (settings$n == 1L) {
    return(local_bib(settings$lines, ...))
  }
  lapply(seq_len(settings$n), function(i) {
    lines <- if (i == settings$write_to) settings$lines else ""
    local_bib(lines, pattern = paste0("file_", i), ...)
  })
}

insert_bibs <- function(lines, bibs) {
  if (length(bibs) > 1L) {
    bibs <- sprintf("[%s]", paste(bibs, collapse = ", "))
  }
  sprintf(lines, bibs)
}

local_set <- function(lines = "", n = 1L, write_to = n) {
  list(lines = lines, n = n, write_to = write_to)
}

local_files <- function(rmd_lines, bib = local_set(), env = parent.frame()) {
  dir <- withr::local_tempdir(.local_envir = env)
  if (!is.null(bib)) {
    bibs <- local_bibs(bib, tmpdir = dir, .local_envir = env)
    rmd_lines <- insert_bibs(rmd_lines, bibs)
  }
  rmd <- local_rmd(rmd_lines, tmpdir = dir, .local_envir = env)
  with_pakret_error(callr::r(render, list(input = rmd)))
  invisible(dir)
}

with_pakret_error <- function(expr) {
  tryCatch(expr, error = function(e) stop(e$parent))
}

read_local_file <- function(dir, target = "md") {
  items <- strsplit(target, ".", fixed = TRUE)[[1]]
  if (length(items) == 1L) {
    items <- c("", items)
  }
  pattern <- do.call(sprintf, c("^%s.+\\.%s$", as.list(items)))
  file <- list.files(dir, pattern = pattern, full.names = TRUE)
  readr::read_file(file)
}

local_pkg <- function(Package, ..., bib_entries = NULL, env = parent.frame()) {
  dir <- withr::local_tempdir(.local_envir = env)
  withr::local_libpaths(dir, action = "prefix", .local_envir = env)
  pkg_path <- file.path(dir, Package)
  create_package(pkg_path, Package, ...)
  if (!is.null(bib_entries)) {
    lines <- make_bib_entries(bib_entries)
    add_bib_entries(pkg_path, lines)
  }
  load_pkg(pkg_path, env)
  invisible(pkg_path)
}

create_package <- function(path, Package, ...) {
  usethis::ui_silence(
    usethis::create_package(
      path = path,
      fields = list(Type = "Package", Package = Package, ...),
      rstudio = FALSE,
      open = FALSE
    )
  )
}

add_bib_entries <- function(dir, lines) {
  path <- file.path(dir, "inst", "CITATION")
  dir.create(dirname(path))
  readr::write_file(lines, path)
}

make_bib_entries <- function(types) {
  bib <- 'bibentry("%s", title = "title", author = "authors", year = "year",%s)'
  entries <- lapply(tolower(types), function(type) {
    sprintf(bib, type, switch_bib_field(type))
  })
  collapse(entries)
}

switch_bib_field <- function(x) {
  switch(x,
    article = bib_field("journal"),
    book = bib_field("publisher"),
    ""
  )
}

bib_field <- function(name) {
  sprintf('%s = "%s"', name, name)
}

load_pkg <- function(path, env) {
  withr::defer(pkgload::unload(basename(path), quiet = TRUE), envir = env)
  pkgload::load_all(path, export_all = FALSE, quiet = TRUE)
}

load_foo <- function(..., env = parent.frame()) {
  local_pkg(
    Package = "foo",
    Title = "Alea Jacta Est",
    `Authors@R` = c(
      utils::person("Caius", "Fastandfurius", role = "aut"),
      utils::person("Numerius", "Clausus", role = "aut"),
      utils::person("Marcus", "Lastopus", role = "aut")
    ),
    Version = "1.0.0",
    Date = "2020-01-01",
    ...,
    env = env
  )
}

load_bar <- function(..., env = parent.frame()) {
  local_pkg(
    Package = "bar",
    Title = "Tempus Edax Rerum",
    `Authors@R` = utils::person("Julius", "Itisalapsus", role = "aut"),
    Version = "0.2.0",
    Date = "2024-01-01",
    ...,
    env = env
  )
}