Merge pull request #145 from mrc-ide/mrc-5483

mrc-5483: Fix issue when pulling multiple packets with multiple files

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.17
+Version: 1.99.18
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),

R/location.R

@@ -273,7 +273,7 @@ orderly_location_pull_metadata <- function(location = NULL, root = NULL,
 ##' efficient, as we keep track of files that are copied over even in
 ##' the case of an interrupted pull.
 ##'
-##' @title Pull a single packet from a location
+##' @title Pull one or more packets from a location
 ##'
 ##' @param ... Arguments passed through to
 ##'   [orderly2::orderly_search]. In the special case where the first
@@ -673,10 +673,9 @@ location_build_pull_plan_files <- function(packet_id, location, root, call) {
         intersect(location, loc$location[loc$packet == id])[[1]]
       }, USE.NAMES = FALSE)
     }
-    files <- data_frame(
-      hash = unlist(lapply(meta, function(x) x$files$hash), FALSE, FALSE),
-      size = unlist(lapply(meta, function(x) x$files$size), FALSE, FALSE),
-      location = location_use)
+
+    files <- Map(location_file_pull_meta, meta, location_use)
+    files <- do.call(rbind.data.frame, files)
     ## Then we ensure we prefer to fetch from earlier-provided
     ## locations by ordering the list by locations and dropping
     ## duplicated hashes.
@@ -690,6 +689,14 @@ location_build_pull_plan_files <- function(packet_id, location, root, call) {
 }
 
 
+location_file_pull_meta <- function(packet_meta, packet_location) {
+  data_frame(
+    hash = unlist(packet_meta$files$hash, FALSE, FALSE),
+    size = unlist(packet_meta$files$size, FALSE, FALSE),
+    location = packet_location)
+}
+
+
 location_build_push_plan <- function(packet_id, location_name, root) {
   driver <- location_driver(location_name, root)
 

R/util.R

@@ -645,7 +645,7 @@ is_testing <- function() {
   identical(Sys.getenv("TESTTHAT"), "true")
 }
 
-#' Given a character vector, missing names are filled using the value.
+# Given a character vector, missing names are filled using the value.
 fill_missing_names <- function(x) {
   if (is.null(names(x))) {
     names(x) <- x

tests/testthat/helper-outpack.R

@@ -4,10 +4,13 @@ options(outpack.schema_validate = TRUE)
 
 
 create_random_packet <- function(root, name = "data", parameters = NULL,
-                                 id = NULL) {
+                                 id = NULL, n_files = 1) {
   src <- fs::dir_create(tempfile())
   on.exit(fs::dir_delete(src))
-  saveRDS(runif(10), file.path(src, "data.rds"))
+  for (n in seq_len(n_files)) {
+    file_name <- sprintf("data%s.rds", if (n > 1) n else "")
+    saveRDS(runif(10), file.path(src, file_name))
+  }
   p <- outpack_packet_start_quietly(
     src, name, parameters = parameters, id = id, root = root)
   outpack_packet_end_quietly(p)

tests/testthat/test-location.R

@@ -680,6 +680,35 @@ test_that("Can filter locations", {
 })
 
 
+test_that("can pull from multiple locations with multiple files", {
+  root <- list()
+  for (name in c("dst", "a", "b")) {
+    root[[name]] <- create_temporary_root()
+    if (name != "dst") {
+      orderly_location_add(name, "path", list(path = root[[name]]$path),
+                           root = root$dst)
+    }
+  }
+
+  ids_a <- create_random_packet(root$a$path, n_files = 1)
+  ids_b <- create_random_packet(root$b$path, n_files = 2)
+
+  orderly_location_pull_metadata(root = root$dst)
+  suppressMessages(orderly_location_pull_packet(name = "data", root = root$dst))
+
+  ## It has pulled both packets, and correct number of files
+  expect_setequal(
+    list.files(file.path(root$dst$path, "archive", "data")),
+    c(ids_a, ids_b))
+  expect_equal(
+    list.files(file.path(root$dst$path, "archive", "data", ids_a)),
+    "data.rds")
+  expect_setequal(
+    list.files(file.path(root$dst$path, "archive", "data", ids_b)),
+    c("data.rds", "data2.rds"))
+})
+
+
 test_that("nonrecursive pulls are prevented by configuration", {
   root <- list()
   for (name in c("src", "dst")) {