R/zzz.R

In sjPlot/strengejacke: Load Packages Associated with Strenge Jacke!

.onAttach <- function(...) {
  sj_versions <- .sj_version()
  sj_pkgs <- c("ggeffects", "sjlabelled", "sjmisc", "sjstats", "sjPlot", "esc")
  needed <- sj_pkgs[!is_attached(sj_pkgs)]

  if (length(needed) == 0) {
    return()
  }

  sj_versions <- sj_versions[sj_versions$package %in% needed, ]
  suppressPackageStartupMessages(suppressWarnings(lapply(sj_versions$package, library, character.only = TRUE, warn.conflicts = FALSE)))

  needs_update <- sj_versions$behind
  sj_versions <- sj_versions[, c("package", "local")]

  max_len_pkg <- max(nchar(sj_versions$package))
  max_len_ver <- max(nchar(sj_versions$local))

  insight::print_color("# Attaching packages", "blue")

  if (any(needs_update)) {
    insight::print_color(" (", "blue")
    insight::print_color("red", "red")
    insight::print_color(" = needs update)", "blue")
  }

  cat("\n")

  symbol_tick <- "\u2714 "
  symbol_warning <- "\u26A0 "

  for (i in 1:nrow(sj_versions)) {
    if (needs_update[i]) {
      insight::print_color(symbol_warning, "red")
    } else {
      insight::print_color(symbol_tick, "green")
    }

    cat(format(sj_versions$package[i], width = max_len_pkg))
    cat(" ")
    insight::print_color(format(sj_versions$local[i], width = max_len_ver), ifelse(needs_update[i], "red", "green"))

    if (i %% 2 == 0)
      cat("\n")
    else
      cat("   ")
  }

  cat("\n")
  .cran_checks()

  if (any(needs_update)) {
    insight::print_color("Update packages in red with 'sj_update()'.\n", "yellow")
  }
}

is_attached <- function(x) {
  paste0("package:", x) %in% search()
}



#' Update sj-packages and its dependencies from CRAN, if necessary.
#'
#' @param which String, indicates whether sj-packages (\code{which = "core"}), dependencies (\code{which = "deps"}) or both (\code{which = "all"}) should be checked for available updates.
#' @importFrom utils menu install.packages
#' @export
sj_update <- function(which = c("all", "core", "deps")) {
  which <- match.arg(which)

  if (which %in% c("all", "core")) {
    core <- .sj_version()
    behind <- core[core$behind, ]

    if (nrow(behind) == 0) {
      insight::print_color("All sj-packages are up to date!\n", "green")
      return(invisible())
    }

    message("The following packages are out of date:")
    message(paste0(" * ", format(behind$package), " (", behind$local, " -> ", behind$cran, ")"), collapse = "\n")

    message("Update now?")
    do_it <- utils::menu(c("Yes", "No")) == 1

    if (!do_it) {
      return(invisible())
    }

    # detach packages before installing
    lapply(behind$package, unloadNamespace)

    utils::install.packages(
      behind$package,
      quiet = TRUE,
      dependencies = FALSE
    )
  }

  if (which %in% c("all", "deps")) {
    deps <- .sj_deps()
    behind <- deps[deps$behind, ]

    if (nrow(behind) == 0) {
      insight::print_color("All sj-dependencies are up to date!\n", "green")
      return(invisible())
    }

    message("The following packages are out of date:")
    message(paste0(" * ", format(behind$package), " (", behind$local, " -> ", behind$cran, ")"), collapse = "\n")

    message("Update now?")
    do_it <- utils::menu(c("Yes", "No")) == 1

    if (!do_it) {
      return(invisible())
    }

    # detach packages before installing
    lapply(behind$package, unloadNamespace)

    utils::install.packages(
      behind$package,
      quiet = TRUE,
      dependencies = FALSE
    )
  }

  invisible()
}


#' @importFrom utils available.packages packageVersion
#' @importFrom tools package_dependencies
.sj_deps <- function() {
  pkgs <- utils::available.packages()

  deps <-
    tools::package_dependencies(
      c("ggeffects", "sjlabelled", "sjmisc", "sjstats", "sjPlot", "esc"),
      pkgs,
      recursive = F
    )

  pkg_deps <- unique(sort(unlist(deps)))

  base_pkgs <- c(
    "base", "compiler", "datasets", "graphics", "grDevices", "grid",
    "methods", "parallel", "splines", "stats", "stats4", "tools", "tcltk",
    "utils"
  )
  pkg_deps <- setdiff(pkg_deps, base_pkgs)

  cran_version <- lapply(pkgs[pkg_deps, "Version"], package_version)
  local_version <- lapply(pkg_deps, utils::packageVersion)

  behind <- mapply('>', cran_version, local_version)

  data.frame(
    package = pkg_deps,
    cran = sapply(cran_version, as.character),
    local = sapply(local_version, as.character),
    behind = behind,
    stringsAsFactors = FALSE
  )
}



#' @importFrom utils available.packages packageVersion
#' @importFrom tools package_dependencies
.sj_version <- function() {
  pkgs <- tryCatch(
    {
      utils::available.packages(contriburl = contrib.url("https://cloud.r-project.org", type = getOption("pkgType")))
    },
    warning = function(w) { NULL },
    error = function(e) { NULL}
  )

  sj_on_cran <- c("ggeffects", "sjlabelled", "sjmisc", "sjstats", "sjPlot", "esc")

  if (!is.null(pkgs)) {
    cran_version <- lapply(pkgs[sj_on_cran, "Version"], package_version)
    local_version <- lapply(sj_on_cran, utils::packageVersion)

    behind <- mapply('>', cran_version, local_version)

    out <- data.frame(
      package = sj_on_cran,
      cran = sapply(cran_version, as.character),
      local = sapply(local_version, as.character),
      behind = behind,
      stringsAsFactors = FALSE,
      row.names = NULL
    )
  } else {
    local_version <- lapply(sj_on_cran, utils::packageVersion)

    out <- data.frame(
      package = sj_on_cran,
      cran = NA,
      local = sapply(local_version, as.character),
      behind = FALSE,
      stringsAsFactors = FALSE,
      row.names = NULL
    )
  }
}



#' Install the strengejacke suite from github
#'
#' @importFrom devtools install_github
#' @export
install_sj_latest <- function() {
  if (requireNamespace("devtools", quietly = TRUE)) {
    devtools::install_github(
      c("strengejacke/sjlabelled",
        "strengejacke/sjstats",
        "strengejacke/sjmisc",
        "strengejacke/ggeffects",
        "strengejacke/sjPlot",
        "strengejacke/esc"
      ), upgrade = "never"
    )
  } else {
    message("Package \"devools\" required.")
  }

}


#' @importFrom xml2 read_html
#' @importFrom rvest html_table
.cran_checks <- function(full = FALSE) {
  on_cran <- c("ggeffects", "sjlabelled", "sjmisc", "sjstats", "sjPlot", "esc")
  error <- FALSE
  error_pkgs <- c()

  tryCatch(
    {
      for (i in on_cran) {
        url <- sprintf("https://cloud.r-project.org/web/checks/check_results_%s.html", i)
        html_page <- xml2::read_html(url)
        html_table <- rvest::html_table(html_page)
        check_status <- html_table[[1]]$Status

        if (isTRUE(full)) {
          all_ok <- TRUE
          max_len <- max(nchar(on_cran))
          i <- format(i, width = max_len)
          cat(sprintf("%s ", i))

          if (any("error" %in% tolower(check_status))) {
            n <- sum("error" == tolower(check_status))
            if (n == 1)
              insight::print_color("1 Error", "red")
            else
              insight::print_color(sprintf("%g Errors", n), "red")
            error <- TRUE
            all_ok <- FALSE
          }
          if (any(c("warn", "warning") %in% tolower(check_status))) {
            if (!all_ok) cat(", ")
            n <- sum("warning" == tolower(check_status)) + sum("warn" == tolower(check_status))
            if (n == 1)
              insight::print_color("1 Warning", "red")
            else
              insight::print_color(sprintf("%g Warnings", n), "red")
            error <- TRUE
            all_ok <- FALSE
          }
          if (any("note" %in% tolower(check_status))) {
            if (!all_ok) cat(", ")
            n <- sum("note" == tolower(check_status))
            if (n == 1)
              insight::print_color("1 Note", "blue")
            else
              insight::print_color(sprintf("%g Notes", n), "blue")
            all_ok <- FALSE
          }
          if (isTRUE(all_ok)) {
            insight::print_color("Ok", "green")
          }
          cat("\n")
        } else {
          if (any(c("warn", "warning", "error") %in% tolower(check_status))) {
            error_pkgs <- c(error_pkgs, i)
            error <- TRUE
          }
        }
      }

      if (error && !full) {
        insight::print_color(sprintf("Warnings or errors in CRAN checks for package(s) %s.\n", paste0("'", error_pkgs, "'", collapse = ", ")), "red")
      }

      invisible(error)
    },
    warning = function(w) { invisible(FALSE) },
    error = function(e) { invisible(FALSE) }
  )
}



#' Show CRAN check status for strengejacke-packages
#'
#' @export
CRAN_checks <- function() {
  .cran_checks(full = TRUE)
}



#' Show weeks since last package update on CRAN
#'
#' Green indicates that enough time since last submission has passed and it's ok to submit an update, yellow means it's ok, but beware it's not too often, and red means that you should probably not yet submit an update.
#'
#' @export
on_CRAN <- function() {
  if (!requireNamespace("rvest", quietly = TRUE) && !requireNamespace("xml2", quietly = TRUE)) {
    return(FALSE)
  }

  on_cran <- c("ggeffects", "sjlabelled", "sjmisc", "sjstats", "sjPlot", "esc")
  tryCatch(
    {
      for (i in on_cran) {
        url <- sprintf("https://cloud.r-project.org/web/packages/%s/index.html", i)
        html_page <- xml2::read_html(url)
        html_table <- rvest::html_table(html_page)
        published <- grepl("^Publish", html_table[[1]]$X1)
        date <- html_table[[1]]$X2[published]
        weeks_on_cran <- as.vector(difftime(as.POSIXct(Sys.Date()), as.POSIXct(date), units = "weeks"))
        max_len <- max(nchar(on_cran))
        i <- format(i, width = max_len)
        cat(sprintf("%s ", i))
        if (weeks_on_cran <= 4)
          col <- "red"
        else if (weeks_on_cran <= 8)
          col <- "yellow"
        else
          col <- "green"
        insight::print_color(sprintf("%.1f weeks\n", weeks_on_cran), col)
      }
    },
    warning = function(w) { invisible(NULL) },
    error = function(e) { invisible(NULL) }
  )

  invisible(NULL)
}