Merge pull request #40 from mrc-ide/mrc-4787

Report on current configuration

DESCRIPTION

@@ -25,7 +25,6 @@ Suggests:
     conan2,
     logwatch,
     mockery,
-    ps,
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Remotes:

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,hipercow_environment)
+export(hipercow_configuration)
 export(hipercow_configure)
 export(hipercow_driver)
 export(hipercow_environment_create)

R/configuration.R

@@ -0,0 +1,144 @@
+##' Report on your hipercow configuration.  We will always want you to
+##' post this along side any problems; it has lots of useful
+##' information in it that will help us see how your set up is
+##' configured.
+##'
+##' @title Report on hipercow configuration
+##'
+##' @inheritParams hipercow_configure
+##'
+##' @param show Display the configuration to the screen
+##'
+##' @return A list with a machine readable form of this information,
+##'   invisibly.
+##'
+##' @export
+hipercow_configuration <- function(show = TRUE, root = NULL) {
+  root <- hipercow_root(root)
+  data <- configuration_data(root)
+  if (show) {
+    configuration_render(data)
+  }
+  invisible(data)
+}
+
+
+configuration_platform <- function() {
+  info <- Sys.info()
+  list("R" = getRversion(),
+       system = info[["sysname"]],
+       host = info[["nodename"]],
+       user = info[["user"]])
+}
+
+
+configuration_packages <- function() {
+  hipercow <- package_version_if_installed("hipercow")
+
+  nms <- c("hipercow.windows", "conan2", "logwatch")
+  pkgs <- set_names(lapply(nms, package_version_if_installed), nms)
+
+  notes <- c()
+  for (pkg in c("hipercow.windows", "conan2")) {
+    if (is.null(pkgs[[pkg]])) {
+      notes <- c(notes, "x" = sprintf("%s is not installed", pkg))
+    }
+  }
+  pkgs <- pkgs[!vapply(pkgs, is.null, TRUE)]
+  warn_version <- !is.null(pkgs$hipercow.windows) &&
+    pkgs$hipercow.windows != hipercow
+  if (warn_version) {
+    notes <- c(notes,
+               "!" = "hipercow and hipercow.windows have different versions")
+  }
+  list(hipercow = hipercow, others = pkgs, notes = notes)
+}
+
+
+configuration_paths <- function(root) {
+  list(root = root$path$root,
+       working = getwd(),
+       path = relative_workdir(root$path$root))
+}
+
+
+configuration_drivers <- function(root) {
+  root$config
+}
+
+
+configuration_environments <- function(root) {
+  lapply(hipercow_environment_list(), environment_load, root = root)
+}
+
+
+configuration_data <- function(root) {
+  list(platform = configuration_platform(),
+       packages = configuration_packages(),
+       paths = configuration_paths(root),
+       environments = configuration_environments(root),
+       drivers = configuration_drivers(root))
+}
+
+
+configuration_render <- function(data) {
+  cli::cli_h1("hipercow root at {data$paths$root}")
+  configuration_render_paths(data$paths)
+  configuration_render_platform(data$platform)
+  configuration_render_packages(data$packages)
+  configuration_render_environments(data$environments)
+  configuration_render_drivers(data$drivers)
+}
+
+
+configuration_render_paths <- function(paths) {
+  cli::cli_alert_success("Working directory '{paths$path}' within root")
+}
+
+
+configuration_render_platform <- function(platform) {
+  cli::cli_alert_info(
+    paste("R version {platform$R} on {platform$system}",
+          "({platform$user}@{platform$host})"))
+}
+
+
+configuration_render_packages <- function(packages) {
+  cli::cli_h2("Packages")
+  cli::cli_alert_info("This is hipercow {packages$hipercow}")
+  versions_str <- sprintf("%s (%s)",
+                          names(packages$others),
+                          vcapply(packages$others, format))
+  cli::cli_alert_info("Installed: {paste(versions_str, collapse = ', ')}")
+  cli::cli_bullets(packages$notes)
+}
+
+
+configuration_render_environments <- function(environments) {
+  cli::cli_h2("Environments")
+  for (el in environments) {
+    cli::cli_h3(el$name)
+    print(el, header = FALSE)
+  }
+}
+
+
+configuration_render_drivers <- function(drivers) {
+  cli::cli_h2("Drivers")
+  n <- length(drivers)
+  if (n == 0) {
+    cli::cli_alert_danger("No drivers configured")
+  } else {
+    cli::cli_alert_success(
+      "{n} {cli::qty(n)}driver{?s} configured ({squote(names(drivers))})")
+    for (nm in names(drivers)) {
+      cli::cli_h3(nm)
+      config <- drivers[[nm]]
+      for (i in names(config)) {
+        el <- format(config[[i]])
+        cli::cli_li("{.strong {i}}: {el[[1]]}")
+        cli::cli_bullets(el[-1])
+      }
+    }
+  }
+}

R/configure.R

@@ -1,5 +1,5 @@
 ##' Configure your hipercow root.  `hipercow_configure` creates the
-##' configuration and `hipercow_get_configuration` looks it up.
+##' configuration and `hipercow_configuration` looks it up.
 ##'
 ##' @title Configure your hipercow root
 ##'

R/environment.R

@@ -96,6 +96,7 @@ hipercow_environment_show <- function(name = "default", root = NULL) {
   print(env)
 }
 
+
 ##' @export
 ##' @rdname hipercow_environment
 hipercow_environment_exists <- function(name = "default", root = NULL) {
@@ -106,8 +107,10 @@ hipercow_environment_exists <- function(name = "default", root = NULL) {
 
 
 ##' @export
-print.hipercow_environment <- function(x, ...) {
-  cli::cli_h1("hipercow environment '{x$name}'")
+print.hipercow_environment <- function(x, ..., header = TRUE) {
+  if (header) {
+    cli::cli_h1("hipercow environment '{x$name}'")
+  }
   if (length(x$packages) == 0) {
     cli::cli_li("packages: {.emph (none)}")
   } else {
@@ -133,7 +136,7 @@ print.hipercow_environment <- function(x, ...) {
 environment_load <- function(name, root, call = NULL) {
   path <- ensure_environment_exists(name, root, call)
   if (is.null(path)) {
-   new_environment(name, NULL, NULL, NULL, root)
+    new_environment(name, NULL, NULL, NULL, root)
   } else {
     readRDS(path)
   }

R/util.R

@@ -88,6 +88,11 @@ format_bytes <- function(x) {
 }
 
 
+package_version_if_installed <- function(name) {
+  tryCatch(utils::packageVersion(name),
+           error = function(e) NULL)
+}
+
 eval_with_hr <- function(expr, title, verbose) {
   if (verbose) {
     cli::cli_rule(right = "{title} {cli::symbol$arrow_down}")

drivers/windows/NAMESPACE

@@ -3,6 +3,7 @@
 S3method(as.character,password)
 S3method(as.character,windows_path)
 S3method(format,dide_clusterload)
+S3method(format,dide_shares)
 S3method(print,dide_clusterload)
 S3method(print,password)
 S3method(print,windows_path)

drivers/windows/R/mounts.R

@@ -7,10 +7,19 @@ dide_cluster_paths <- function(shares, path_root) {
     shares[[i]]$path_remote <- use_app_on_nas_south_ken(shares[[i]]$path_remote)
   }
 
+  class(shares) <- "dide_shares"
   shares
 }
 
 
+##' @export
+format.dide_shares <- function(x, ...) {
+  n <- length(x)
+  c(sprintf("%d configured:", n),
+    set_names(vcapply(x, as.character), rep(">", n)))
+}
+
+
 detect_mounts <- function() {
   if (is_windows()) {
     detect_mounts_windows()

drivers/windows/tests/testthat/test-config.R

@@ -9,9 +9,13 @@ test_that("Can create configuration", {
     c("cluster", "template", "shares", "r_version", "path_lib"))
   expect_equal(config$cluster, "wpia-hn")
   expect_equal(config$template, "AllNodes")
-  expect_equal(config$shares, list(shares))
+  expect_equal(config$shares, structure(list(shares), class = "dide_shares"))
   expect_equal(config$r_version, numeric_version("4.3.0"))
   expect_equal(config$path_lib, "hipercow/lib/windows/4.3.0")
+  expect_equal(
+    format(config$shares),
+    c("1 configured:",
+      ">" = as.character(config$shares[[1]])))
 })
 
 

tests/testthat/test-configuration.R

@@ -0,0 +1,99 @@
+test_that("can report on configuration", {
+  path <- withr::local_tempfile()
+  init_quietly(path)
+  path <- normalize_path(path)
+  root <- hipercow_root(path)
+  res <- evaluate_promise(
+    withr::with_dir(path, hipercow_configuration()))
+
+  cfg <- res$result
+  expect_type(cfg, "list")
+  expect_equal(names(cfg),
+               c("platform", "packages", "paths", "environments", "drivers"))
+  expect_equal(cfg$platform, configuration_platform())
+  expect_equal(cfg$packages, configuration_packages())
+  expect_equal(cfg$paths, withr::with_dir(path, configuration_paths(root)))
+  expect_equal(cfg$drivers, configuration_drivers(root))
+  expect_silent(
+    withr::with_dir(path, hipercow_configuration(show = FALSE)))
+
+  expect_null(cfg$drivers)
+
+  cmp <- withVisible(
+    withr::with_dir(path, hipercow_configuration(show = FALSE)))
+  expect_equal(cmp$value, cfg)
+  expect_false(cmp$visible)
+})
+
+
+test_that("can report on configuration with a driver configured", {
+  elsewhere_register()
+  path_here <- withr::local_tempdir()
+  path_there <- withr::local_tempdir()
+  init_quietly(path_here)
+  init_quietly(path_there)
+  root <- hipercow_root(path_here)
+  suppressMessages(
+    hipercow_configure("elsewhere", path = path_there, root = path_here))
+
+  res <- evaluate_promise(
+    withr::with_dir(path_here, hipercow_configuration()))
+  cfg <- res$result
+  expect_type(cfg, "list")
+  expect_equal(names(cfg),
+               c("platform", "packages", "paths", "environments", "drivers"))
+  expect_equal(cfg$platform, configuration_platform())
+  expect_equal(cfg$packages, configuration_packages())
+  expect_equal(cfg$paths, withr::with_dir(path_here, configuration_paths(root)))
+  expect_equal(cfg$drivers, configuration_drivers(root))
+  expect_silent(
+    withr::with_dir(path_here, hipercow_configuration(show = FALSE)))
+
+  expect_equal(cfg$drivers, list(elsewhere = root$config$elsewhere))
+
+  cmp <- withVisible(
+    withr::with_dir(path_here, hipercow_configuration(show = FALSE)))
+  expect_equal(cmp$value, cfg)
+  expect_false(cmp$visible)
+})
+
+
+test_that("can report about package version problems", {
+  mock_version <- mockery::mock(1, 2, 3, 4)
+  mockery::stub(configuration_packages, "package_version_if_installed",
+                mock_version)
+  res <- configuration_packages()
+  expect_equal(res$hipercow, 1)
+  expect_equal(res$others, list(hipercow.windows = 2, conan2 = 3, logwatch = 4))
+  expect_equal(
+    res$notes,
+    c("!" = "hipercow and hipercow.windows have different versions"))
+})
+
+
+test_that("can report about missing packages", {
+  mock_version <- mockery::mock(1, 2, NULL, NULL)
+  mockery::stub(configuration_packages, "package_version_if_installed",
+                mock_version)
+  res <- configuration_packages()
+  expect_equal(res$hipercow, 1)
+  expect_equal(res$others, list(hipercow.windows = 2))
+  expect_equal(
+    res$notes,
+    c("x" = "conan2 is not installed",
+      "!" = "hipercow and hipercow.windows have different versions"))
+})
+
+
+test_that("can report about everything being missing", {
+  mock_version <- mockery::mock(1, NULL, NULL, NULL)
+  mockery::stub(configuration_packages, "package_version_if_installed",
+                mock_version)
+  res <- configuration_packages()
+  expect_equal(res$hipercow, 1)
+  expect_equal(res$others, set_names(list(), character()))
+  expect_equal(
+    res$notes,
+    c("x" = "hipercow.windows is not installed",
+      "x" = "conan2 is not installed"))
+})