Merge pull request #116 from mrc-ide/mrc-4437

R/location_path.R

@@ -69,7 +69,7 @@ orderly_location_path <- R6::R6Class(
 ## This split just acts to make the http one easier to think about -
 ## it's not the job of the driver to do validation, but the server.
 location_path_import_metadata <- function(str, hash, root) {
-  meta <- outpack_metadata_load(as_json(str))
+  meta <- outpack_metadata_core_load(as_json(str))
   id <- meta$id
   hash_validate_data(str, hash, sprintf("metadata for '%s'", id))
 

R/outpack_insert.R

@@ -1,6 +1,6 @@
 outpack_insert_packet <- function(path, json, root = NULL) {
   assert_is(root, "outpack_root")
-  meta <- outpack_metadata_load(json)
+  meta <- outpack_metadata_core_load(json)
   assert_is_directory(path)
 
   hash_algorithm <- root$config$core$hash_algorithm

R/outpack_metadata.R

@@ -31,7 +31,7 @@ orderly_metadata <- function(id, root = NULL, locate = FALSE) {
   if (!file.exists(path_metadata)) {
     cli::cli_abort("Packet '{id}' not found in outpack index")
   }
-  outpack_metadata_load(path_metadata)
+  outpack_metadata_load(path_metadata, root$config$orderly$plugins)
 }
 
 
@@ -41,19 +41,32 @@ orderly_metadata <- function(id, root = NULL, locate = FALSE) {
 ##' context of reading a metadata file written out as part of a failed
 ##' run.
 ##'
+##' Custom metadata saved by plugins may not be deserialised as
+##' expected when called with this function, as it is designed to
+##' operate separately from a valid orderly root (i.e., it will load
+##' data from any file regardless of where it came from). If `plugins`
+##' is `TRUE` (the default) then we will deserialise all data that
+##' matches any loaded plugin.  This means that the behaviour of this
+##' function depends on if you have loaded the plugin packages. You
+##' can force this by running `orderly2::orderly_config()` within any
+##' orderly directory, which will load any declared plugins.
+##'
 ##' @title Read outpack metadata json file
 ##'
 ##' @param path Path to the json file
 ##'
+##' @param plugins Try and deserialise data from all loaded plugins
+##'   (see Details).
+##'
 ##' @return A list of outpack metadata; see the schema for details. In
 ##'   contrast to reading the json file directly with
 ##'   `jsonlite::fromJSON`, this function will take care to convert
 ##'   scalar and length-one vectors into the expected types.
 ##'
 ##' @export
-orderly_metadata_read <- function(path) {
+orderly_metadata_read <- function(path, plugins = TRUE) {
   assert_file_exists(path, call = environment())
-  outpack_metadata_load(path)
+  outpack_metadata_load(path, if (plugins) .plugins else NULL)
 }
 
 outpack_metadata_create <- function(path, name, id, time, files,
@@ -166,10 +179,14 @@ outpack_metadata_core <- function(id, root, call = NULL) {
 }
 
 
+outpack_metadata_core_read <- function(path) {
+  outpack_metadata_core_load(read_string(path))
+}
+
 
 metadata_core_names <- c("id", "name", "parameters", "time", "files", "depends")
-outpack_metadata_core_read <- function(path) {
-  data <- jsonlite::read_json(path)[metadata_core_names]
+outpack_metadata_core_load <- function(json) {
+  data <- jsonlite::parse_json(json)[metadata_core_names]
   outpack_metadata_core_deserialise(data)
 }
 
@@ -193,7 +210,7 @@ outpack_metadata_core_deserialise <- function(data) {
 }
 
 
-outpack_metadata_load <- function(json) {
+outpack_metadata_load <- function(json, plugins) {
   if (!inherits(json, "json")) { # could use starts with "{"
     json <- read_string(json)
   }
@@ -202,6 +219,16 @@ outpack_metadata_load <- function(json) {
   if (!is.null(data$custom$orderly)) {
     data$custom$orderly <- custom_metadata_deserialise(data$custom$orderly)
   }
+  for (nm in intersect(names(data$custom), names(plugins))) {
+    data$custom[[nm]] <- tryCatch(
+      plugins[[nm]]$deserialise(data$custom[[nm]]),
+      error = function(e) {
+        cli::cli_warn(
+          c("Deserialising custom metadata '{nm}' for '{data$id}' failed",
+            x = e$message))
+        data$custom[[nm]]
+      })
+  }
   data
 }
 

R/plugin.R

@@ -29,6 +29,17 @@
 ##'   then no serialisation is done, and no metadata from your plugin
 ##'   will be added.
 ##'
+##' @param deserialise A function to deserialise any metadata
+##'   serialised by the `serialise` function. This is intended to help
+##'   deal with issues disambiguating unserialising objects from json
+##'   (scalars vs arrays of lenth 1, data.frames vs lists-of-lists
+##'   etc), and will make your plugin nicer to work with
+##'   [orderly2::orderly_metadata_extract()]. This function will be
+##'   given a single argument `data` which is the data from
+##'   `jsonlite::fromJSON(..., simplifyVector = FALSE)` and you should
+##'   apply any required simplifications yourself, returning a
+##'   modified copy of the argument.
+##'
 ##' @param cleanup Optionally, a function to clean up any state that
 ##'   your plugin uses. You can call `orderly_plugin_context` from
 ##'   within this function and access anything you need from that. If
@@ -45,9 +56,11 @@
 ##'
 ##' @export
 orderly_plugin_register <- function(name, config, serialise = NULL,
-                                    cleanup = NULL, schema = NULL) {
+                                    deserialise = NULL, cleanup = NULL,
+                                    schema = NULL) {
   assert_scalar_character(name, call = environment())
-  plugin <- orderly_plugin(name, config, serialise, cleanup, schema)
+  plugin <- orderly_plugin(name, config, serialise, deserialise, cleanup,
+                           schema)
   .plugins[[name]] <- plugin
 }
 
@@ -69,30 +82,36 @@ load_orderly_plugin <- function(name) {
 .plugins <- new.env(parent = emptyenv())
 
 
-orderly_plugin <- function(package, config, serialise, cleanup, schema,
-                           call = NULL) {
+orderly_plugin <- function(package, config, serialise, deserialise, cleanup,
+                           schema, call = NULL) {
   assert_is(config, "function", call = call)
   if (is.null(cleanup)) {
     cleanup <- plugin_no_cleanup
   }
   if (!is.null(schema)) {
     if (is.null(serialise)) {
-      stop("If 'schema' is given, then 'serialise' must be non-NULL")
+      cli::cli_abort(
+        "If 'schema' is given, then 'serialise' must be non-NULL",
+        call = call)
     }
     path_pkg <- pkg_root(package)
     if (!file.exists(file.path(path_pkg, schema))) {
       cli::cli_abort(
-        "Expected schema file '{schema}' to exist in package '{package}'")
+        "Expected schema file '{schema}' to exist in package '{package}'",
+        call = call)
     }
     schema <- sprintf("%s/%s", package, schema)
   }
-  if (is.null(serialise)) {
-    serialise <- plugin_no_serialise
+  if (!is.null(deserialise) && is.null(serialise)) {
+    cli::cli_abort(
+      "If 'deserialise' is given, then 'serialise' must be non-NULL",
+      call = call)
   }
   assert_is(cleanup, "function", call = call)
   ret <- list(package = package,
               config = config,
-              serialise = serialise,
+              serialise = serialise %||% plugin_no_serialise,
+              deserialise = deserialise %||% plugin_no_deserialise,
               cleanup = cleanup,
               schema = schema)
   class(ret) <- "orderly_plugin"
@@ -229,6 +248,11 @@ plugin_no_serialise <- function(data) {
 }
 
 
+plugin_no_deserialise <- function(data) {
+  data
+}
+
+
 ## Some careful work here is required to cope with the case where
 ## orderly2 and the plugin package are installed directly or in dev
 ## mode

tests/testthat/test-outpack-packet.R

@@ -311,7 +311,7 @@ test_that("Can add multiple copies of extra data", {
   outpack_packet_end_quietly(p)
 
   path_metadata <- file.path(root$path, ".outpack", "metadata", p$id)
-  meta <- outpack_metadata_load(path_metadata)
+  meta <- outpack_metadata_load(path_metadata, NULL)
   expect_equal(meta$custom,
                list(app1 = list(a = 1, b = 2),
                     app2 = list(c = list(1, 2, 3))))

tests/testthat/test-plugin.R

@@ -12,10 +12,6 @@ test_that("Can run simple example with plugin", {
 
   meta <- orderly_metadata(id, root = path)
 
-  ## Our nice vectors have become lists here, due to the general pain
-  ## of deserialising json, into R but at least it's all there.
-  ## Probably the most general solution involves plugins being able to
-  ## provide deserialisers that can apply any required simplification?
   expect_equal(
     meta$custom$example.random,
     list(list(as = "dat", mean = mean(cmp), variance = var(cmp))))
@@ -42,6 +38,36 @@ test_that("can run interactive example with plugin", {
 })
 
 
+test_that("Can use custom deserialiser plugin", {
+  clear_plugins()
+  on.exit(clear_plugins())
+  path <- test_prepare_orderly_example("plugin")
+
+  .plugins[["example.random"]]$deserialise <- function(data) {
+    data_frame(
+      as = vcapply(data, "[[", "as"),
+      mean = vnapply(data, "[[", "mean"),
+      variance = vnapply(data, "[[", "variance"))
+  }
+
+  envir <- new.env()
+  set.seed(1)
+  id <- orderly_run_quietly("plugin", root = path, envir = envir)
+
+  set.seed(1)
+  cmp <- rnorm(10)
+  expect_identical(envir$dat, cmp)
+
+  meta <- orderly_metadata(id, root = path)
+
+  root <- root_open(path, locate = FALSE, require_orderly = FALSE)
+  meta <- orderly_metadata(id, root = root)
+  expect_s3_class(meta$custom$example.random, "data.frame")
+  expect_equal(meta$custom$example.random,
+               data_frame(as = "dat", mean = mean(cmp), variance = var(cmp)))
+})
+
+
 test_that("loading plugin triggers package load", {
   skip_if_not_installed("mockery")
   clear_plugins()
@@ -122,32 +148,41 @@ test_that("validate that plugins make sense", {
   skip_if_not_installed("mockery")
   config <- function(...) "config"
   serialise <- function(...) "serialise"
+  deserialise <- function(...) "deserialise"
   cleanup <- function(...) "cleanup"
   schema <- withr::local_tempfile(fileext = ".json")
   writeLines("{}", schema)
 
   mock_pkg_root <- mockery::mock(dirname(schema), cycle = TRUE)
   mockery::stub(orderly_plugin, "pkg_root", mock_pkg_root)
 
-  p <- orderly_plugin("pkg", config, NULL, NULL, NULL)
+  p <- orderly_plugin("pkg", config, NULL, NULL, NULL, NULL)
   expect_identical(p$config, config)
   expect_identical(p$serialise, plugin_no_serialise)
+  expect_identical(p$deserialise, plugin_no_deserialise)
   expect_identical(p$cleanup, plugin_no_cleanup)
   expect_null(p$schema)
 
-  p <- orderly_plugin("pkg", config, serialise, cleanup, basename(schema))
+  p <- orderly_plugin("pkg", config, serialise, deserialise, cleanup,
+                      basename(schema))
   expect_identical(p$config, config)
   expect_identical(p$serialise, serialise)
+  expect_identical(p$deserialise, deserialise)
   expect_identical(p$cleanup, cleanup)
   expect_equal(p$schema, file.path("pkg", basename(schema)))
 
   expect_error(
-    orderly_plugin("pkg", config, NULL, NULL, basename(schema)),
+    orderly_plugin("pkg", config, NULL, NULL, NULL, basename(schema)),
     "If 'schema' is given, then 'serialise' must be non-NULL")
 
+  expect_error(
+    orderly_plugin("pkg", config, NULL, deserialise, NULL, NULL),
+    "If 'deserialise' is given, then 'serialise' must be non-NULL")
+
   unlink(schema)
   expect_error(
-    orderly_plugin("pkg", config, serialise, cleanup, basename(schema)),
+    orderly_plugin("pkg", config, serialise, deserialise, cleanup,
+                   basename(schema)),
     sprintf("Expected schema file '%s' to exist in package 'pkg'",
             basename(schema)),
     fixed = TRUE)
@@ -173,3 +208,29 @@ test_that("deal with devmode roots", {
   expect_equal(pkg_root("pkg"), "/path/to/pkg")
   expect_equal(pkg_root("pkg"), file.path("/path/to/pkg", "inst"))
 })
+
+
+test_that("gracefully cope with failed deserialisation", {
+  clear_plugins()
+  on.exit(clear_plugins())
+  path <- test_prepare_orderly_example("plugin")
+
+  .plugins[["example.random"]]$deserialise <- function(data) {
+    stop("some error here")
+  }
+
+  set.seed(1)
+  cmp <- rnorm(10)
+
+  envir <- new.env()
+  set.seed(1)
+  id <- orderly_run_quietly("plugin", root = path, envir = envir)
+  w <- expect_warning(
+    meta <- orderly_metadata(id, root = path),
+    "Deserialising custom metadata 'example.random' for '.+' failed")
+  expect_match(conditionMessage(w), "some error here")
+  expect_type(meta$custom$example.random, "list")
+  expect_equal(
+    meta$custom$example.random,
+    list(list(as = "dat", mean = mean(cmp), variance = var(cmp))))
+})