Run package examples, allowing for possibly multiple failures

check_examples.R

#' Run a package's examples, allowing tolerance for failures
#'
#' @noRd
.RunExamples <- function(man_dir, timeout = 60) {
  # It appears the result order is not stable; sort to ensure this
  rd_files <- sort(dir(man_dir, full.names = TRUE, pattern = "\\.[Rr]d$"))

  if (length(rd_files) == 0L) {
    cat("No examples to run.\n")
    return(list())
  }

  names(rd_files) <- basename(rd_files)

  package_name <- basename(dirname(man_dir))

  cat(sprintf("Running examples from %d help files\n", length(rd_files)))
  on.exit(cat("\n"))
  return(lapply(
    rd_files,
    .RunExample,
    package_name,
    timeout
  ))
}

#' Run one single example, including boilerplate code
#' @noRd
.RunExample <- function(rd_file, package_name, timeout) {
  sink_file <- tempfile()
  on.exit(unlink(sink_file))

  r_tmp <- tempfile()
  tools::Rd2ex(rd_file, r_tmp, commentDonttest = TRUE)
  on.exit(unlink(r_tmp), add = TRUE)

  # no examples in .Rd --> no file created.
  if (!file.exists(r_tmp)) {
    cat(".")
    return(invisible())
  }

  rd_expr <- tryCatch(parse(r_tmp), error = identity)
  if (inherits(rd_expr, "error")) {
    cat("x")
    return(c(readLines(r_tmp), "EXAMPLE FAILED TO PARSE, CHECK SYNTAX"))
  } else if (length(rd_expr) == 0L) {
    # no expressions in .Rd --> everything is commented out (e.g. \dontrun{}),
    #   in which case no need to waste effort running boilerplate code.
    cat(".")
    return(invisible())
  }

  r_file <- file.path(tempdir(), gsub("\\.Rd$", ".R", basename(rd_file)))
  writeLines(
    c(
      .HeaderBoilerplate(rd_file, package_name),
      readLines(r_tmp),
      .FooterBoilerplate()
    ),
    r_file
  )
  on.exit(unlink(r_file), add = TRUE)

  # imitating R CMD check here. Or at least the essential parts. Bring
  #   garlic and your favorite holy text if you plan to understand all that
  #   R CMD check is doing.
  return_value <- system2(
    file.path(R.home("bin"), "R"),
    c("--vanilla", "--encoding=UTF-8"),
    env = c("LANGUAGE=en", "_R_CHECK_INTERNALS2_=1"),
    stdout = sink_file,
    stderr = sink_file,
    stdin = r_file,
    timeout = timeout
  ) |>
    tryCatch(warning = identity)

  # example timed out
  if (inherits(return_value, "warning")) {
    cat("x")
    return(c(
      .ExtractExampleFailures(sink_file),
      "",
      paste("EXAMPLE TIMED OUT IN", timeout, "SECONDS.")
    ))
  }

  # example succeeded
  if (return_value == 0L) {
    cat("o")
    return(invisible())
  }

  # example failed
  cat("x")
  return(.ExtractExampleFailures(sink_file))
}

.kHeaderBoilerplateMarker <- "*** END HEADER BOILERPLATE ***"

#' Code to run before each example
#'
#' Inspired by how `R CMD check` itself runs examples, see
#'   //third_party/R/R/R_x_y_z/share/R/examples-{header,footer}.R
#'   as well as `tools:::massageExamples()` (or better yet, debug
#'   `tools:::R_runR()` and then run `tools:::.check_packages()`)
#' @noRd
.HeaderBoilerplate <- function(rd_file, package_name) {
  return(c(
    # Required for any code that refers to `.Random.seed`, which is
    #   only created the first time the seed is set in the session.
    "set.seed(400413)",
    "options(warn = 1)",
    sprintf("library(%s)", package_name),
    "flush(stderr())",
    "flush(stdout())",
    paste("#", .kHeaderBoilerplateMarker)
  ))
}

.FooterBoilerplate <- function() {
  return(c(
    "# *** START FOOTER BOILERPLATE ***",
    "try(grDevices::dev.off(), silent = TRUE)",
    "quit('no')"
  ))
}

.ExtractExampleFailures <- function(sink_file) {
  output <- readLines(sink_file)

  end_boilerplate <- grep(.kHeaderBoilerplateMarker, output, fixed = TRUE)
  # This can only happen if the boilerplate itself failed to finish
  if (length(end_boilerplate) == 0L) end_boilerplate <- 0L

  # R error message is printed, then R itself stops: 'Execution halted'
  process_stop <- grep("^Execution halted", output)
  # This happens if R crashes unexpectedly (e.g. segfault):
  if (length(process_stop) == 0L) process_stop <- length(output) + 1L

  # only expect there to be one value, but force length-1 just in case
  first_line <- end_boilerplate[1L] + 1L
  final_line <- process_stop[1L] - 1L

  # more escape valves -- neither of these should apply
  if (final_line < 1L) {
    return(paste(
      "Running example failed unexpectedly",
      "('Execution halted' occurs before line 3); full output:",
      paste(output, collapse = "\n")
    ))
  }
  if (first_line > final_line) first_line <- 1L

  return(output[first_line:final_line])
}