Merge pull request #10 from mrc-ide/prototype-drivers

Tidy up approach to drivers

NAMESPACE

@@ -1,9 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
 export(hermod_configure)
-export(hermod_get_configuration)
+export(hermod_driver)
 export(hermod_init)
 export(hermod_task_create_explicit)
 export(hermod_task_eval)
 export(hermod_task_result)
 export(hermod_task_status)
+export(hermod_task_submit)

R/configure.R

@@ -0,0 +1,126 @@
+##' Configure your hermod root.  `hermod_configure` creates the
+##' configuration and `hermod_get_configuration` looks it up.
+##'
+##' @title Configure your hermod root
+##'
+##' @param driver The hermod driver; probably you want this to be
+##'   `"windows"` as that is all we support at the moment!
+##'
+##' @param ... Arguments passed to your driver. We'll work out how to
+##'   point you at appropriate documentation once it is written.
+##'
+##' @param root Hermod root, usually best `NULL`
+##'
+##' @export
+hermod_configure <- function(driver, ..., root = NULL) {
+  root <- hermod_root(root)
+
+  assert_scalar_character(driver)
+  dr <- hermod_driver_load(driver)
+  config <- withr::with_dir(root$path$root, dr$configure(...))
+
+  fs::dir_create(root$path$config)
+  if (is.null(root$config)) {
+    root$config <- list()
+  }
+
+  saveRDS(config, file.path(root$path$config, paste0(driver, ".rds")))
+  root$config[[driver]] <- config
+
+  invisible()
+}
+
+
+##' Create a new hermod driver; this is intended to be used from other
+##' packages, and rarely called directly. If you are trying to run
+##' tasks on a cluster you do not need to call this!
+##'
+##' @param configure Function used to set core configuration for the
+##'   driver.  This function will be called from the hermod root
+##'   directory (so `getwd()` will report the correct path). It can
+##'   take any arguments, do any calculation and then must return any
+##'   R object that can be serialised.  The resulting configuration
+##'   will be passed in as `config` to other driver functions.
+##'
+##' @param submit Submit a task to a cluster.  This is run after the
+##'   task is created (either automatically or manually) and takes as
+##'   arguments the task id, the configuration, the path to the root.
+##'
+##' @export
+hermod_driver <- function(configure, submit) {
+  structure(list(configure = configure,
+                 submit = submit),
+            class = "hermod_driver")
+}
+
+
+hermod_driver_load <- function(driver, call) {
+  if (is.null(cache$drivers[[driver]])) {
+    valid <- "windows"
+    assert_scalar_character(driver)
+    if (!(driver %in% valid)) {
+      cli::cli_abort(c("Invalid driver '{driver}'",
+                       i = "Valid choice{? is/s are}: {squote(valid)}"),
+                     call = call)
+    }
+    cache$drivers[[driver]] <- hermod_driver_create(driver)
+  }
+  cache$drivers[[driver]]
+}
+
+
+hermod_driver_create <- function(name) {
+  pkg <- sprintf("hermod.%s", name)
+  ns <- ensure_package(pkg)
+  target <- sprintf("hermod_driver_%s", name)
+
+  ## Users should never see these errors, we are in control of our own
+  ## drivers; these just help us if we're writing new ones.
+  stopifnot(is.function(ns[[target]]))
+  result <- ns[[target]]()
+  stopifnot(inherits(result, "hermod_driver"))
+  result
+}
+
+
+hermod_driver_select <- function(name, root, call = NULL) {
+
+  valid <- names(root$config)
+  if (is.null(name)) {
+    if (length(valid) == 0) {
+      cli::cli_abort(c("No hermod driver configured",
+                       i = "Please run 'hermod_configure()'"),
+                     call = call)
+    } else if (length(valid) > 1) {
+      cli::cli_abort(c("More than one hermod driver configured",
+                       i = "Please provide the argument 'driver'",
+                       i = "Valid options are: {squote(valid)}"),
+                     arg = "driver", call = call)
+    }
+    name <- valid
+  } else {
+    assert_scalar_character(name, name = "driver")
+    if (!(name %in% valid)) {
+      if (length(valid) == 0) {
+        hint <- paste("No driver configured;",
+                      "please run 'hermod_configure(\"{name}\")'")
+      } else {
+        hint <- "Valid option{? is/s are}: {squote(valid)}"
+      }
+      cli::cli_abort(
+        c("Invalid value for 'driver': '{name}'",
+          i = hint),
+        arg = "driver", call = call)
+    }
+  }
+  name
+}
+
+
+hermod_driver_prepare <- function(driver, root, call) {
+  root <- hermod_root(root)
+  driver <- hermod_driver_select(driver, root, call)
+  list(name = driver,
+       driver = hermod_driver_load(driver, call),
+       config = root$config[[driver]])
+}

R/root.R

@@ -30,52 +30,6 @@ hermod_init <- function(path = ".") {
 }
 
 
-##' Configure your hermod root.  `hermod_configure` creates the
-##' configuration and `hermod_get_configuration` looks it up.
-##'
-##' @title Configure your hermod root
-##'
-##' @param driver The hermod driver; probably you want this to be
-##'   `"windows"` as that is all we support at the moment!
-##'
-##' @param ... Arguments passed to your driver. We'll work out how to
-##'   point you at appropriate documentation once it is written.
-##'
-##' @param root Hermod root, usually best `NULL`
-##'
-##' @export
-hermod_configure <- function(driver, ..., root = NULL) {
-  assert_scalar_character(driver)
-  package <- sprintf("hermod.%s", driver)
-  ns <- ensure_package(package)
-
-  root <- hermod_root(root)
-  ## TODO: what name here
-  config <- withr::with_dir(root$path$root, ns$make_configuration(...))
-  fs::dir_create(root$path$config)
-  saveRDS(config, file.path(root$path$config, paste0(driver, ".rds")))
-  if (is.null(root$config)) {
-    root$config <- list()
-  }
-  root$config[[driver]] <- config
-  invisible()
-}
-
-
-##' @export
-##' @rdname hermod_configure
-hermod_get_configuration <- function(driver, root = NULL) {
-  assert_scalar_character(driver)
-  config <- hermod_root(root)$config[[driver]]
-  if (is.null(config)) {
-    cli::cli_abort(
-      c("This hermod root is not configured for driver '{driver}'",
-        i = "Please run 'hermod_configure(\"{driver}\", ...)'"))
-  }
-  config
-}
-
-
 hermod_root <- function(root = NULL) {
   if (inherits(root, "hermod_root")) {
     return(root)

R/submit.R

@@ -0,0 +1,28 @@
+##' Submit a task to a queue
+##'
+##' This is a lower-level function that you will not often need to call.
+##'
+##' @title Submit a task
+##' @param id The task id
+##'
+##' @param ... Disallowed additional arguments, don't use.
+##'
+##' @param driver The name of the driver to use, or you can leave
+##'   blank if only one is configured (this will be typical).
+##'
+##' @param root The hermod root
+##'
+##' @export
+hermod_task_submit <- function(id, ..., driver = NULL, root = NULL) {
+  if (...length() > 0) {
+    cli::cli_abort("Additional arguments to 'hermod_task_submit' not allowed")
+  }
+  root <- hermod_root(root)
+
+  ## This is a bit gross, could be tidied up later.
+  dat <- hermod_driver_prepare(driver, root, environment())
+  dat$driver$submit(id, dat$config, root$path$root)
+
+  writeLines(dat$name, file.path(root$path$tasks, id, STATUS_SUBMITTED))
+  invisible()
+}

R/util.R

@@ -22,7 +22,10 @@ ensure_package <- function(name) {
       "Please install the '{name}' package",
       c(i = "Try at https://github.com/mrc-ide/{name}")))
   }
-  ## TODO: probably we only want exports
-  ##   as.environment("package:{name}")
   getNamespace(name)
 }
+
+
+squote <- function(x) {
+  sprintf("'%s'", x)
+}

drivers/windows/R/batch.R

@@ -1,11 +1,8 @@
-write_batch_task_run <- function(task_id, workdir, config, path_root) {
-  data <- template_data(workdir, config, path_root)
+write_batch_task_run <- function(task_id, config, path_root) {
+  data <- template_data(config, path_root)
   data$hermod_task_id <- task_id
   str <- glue_whisker(read_template("task_run"), data)
-  ## NOTE: we could use the root object here, not 100% sure that's the
-  ## best line to take; alternatively write 'hermod_get_paths' or
-  ## similar?
-  path <- file.path(path_tasks(path_root), task_id, BATCH_RUN)
+  path <- file.path(path_root, "hermod", "tasks", task_id, BATCH_RUN)
   writeLines(str, path)
   path
 }
@@ -16,20 +13,9 @@ read_template <- function(name) {
 }
 
 
-template_data <- function(workdir, config, path_root) {
-  if (!fs::path_has_parent(workdir, path_root)) {
-    cli::cli_abort(c(
-      "Expected working directory to be within hermod root",
-      i = "Working directory: '{workdir}'",
-      i = "hermod root: '{path_root}'"))
-  }
-  workdir <- prepare_path(workdir, config$shares)
+template_data <- function(config, path_root) {
   hermod_root <- prepare_path(path_root, config$shares)
 
-  ## Same path, absolute, that will be used remotely
-  hermod_root_abs <- windows_path(
-    file.path(hermod_root$drive_remote, hermod_root$rel))
-
   r_version_str <- paste(unclass(config$r_version)[[1]], collapse = "_")
 
   network_shares_data <- list(
@@ -48,8 +34,7 @@ template_data <- function(workdir, config, path_root) {
        r_version = r_version_str,
        network_shares_create = paste(network_shares_create, collapse = "\n"),
        network_shares_delete = paste(network_shares_delete, collapse = "\n"),
-       hermod_workdir_drive = workdir$drive_remote,
-       hermod_workdir_path = paste0("\\", windows_path(workdir$rel)),
-       hermod_path_root_abs = hermod_root_abs,
+       hermod_root_drive = hermod_root$drive_remote,
+       hermod_root_path = paste0("\\", windows_path(hermod_root$rel)),
        cluster_name = config$cluster)
 }

drivers/windows/R/config.R

@@ -1,4 +1,4 @@
-make_configuration <- function(shares = NULL, r_version = NULL) {
+windows_configure <- function(shares = NULL, r_version = NULL) {
   path <- getwd()
   config <- list(
     cluster = "wpia-hn",

drivers/windows/R/driver.R

@@ -0,0 +1,18 @@
+hermod_driver_windows <- function() {
+  hermod::hermod_driver(
+    configure = windows_configure,
+    submit = windows_submit)
+}
+
+
+windows_submit <- function(id, config, path_root) {
+  path_batch <- write_batch_task_run(id, config, path_root)
+
+  path_batch_dat <- prepare_path(path_batch, config$shares)
+  path_batch_unc <- windows_path(
+    file.path(path_batch_dat$path_remote, path_batch_dat$rel))
+
+  client <- get_web_client()
+  dide_id <- client$submit(path_batch_unc, id, config$template)
+  writeLines(dide_id, file.path(dirname(path_batch), DIDE_ID))
+}

drivers/windows/R/util.R

@@ -123,10 +123,3 @@ readline_with_default <- function(prefix, default) {
   }
   result
 }
-
-
-## This is really part of hermod, but until we decide on the
-## interface, leaving it here.
-path_tasks <- function(path_root) {
-  file.path(path_root, "hermod", "tasks")
-}

drivers/windows/README.md

@@ -30,6 +30,20 @@ id <- hermod::hermod_task_create_explicit(quote(sessionInfo()))
 hermod::hermod_task_submit(id, "windows")
 ```
 
+## Creating the temporary library for testing
+
+* Log into a windows host by RDP (or Wes from his desktop)
+* Open the most recent version of R you can find there
+* Ensure that `T:/hemod-testing` is in fact the library
+* Then run:
+
+```r
+.libPaths("T:/hermod-testing")
+remotes::install_github("mrc-ide/hermod@<branchname>")
+```
+
+remotes::install_github("mrc-ide/hermod@prototype-drivers")
+
 ## License
 
 MIT © Imperial College of Science, Technology and Medicine

drivers/windows/inst/templates/task_run.bat

@@ -6,16 +6,15 @@ ECHO hermod version: {{hermod_version}}
 ECHO running on: %COMPUTERNAME%
 
 REM variables that get pulled in here
-REM * hermod_drive - the drive alone (e.g., Q:)
-REM * hermod_root - the absolute path incl. drive to folder with hermod/
-REM * hermod_workdir - the absolute path on drive to working directory
+REM * hermod_root_drive - the drive alone (e.g., Q:)
+REM * hermod_root_path - the relative path incl. drive to folder with hermod/
 
 call setr64_{{r_version}}.bat
 
 {{network_shares_create}}
 
-{{hermod_workdir_drive}}
-cd {{hermod_workdir_path}}
+{{hermod_root_drive}}
+cd {{hermod_root_path}}
 ECHO working directory: %CD%
 
 set R_LIBS_USER=\\fi--didef3.dide.ic.ac.uk\tmp\hermod-testing
@@ -24,7 +23,7 @@ ECHO this is a single task
 
 @REM The quoting here is necessary for paths with spaces.
 ECHO on
-Rscript -e "hermod::hermod_task_eval('{{hermod_task_id}}')" > "{{hermod_path_root_abs}}\hermod\tasks\{{hermod_task_id}}\log" 2>&1
+Rscript -e "hermod::hermod_task_eval('{{hermod_task_id}}')" > "hermod\tasks\{{hermod_task_id}}\log" 2>&1
 
 @ECHO off
 %SystemDrive%