98/ Subset expanded grid of valid values by output type

.lintr

@@ -4,3 +4,6 @@ linters: linters_with_defaults(
     object_length_linter = object_length_linter(length = 50L),
     cyclocomp_linter = cyclocomp_linter(complexity_limit = 20L)
   )
+exclusions: list(
+    "tests/testthat/helper.R"
+  )

R/check_tbl_spl_compound_taskid_set.R

@@ -59,7 +59,11 @@ check_tbl_spl_compound_taskid_set <- function(tbl, round_id, file_path, hub_path
     details = compile_msg(compound_taskid_set),
     errors = compile_errors(compound_taskid_set),
     error = TRUE,
-    compound_taskid_set = if (check) { compound_taskid_set } else { NA }
+    compound_taskid_set = if (check) {
+      compound_taskid_set
+    } else {
+      NA
+    }
   )
 }
 

R/check_tbl_spl_compound_tid.R

@@ -34,8 +34,6 @@ check_tbl_spl_compound_tid <- function(tbl, round_id, file_path, hub_path,
   }
 
   hash_tbl <- spl_hash_tbl(tbl, round_id, config_tasks, compound_taskid_set)
-  # TODO: Currently, samples must strictly match the compound task ID set expectations
-  # and cannot handle coarser-grained compound task ID sets.
   n_tbl <- hash_tbl[hash_tbl$n_compound_idx > 1L, ]
 
   check <- nrow(n_tbl) == 0L

R/expand_model_out_grid.R

@@ -20,6 +20,8 @@
 #' in the round. Can be used to override the compound task ID set defined in the
 #' config. If `NULL` is provided for a given modeling task, a compound task ID set of
 #' all task IDs is used.
+#' @param output_types character vector of output type names to include.
+#' Use to subset for grids for specific output types.
 #'
 #' @return If `bind_model_tasks = TRUE` (default) a tibble or arrow table
 #' containing all possible task ID and related output type ID
@@ -126,16 +128,12 @@ expand_model_out_grid <- function(config_tasks,
                                   as_arrow_table = FALSE,
                                   bind_model_tasks = TRUE,
                                   include_sample_ids = FALSE,
-                                  compound_taskid_set = NULL) {
-  round_idx <- hubUtils::get_round_idx(config_tasks, round_id)
+                                  compound_taskid_set = NULL,
+                                  output_types = NULL) {
   checkmate::assert_list(compound_taskid_set, null.ok = TRUE)
   output_type_id_datatype <- rlang::arg_match(output_type_id_datatype)
-
-  round_config <- purrr::pluck(
-    config_tasks,
-    "rounds",
-    round_idx
-  )
+  output_types <- validate_output_types(output_types, config_tasks, round_id)
+  round_config <- get_round_config(config_tasks, round_id)
 
   task_id_l <- purrr::map(
     round_config[["model_tasks"]],
@@ -158,7 +156,13 @@ expand_model_out_grid <- function(config_tasks,
   output_type_l <- purrr::map(
     round_config[["model_tasks"]],
     function(.x) {
-      .x[["output_type"]]
+      out <- .x[["output_type"]]
+      if (is.null(output_types)) {
+        out
+      } else {
+        mt_output_types <- output_types[output_types %in% names(out)]
+        out[mt_output_types]
+      }
     }
   ) %>%
     purrr::map(
@@ -258,7 +262,6 @@ process_mt_grid_outputs <- function(x, config_tasks, all_character,
                                     as_arrow_table = TRUE,
                                     bind_model_tasks = TRUE,
                                     output_type_id_datatype = output_type_id_datatype) {
-
   if (bind_model_tasks) {
     # To bind multiple modeling task grids together, we need to ensure they contain
     # the same columns. Any missing columns are padded with NAs.
@@ -304,6 +307,9 @@ process_mt_grid_outputs <- function(x, config_tasks, all_character,
 
 # Pad any columns in all_cols missing in x of with new NA columns
 pad_missing_cols <- function(x, all_cols) {
+  if (ncol(x) == 0L) {
+    return(x)
+  }
   if (inherits(x, "data.frame")) {
     x[, all_cols[!all_cols %in% names(x)]] <- NA
     return(x[, all_cols])
@@ -472,3 +478,54 @@ extract_mt_output_type_ids <- function(x, config_tid) {
     }
   )
 }
+
+
+get_round_config <- function(config_tasks, round_id) {
+  round_idx <- hubUtils::get_round_idx(config_tasks, round_id)
+  purrr::pluck(
+    config_tasks,
+    "rounds",
+    round_idx
+  )
+}
+
+get_round_output_types <- function(config_tasks, round_id) {
+  round_config <- get_round_config(config_tasks, round_id)
+  purrr::map(
+    round_config[["model_tasks"]],
+    ~ .x[["output_type"]]
+  )
+}
+
+get_round_output_type_names <- function(config_tasks, round_id,
+                                        collapse = TRUE) {
+  out <- get_round_output_types(config_tasks, round_id) %>%
+    purrr::map(names)
+
+  if (collapse) {
+    purrr::flatten_chr(out) %>%
+      unique()
+  } else {
+    out
+  }
+}
+
+validate_output_types <- function(output_types, config_tasks, round_id,
+                                  call = rlang::caller_call()) {
+  checkmate::assert_character(output_types, null.ok = TRUE)
+  if (is.null(output_types)) {
+    return(NULL)
+  }
+  round_output_types <- get_round_output_type_names(config_tasks, round_id)
+  valid_output_types <- intersect(output_types, round_output_types)
+  if (length(valid_output_types) == 0L) {
+    cli::cli_abort(
+      c(
+        "x" = "{.val {output_types}} {?is/are} not valid output type{?s}.",
+        "i" = "{.arg output_types} must be members of: {.val {round_output_types}}"
+      ),
+      call = call
+    )
+  }
+  valid_output_types
+}

R/v3-sample-utils.R

@@ -59,7 +59,7 @@ spl_hash_tbl <- function(tbl, round_id, config_tasks, compound_taskid_set = NULL
     )
   ) %>%
     purrr::compact() %>%
-    purrr::imap( ~ dplyr::mutate(.x, mt_id = as.integer(.y))) %>% # add mt_id
+    purrr::imap(~dplyr::mutate(.x, mt_id = as.integer(.y))) %>% # add mt_id
     purrr::list_rbind()
 }
 

tests/testthat/_snaps/expand_model_out_grid.md

@@ -485,6 +485,106 @@
       10 2022-12-26    wk ahead inc flu h~       1 01       sample      4             
       # i 32 more rows
 
+# expand_model_out_grid output type subsetting works
+
+    Code
+      expand_model_out_grid(config_tasks, round_id = "2022-12-26",
+        include_sample_ids = TRUE, bind_model_tasks = FALSE, output_types = c("pmf",
+          "sample"), )
+    Output
+      [[1]]
+      # A tibble: 6 x 6
+        forecast_date target               horizon location output_type output_type_id
+        <date>        <chr>                  <int> <chr>    <chr>       <chr>         
+      1 2022-12-26    wk ahead inc flu ho~       2 US       sample      1             
+      2 2022-12-26    wk ahead inc flu ho~       2 01       sample      1             
+      3 2022-12-26    wk ahead inc flu ho~       2 02       sample      1             
+      4 2022-12-26    wk ahead inc flu ho~       1 US       sample      2             
+      5 2022-12-26    wk ahead inc flu ho~       1 01       sample      2             
+      6 2022-12-26    wk ahead inc flu ho~       1 02       sample      2             
+
+      [[2]]
+      # A tibble: 30 x 6
+         forecast_date target              horizon location output_type output_type_id
+         <date>        <chr>                 <int> <chr>    <chr>       <chr>         
+       1 2022-12-26    wk flu hosp rate c~       2 US       pmf         large_decrease
+       2 2022-12-26    wk flu hosp rate c~       1 US       pmf         large_decrease
+       3 2022-12-26    wk flu hosp rate c~       2 01       pmf         large_decrease
+       4 2022-12-26    wk flu hosp rate c~       1 01       pmf         large_decrease
+       5 2022-12-26    wk flu hosp rate c~       2 02       pmf         large_decrease
+       6 2022-12-26    wk flu hosp rate c~       1 02       pmf         large_decrease
+       7 2022-12-26    wk flu hosp rate c~       2 US       pmf         decrease      
+       8 2022-12-26    wk flu hosp rate c~       1 US       pmf         decrease      
+       9 2022-12-26    wk flu hosp rate c~       2 01       pmf         decrease      
+      10 2022-12-26    wk flu hosp rate c~       1 01       pmf         decrease      
+      # i 20 more rows
+
+
+---
+
+    Code
+      expand_model_out_grid(config_tasks, round_id = "2022-12-26",
+        include_sample_ids = TRUE, bind_model_tasks = FALSE, output_types = "sample", )
+    Output
+      [[1]]
+      # A tibble: 6 x 6
+        forecast_date target               horizon location output_type output_type_id
+        <date>        <chr>                  <int> <chr>    <chr>       <chr>         
+      1 2022-12-26    wk ahead inc flu ho~       2 US       sample      1             
+      2 2022-12-26    wk ahead inc flu ho~       2 01       sample      1             
+      3 2022-12-26    wk ahead inc flu ho~       2 02       sample      1             
+      4 2022-12-26    wk ahead inc flu ho~       1 US       sample      2             
+      5 2022-12-26    wk ahead inc flu ho~       1 01       sample      2             
+      6 2022-12-26    wk ahead inc flu ho~       1 02       sample      2             
+
+      [[2]]
+      # A tibble: 0 x 0
+
+
+---
+
+    Code
+      expand_model_out_grid(config_tasks, round_id = "2022-12-26",
+        include_sample_ids = TRUE, bind_model_tasks = TRUE, output_types = "sample", )
+    Output
+      # A tibble: 6 x 6
+        forecast_date target               horizon location output_type output_type_id
+        <date>        <chr>                  <int> <chr>    <chr>       <chr>         
+      1 2022-12-26    wk ahead inc flu ho~       2 US       sample      1             
+      2 2022-12-26    wk ahead inc flu ho~       2 01       sample      1             
+      3 2022-12-26    wk ahead inc flu ho~       2 02       sample      1             
+      4 2022-12-26    wk ahead inc flu ho~       1 US       sample      2             
+      5 2022-12-26    wk ahead inc flu ho~       1 01       sample      2             
+      6 2022-12-26    wk ahead inc flu ho~       1 02       sample      2             
+
+---
+
+    Code
+      expand_model_out_grid(config_tasks, round_id = "2022-12-26",
+        include_sample_ids = FALSE, bind_model_tasks = TRUE, output_types = c(
+          "random", "sample"), )
+    Output
+      # A tibble: 6 x 6
+        forecast_date target               horizon location output_type output_type_id
+        <date>        <chr>                  <int> <chr>    <chr>       <chr>         
+      1 2022-12-26    wk ahead inc flu ho~       2 US       sample      <NA>          
+      2 2022-12-26    wk ahead inc flu ho~       1 US       sample      <NA>          
+      3 2022-12-26    wk ahead inc flu ho~       2 01       sample      <NA>          
+      4 2022-12-26    wk ahead inc flu ho~       1 01       sample      <NA>          
+      5 2022-12-26    wk ahead inc flu ho~       2 02       sample      <NA>          
+      6 2022-12-26    wk ahead inc flu ho~       1 02       sample      <NA>          
+
+---
+
+    Code
+      expand_model_out_grid(config_tasks, round_id = "2022-12-26",
+        include_sample_ids = FALSE, bind_model_tasks = FALSE, output_types = c(
+          "random"), )
+    Condition
+      Error in `expand_model_out_grid()`:
+      x "random" is not valid output type.
+      i `output_types` must be members of: "sample", "mean", and "pmf"
+
 # expand_model_out_grid errors correctly
 
     Code

tests/testthat/helper.R

@@ -1,6 +1,3 @@
-suppressPackageStartupMessages({
-  library(dplyr)
-})
 # Function to create a valid sample submission for the testdata/hub-spl hub
 create_spl_file <- function(round_id, compound_taskid_set = NULL,
                             hub_path = test_path("testdata/hub-spl"),

tests/testthat/test-check_tbl_spl_compound_taskid_set.R

@@ -93,17 +93,17 @@ test_that("Different compound_taskid_sets work", {
   # Mock the config file to include all task ids a derived task id depends on
   #  in the compound_taskid_set but exclude the derived task id itself.
   #  Currently will fail
-    config_tasks_full_ctids <- purrr::modify_in(
-      hubUtils::read_config_file(
-        fs::path(hub_path, "hub-config", "tasks.json")
-      ),
-      list(
-        "rounds", 1, "model_tasks", 2,
-        "output_type", "sample",
-        "output_type_id_params", "compound_taskid_set"
-      ),
-      ~ c("reference_date", "horizon", "location", "variant")
-    )
+  config_tasks_full_ctids <- purrr::modify_in(
+    hubUtils::read_config_file(
+      fs::path(hub_path, "hub-config", "tasks.json")
+    ),
+    list(
+      "rounds", 1, "model_tasks", 2,
+      "output_type", "sample",
+      "output_type_id_params", "compound_taskid_set"
+    ),
+    ~ c("reference_date", "horizon", "location", "variant")
+  )
 
   mockery::stub(
     check_tbl_spl_compound_taskid_set,

tests/testthat/test-check_tbl_spl_compound_tid.R

@@ -50,10 +50,10 @@ test_that("Overriding compound_taskid_set in check_tbl_spl_compound_tid works",
     c("reference_date", "horizon")
   )
   tbl_coarse <- create_spl_file("2022-10-22",
-                                compound_taskid_set = compound_taskid_set,
-                                write = FALSE,
-                                out_datatype = "chr",
-                                n_samples = 1L
+    compound_taskid_set = compound_taskid_set,
+    write = FALSE,
+    out_datatype = "chr",
+    n_samples = 1L
   )
 
 
@@ -65,9 +65,10 @@ test_that("Overriding compound_taskid_set in check_tbl_spl_compound_tid works",
     )
   )
 
- # Validation providing coarser compound taskid set succeeds
+  # Validation providing coarser compound taskid set succeeds
   expect_snapshot(
     check_tbl_spl_compound_tid(tbl_coarse, round_id, file_path, hub_path,
-                               compound_taskid_set = compound_taskid_set)
+      compound_taskid_set = compound_taskid_set
+    )
   )
 })

tests/testthat/test-check_tbl_spl_n.R

@@ -77,10 +77,10 @@ test_that("Overriding compound_taskid_set in check_tbl_spl_compound_tid works",
     c("reference_date", "horizon")
   )
   tbl_coarse <- create_spl_file("2022-10-22",
-                                compound_taskid_set = compound_taskid_set,
-                                write = FALSE,
-                                out_datatype = "chr",
-                                n_samples = 1L
+    compound_taskid_set = compound_taskid_set,
+    write = FALSE,
+    out_datatype = "chr",
+    n_samples = 1L
   )
 
   # Validation of coarser files should return check failure.
@@ -104,9 +104,9 @@ test_that("Overriding compound_taskid_set in check_tbl_spl_compound_tid works",
 
   # Create 100 spls of each compound idx
   tbl_full <- create_spl_file("2022-10-22",
-                              compound_taskid_set = compound_taskid_set,
-                              write = FALSE,
-                              out_datatype = "chr"
+    compound_taskid_set = compound_taskid_set,
+    write = FALSE,
+    out_datatype = "chr"
   )
 
   # This succeeds!

tests/testthat/test-check_tbl_spl_non_compound_tid.R

@@ -68,6 +68,7 @@ test_that("Overriding compound_taskid_set in check_tbl_spl_compound_tid works",
   # also succeeds.
   expect_snapshot(
     check_tbl_spl_non_compound_tid(tbl_coarse, round_id, file_path, hub_path,
-                               compound_taskid_set = compound_taskid_set)
+      compound_taskid_set = compound_taskid_set
+    )
   )
 })