R/check-results.R

In thierrymoudiki/devtools: Tools to Make Developing R Packages Easier

parse_check_results <- function(path) {
  lines <- paste(readLines(path, warn = FALSE), collapse = "\n")

  # Strip off trailing NOTE and WARNING messages
  lines <- gsub("^NOTE: There was .*\n$", "", lines)
  lines <- gsub("^WARNING: There was .*\n$", "", lines)

  pieces <- strsplit(lines, "\n\\* ")[[1]]

  structure(
    list(
      errors = pieces[grepl("... ERROR", pieces, fixed = TRUE)],
      warnings = pieces[grepl("... WARN", pieces, fixed = TRUE)],
      notes = pieces[grepl("... NOTE", pieces, fixed = TRUE)]
    ),
    path = path,
    class = "check_results"
  )
}

signal_check_results <- function(x, on = c("none", "error", "warning", "note")) {
  has <- lapply(x, function(x) length(x) > 0)

  on <- match.arg(on)
  has_problem <- switch(on,
    none = FALSE,
    error = has$errors,
    warning = has$errors | has$warnings,
    note = has$errors | has$warnings | has$notes
  )

  if (has_problem) {
    stop(summarise_check_results(x), call. = FALSE)
  }
  invisible(TRUE)
}

#' @export
print.check_results <- function(x, ...) {
  message("R CMD check results")
  message(summarise_check_results(x))

  cat(format(x), "\n", sep = "")
  invisible(x)
}

#' @export
format.check_results <- function(x, ...) {
  checks <- trunc_middle(unlist(x))

  paste0(checks, collapse = "\n\n")
}

summarise_check_results <- function(x, colour = FALSE) {
  n <- lapply(x, length)
  paste0(
    show_count(n$errors, "error ", "errors", colour && n$errors > 0), " | ",
    show_count(n$warnings, "warning ", "warnings", colour && n$warnings > 0), " | ",
    show_count(n$notes, "note ", "notes")
  )
}

show_count <- function(n, singular, plural, is_error = FALSE) {
  out <- paste0(n, " ", ngettext(n, singular, plural))
  if (is_error && requireNamespace("cli", quietly = TRUE)) {
    out <- cli::col_red(out)
  }
  out
}


has_problems <- function(x) {
  length(x$results$errors) > 0 || length(x$results$warnings) > 0
}

first_problem <- function(x) {
  if (length(x$errors) > 0) {
    problem <- x$errors[[1]]
  } else if (length(x$warnings) > 0) {
    problem <- x$warnings[[1]]
  } else {
    return(NA_character_)
  }

  strsplit(problem, "\n", fixed = TRUE)[[1]][1]
}

trunc_middle <- function(x, n_max = 25, n_top = 10, n_bottom = 10) {
  trunc_middle_one <- function(x) {
    lines <- strsplit(x, "\n", fixed = TRUE)[[1]]
    nlines <- length(lines)

    if (nlines <= n_max) {
      return(x)
    }

    paste(c(
      lines[1:n_top],
      paste0("... ", length(lines) - n_top - n_bottom, " lines ..."),
      lines[(nlines - n_bottom):nlines]
    ), collapse = "\n")
  }

  vapply(x, trunc_middle_one, character(1), USE.NAMES = FALSE)
}

#' Parses R CMD check log file for ERRORs, WARNINGs and NOTEs
#'
#' Extracts check messages from the `00check.log` file generated by
#' `R CMD check`.
#'
#' @param path check path, e.g., value of the `check_dir` argument in a
#'   call to [check()]
#' @param error,warning,note logical, indicates if errors, warnings and/or
#'   notes should be returned
#' @return a character vector with the relevant messages, can have length zero
#'   if no messages are found
#'
#' @seealso [check()]
#' @export
check_failures <- function(path, error = TRUE, warning = TRUE, note = TRUE) {
  check_dir <- file.path(path, "00check.log")

  results <- parse_check_results(check_dir)

  c(
    if (error) results$errors,
    if (warning) results$warnings,
    if (note) results$notes
  )
}