R/utils_sitrep.R

In nflreadr: Download 'nflverse' Data

#' Get a Situation Report on System, nflverse/ffverse Package Versions and Dependencies
#'
#' This function gives a quick overview of the versions of R and the operating
#' system as well as the versions of nflverse/ffverse packages, options, and their dependencies.
#' It's primarily designed to help you get a quick idea of what's going on when
#' you're helping someone else debug a problem.
#'
#' @param pkg a character vector naming installed packages, or `NULL`
#'   (the default) meaning all nflverse packages. The function checks internally
#'   if all packages are installed and informs if that is not the case.
#' @param recursive a logical indicating whether dependencies of `pkg` and their
#'  dependencies (and so on) should be included.
#'  Can also be a character vector listing the types of dependencies, a subset
#'  of `c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances")`.
#'  Character string `"all"` is shorthand for that vector, character string
#'  `"most"` for the same vector without `"Enhances"`, character string `"strong"`
#'  (default) for the first three elements of that vector.
#' @param redact_path a logical indicating whether options that contain "path"
#' in the name should be redacted, default = TRUE
#' @param dev_repos Developmental cran-like repos to check, e.g. r-universe repos
#' @examples
#' \dontshow{.for_cran()}
#' \donttest{
#' try({
#' nflverse_sitrep()
#' ffverse_sitrep()
#' .sitrep("cachem")
#' })
#' }
#' @rdname sitrep
#' @export
nflverse_sitrep <- function(pkg = c("nflreadr","nflfastR","nflseedR","nfl4th","nflplotR","nflverse"),
                            recursive = TRUE,
                            redact_path = TRUE) {
  .sitrep(pkg = pkg, recursive = recursive, redact_path = redact_path, dev_repos = "https://nflverse.r-universe.dev")
}

#' @rdname sitrep
#' @export
ffverse_sitrep <- function(pkg = c("ffscrapr", "ffsimulator", "ffpros", "ffopportunity"),
                           recursive = TRUE,
                           redact_path = TRUE) {
  .sitrep(pkg = pkg, recursive = recursive, redact_path = redact_path, dev_repos = "https://ffverse.r-universe.dev")
}

#' @rdname sitrep
#' @export
.sitrep <- function(pkg, recursive = TRUE, redact_path = TRUE, dev_repos = c("https://nflverse.r-universe.dev", "https://ffverse.r-universe.dev")){

  out <- structure(
    list(
      system_info = list(),
      installed = list(),
      dependencies = list(),
      package_options = list(),
      not_installed = list(),
      packages = pkg,
      timestamp = Sys.time()
    ),
    class = c("nflverse_sitrep", "list")
  )

  # OPERATING SYSTEM INFO
  out$system_info <- list(
    r_version = R.version$version.string,
    os_version = utils::osVersion
  )
  packages <- pkg

  inst_pkgs <- data.table::as.data.table(utils::installed.packages())

  out$not_installed <- packages[!packages %in% inst_pkgs$Package]
  packages <- packages[packages %in% inst_pkgs$Package]

  if (length(packages) == 0) return(out)

  out$installed <- .sitrep_pkg_status(packages = packages,
                                      inst_pkgs = inst_pkgs,
                                      dev_repos = dev_repos,
                                      check_latest = TRUE)

  # Relies on options for a given package being prefixed by said package name
  out$package_options <- .sitrep_pkg_opts(packages, redact_path = redact_path)

  # Exit here if we don't want pkg deps
  if (isFALSE(recursive)) return(out)

  out$dependencies <- .sitrep_pkg_deps(packages = packages,
                                       inst_pkgs = inst_pkgs,
                                       recursive = recursive)

  return(out)
}

.sitrep_pkg_status <- function(packages,
                               inst_pkgs = utils::installed.packages(),
                               dev_repos = c("https://nflverse.r-universe.dev", "https://ffverse.r-universe.dev"),
                               check_latest = curl::has_internet()){

  inst_pkgs <- data.table::as.data.table(inst_pkgs)
  Package <- Version <- NULL
  inst <- inst_pkgs[Package %in% packages][, list(package = Package, installed = Version, cran = NA, dev = NA, behind = NA)]
  if (!curl::has_internet() || !check_latest) return(as.data.frame(inst))

  cran_repos <- c("https://packagemanager.posit.co/cran/latest", "https://cloud.r-project.org", "https://cran.rstudio.com")
  cran_pkgs <- data.table::as.data.table(utils::available.packages(repos = cran_repos))[Package %in% packages, list(package = Package, cran = Version)]
  dev_pkgs <- data.table::as.data.table(utils::available.packages(repos = dev_repos))[Package %in% packages, list(package = Package, dev = Version)]

  package <- installed <- cran <- dev <- behind_cran <- behind_dev <- behind <- NULL

  inst <- merge(
    merge(
      inst[, list(package, installed)],
      cran_pkgs,
      by = "package",
      all = TRUE
    ),
    dev_pkgs,
    all = TRUE,
    by = "package"
  )[
    , list(
      package, installed, cran, dev,
      behind_cran = ifelse(!is.na(cran), package_version(installed, strict = FALSE) < package_version(cran, strict = FALSE), FALSE),
      behind_dev = ifelse(!is.na(dev), package_version(installed, strict = FALSE) < package_version(dev, strict = FALSE), FALSE)
    )
  ][
    , list(
      package, installed, cran, dev,
      behind = paste0(ifelse(behind_cran, "cran;", ""), ifelse(behind_dev, "dev", "")),
      behind_cran = NULL,
      behind_dev = NULL
    )
  ]



  return(as.data.frame(inst))
}

#' Show options for installed packages
#' @keywords internal
.sitrep_pkg_opts <- function(packages, redact_path = TRUE){
  opts <- options()
  pkg_search_string <- paste(packages, collapse = "|")
  package_options <- opts[grepl(pkg_search_string, x = names(opts))]
  if(redact_path) {
    package_options[grepl("path|token|auth", names(package_options))] <- "{redacted, use redact_path = FALSE to show}"
  }
  return(package_options)
}

#' Show dependency versions of installed packages
#' @keywords internal
.sitrep_pkg_deps <- function(packages, inst_pkgs = utils::installed.packages(), recursive = TRUE){

  inst_pkgs <- data.table::as.data.table(inst_pkgs)
  .flatten <- function(x) sort(unique(unlist(x, use.names = FALSE)))
  deps <- .flatten(tools::package_dependencies(packages, db = inst_pkgs, recursive = recursive))

  deps <- deps[!deps %in% packages]
  missing_pkgs <- setdiff(deps, inst_pkgs$Package)

  dep_status <- inst_pkgs[inst_pkgs$Package %in% deps][, c("Package", "Version")]
  data.table::setnames(dep_status, c("package","version"))

  if(length(missing_pkgs) > 0) {
    dep_status <- data.table::rbindlist(
      list(
        dep_status,
        data.table::data.table(package = missing_pkgs, version = "missing")
      )
    )
  }

  return(as.data.frame(dep_status))
}

#' nflverse_sitrep data class
#'
#' `nflverse_sitrep()` returns an S3 class that was created to allow for custom
#' printing. It will otherwise dispatch to the `list` class.
#'
#' Re-exporting with `methods::setOldClass()` allows these dataframes to be used
#' in S4 generics like those from DBI and jsonlite.
#'
#' @name nflverse_sitrep-class
#' @keywords internal
#' @exportClass nflverse_sitrep
methods::setOldClass("nflverse_sitrep", "list")

#' @export
#' @noRd
print.nflverse_sitrep <- function(x, ...) {
  cli::cat_rule(cli::style_bold("System Info"), col = cli::make_ansi_style("cyan"), line = 1)
  cli::cat_bullet(glue::glue("{x$system_info$r_version} {cli::symbol$bullet} Running under: {x$system_info$os_version}")) # nolint

  cli::cat_rule(cli::style_bold("Package Status"), col = cli::make_ansi_style("cyan"), line = 1)
  if(nrow(x$installed) > 0) {
    print(x$installed)
  }

  cli::cat_rule(cli::style_bold("Package Options"), col = cli::make_ansi_style("cyan"), line = 1)
  if (length(x$package_options) == 0) cli::cat_bullet("No options set for above packages")
  if (length(x$package_options) > 0) .cat_options(names(x$package_options), unname(x$package_options))

  if (length(x$dependencies) >= 1) {
    cli::cat_rule(cli::style_bold("Package Dependencies"), col = cli::make_ansi_style("cyan"), line = 1)
    .cat_pkg(x$dependencies$package, x$dependencies$version)
  }

  if (length(x$not_installed) >= 1) {
    cli::cat_rule(cli::style_bold("Not Installed"), col = cli::make_ansi_style("cyan"), line = 1)
    .cat_pkg(x$not_installed, rep_len("", length(x$not_installed)))
  }

  cli::cat_rule(col = cli::make_ansi_style("cyan"), line = 1)

  return(invisible(x))
}

.cat_pkg <- function(packages, versions) {
  stopifnot(length(packages) == length(versions))

  if (length(packages) <= 2) {
    cli::cat_bullet(glue::glue("{format(packages)} ({format(versions)})"))
    return(invisible())
  }

  l <- length(packages)

  breaks <- cut(
    x = seq_along(packages),
    breaks = c(0, ceiling(l / 3), 2 * ceiling(l / 3), l + 1)
  )

  p <- split(packages, breaks)
  v <- split(versions, breaks)

  r <- length(p[[1]]) - length(p[[3]])

  if (r != 0) {
    p[[3]] <- c(p[[3]], rep("", r))
    v[[3]] <- c(v[[3]], rep("", r))
  }

  p <- lapply(p, function(x) ifelse(x != "", format(paste(cli::symbol$bullet, x)), ""))
  v <- lapply(v, function(x) ifelse(x != "", format(paste0(" (", x, ")")), ""))

  cli::cat_line(
    paste0(
      p[[1]], v[[1]], "  ",
      p[[2]], v[[2]], "  ",
      p[[3]], v[[3]], "  "
    )
  )
}

.cat_options <- function(option_names, option_values) {
  stopifnot(length(option_names) == length(option_values))
  cli::cat_bullet(glue::glue("{format(option_names)}: {format(option_values)}"))
}