Only allow a single target_keys key value pair

R/create_target_metadata_item.R

@@ -11,13 +11,14 @@
 #' @param target_name character string. A longer human readable target description
 #' that could be used, for example, as a visualisation axis label.
 #' @param target_units character string. Unit of observation of the target.
-#' @param target_keys named list or `NULL`. Should be `NULL`, in the case
-#' where the target is not specified as a task_id but is specified solely through
-#' the `target_id` argument. Otherwise, should be a named list of one or more
-#' character strings. The name of each element should match a task_id variable
-#' within the same model_tasks object. Each element should be of length 1.
-#' Each value, or the combination of values if multiple keys are specified,
-#' define a single target value.
+#' @param target_keys named list or `NULL`. The `target_keys` value defines a
+#' single target.
+#' Should be `NULL`, in the case where the target is not specified as a task_id
+#' but is specified solely through the `target_id` argument.
+#' Otherwise, should be a named list containing a single character string element.
+#' The name of the element should match a `task_id`
+#' variable name within the same `model_tasks` object and the value should match
+#' a single value of that variable.
 #' @param description character string (optional). An optional verbose description
 #' of the target that might include information such as definitions of a 'rate' or similar.
 #' @param target_type character string. Target statistical data type. Consult the
@@ -117,7 +118,7 @@ create_target_metadata_item <- function(target_id, target_name, target_units,
     }
   )
 
-  check_target_keys(target_keys, call = call)
+  check_target_keys(target_keys, schema_version, call = call)
 
   structure(mget(property_names),
     class = c("target_metadata_item", "list"),
@@ -127,7 +128,8 @@ create_target_metadata_item <- function(target_id, target_name, target_units,
   )
 }
 
-check_target_keys <- function(target_keys, call = rlang::caller_env()) {
+check_target_keys <- function(target_keys, schema_version,
+                              call = rlang::caller_env()) {
   if (is.null(target_keys)) {
     return()
   }
@@ -149,6 +151,20 @@ check_target_keys <- function(target_keys, call = rlang::caller_env()) {
       call = call
     )
   }
+  is_gte_v4_0_1 <- hubUtils::version_gte(
+    "v4.0.1",
+    schema_version = schema_version
+  )
+  target_key_n <- length(target_keys)
+  if (is_gte_v4_0_1 && target_key_n > 1L) {
+    cli::cli_abort(
+      c(
+        "!" = "{.arg target_keys} must be a named {.cls list} of
+        length {.val {1L}} not {.val {target_key_n}}."
+      ),
+      call = call
+    )
+  }
 
   purrr::walk2(
     target_keys,

tests/testthat/_snaps/create_target_metadata_item.md

@@ -162,3 +162,14 @@
       - "https://raw.githubusercontent.com/hubverse-org/schemas/main/v3.0.1/tasks-schema.json"
       + "https://raw.githubusercontent.com/hubverse-org/schemas/main/v4.0.0/tasks-schema.json"
 
+# Target_keys of length more than 1 are not allowed post v4.0.1
+
+    Code
+      create_target_metadata_item(target_id = "flu inc hosp", target_name = "Weekly incident influenza hospitalizations",
+        target_units = "rate per 100,000 population", target_keys = list(target = "flu",
+          target_metric = "inc hosp"), target_type = "discrete", is_step_ahead = TRUE,
+        time_unit = "week")
+    Condition
+      Error in `create_target_metadata_item()`:
+      ! `target_keys` must be a named <list> of length 1 not 2.
+

tests/testthat/test-create_output_type_item.R

@@ -452,7 +452,7 @@ test_that("schema version option works for create_output_type_mean", {
   withr::with_options(
     list(
       hubAdmin.schema_version = "v3.0.1",
-      hubAmin.branch = "main"
+      hubAdmin.branch = "main"
     ),
     {
       opt_version <- create_output_type_mean(
@@ -493,7 +493,7 @@ test_that("schema version option works for create_output_type_quantile", {
   withr::with_options(
     list(
       hubAdmin.schema_version = "v3.0.1",
-      hubAmin.branch = "main"
+      hubAdmin.branch = "main"
     ),
     {
       opt_version <- create_output_type_quantile(
@@ -543,7 +543,7 @@ test_that("schema version option works for create_output_type_cdf", {
   withr::with_options(
     list(
       hubAdmin.schema_version = "v3.0.1",
-      hubAmin.branch = "main"
+      hubAdmin.branch = "main"
     ),
     {
       opt_version <- create_output_type_cdf(
@@ -590,7 +590,7 @@ test_that("schema version option works for create_output_type_pmf", {
   withr::with_options(
     list(
       hubAdmin.schema_version = "v3.0.1",
-      hubAmin.branch = "main"
+      hubAdmin.branch = "main"
     ),
     {
       opt_version <- create_output_type_pmf(

tests/testthat/test-create_target_metadata_item.R

@@ -131,7 +131,7 @@ test_that("schema version option works for create_target_metadata_item", {
   withr::with_options(
     list(
       hubAdmin.schema_version = "v3.0.1",
-      hubAmin.branch = "main"
+      hubAdmin.branch = "main"
     ),
     {
       opt_version <- create_target_metadata_item(
@@ -148,3 +148,69 @@ test_that("schema version option works for create_target_metadata_item", {
   expect_equal(arg_version, opt_version)
   expect_snapshot(waldo::compare(opt_version, version_default))
 })
+
+test_that("Target_keys of length more than 1 are not allowed post v4.0.1", {
+  skip_if_offline()
+  withr::with_options(
+    list(
+      hubAdmin.schema_version = "v4.0.1",
+      # TDOD: remove branch argument when v4.0.1 is released.
+      hubAdmin.branch = "ak/v4.0.1/restrict-target-key-value-pair-n/117"
+    ),
+    {
+      # One target_key is allowed in v4.0.1 and later versions.
+      target_keys_n1 <- create_target_metadata_item(
+        target_id = "inc hosp",
+        target_name = "Weekly incident influenza hospitalizations",
+        target_units = "rate per 100,000 population",
+        target_keys = list(target = "inc hosp"),
+        target_type = "discrete",
+        is_step_ahead = TRUE,
+        time_unit = "week"
+      )
+      expect_s3_class(target_keys_n1, "target_metadata_item")
+      expect_length(target_keys_n1$target_keys, 1L)
+
+      # More than one target_key is NOT allowed in v4.0.1 and later versions
+      # and throws error.
+      expect_snapshot(
+        create_target_metadata_item(
+          target_id = "flu inc hosp",
+          target_name = "Weekly incident influenza hospitalizations",
+          target_units = "rate per 100,000 population",
+          target_keys = list(
+            target = "flu",
+            target_metric = "inc hosp"
+          ),
+          target_type = "discrete",
+          is_step_ahead = TRUE,
+          time_unit = "week"
+        ),
+        error = TRUE
+      )
+    }
+  )
+  # More than 1 target_keys still allowed in earlier versions to conform to
+  # schema.
+  withr::with_options(
+    list(
+      hubAdmin.schema_version = "v4.0.0"
+    ),
+    {
+      target_keys_n2 <- create_target_metadata_item(
+        target_id = "flu inc hosp",
+        target_name = "Weekly incident influenza hospitalizations",
+        target_units = "rate per 100,000 population",
+        target_keys = list(
+          target = "flu",
+          target_metric = "inc hosp"
+        ),
+        target_type = "discrete",
+        is_step_ahead = TRUE,
+        time_unit = "week"
+      )
+      expect_s3_class(target_keys_n2, "target_metadata_item")
+      expect_length(target_keys_n2$target_keys, 2L)
+    }
+  )
+})

tests/testthat/test-create_task_id.R

@@ -114,7 +114,7 @@ test_that("schema version option works for create_task_id", {
   withr::with_options(
     list(
       hubAdmin.schema_version = "v3.0.1",
-      hubAmin.branch = "main"
+      hubAdmin.branch = "main"
     ),
     {
       opt_version <- create_task_id("horizon",

tests/testthat/test-download_tasks_schema.R

@@ -40,7 +40,7 @@ test_that("schema version option works for download_tasks_schema", {
 
   withr::with_options(
     list(hubAdmin.schema_version = "v3.0.1",
-         hubAmin.branch = "main"),
+         hubAdmin.branch = "main"),
     {
       opt_version <- download_tasks_schema()
     }

tests/testthat/test-validate_config.R

@@ -41,7 +41,7 @@ test_that("Missing files returns an invalid config with an immediate message", {
   suppressMessages({
     expect_message(out <- validate_config(hub_path = tmp), "File does not exist")
   })
-  expect_false(out)
+  expect_false(unclass(out))
 })
 test_that("Config for samples fail correctly", {
   skip_if_offline()
@@ -251,3 +251,35 @@ test_that("v4 validation works", {
     )
   )
 })
+
+test_that("v4.0.1 target keys with 2 properties throws error", {
+  skip_if_offline()
+  config_path <- testthat::test_path("testdata", "v4.0.1-tasks-2-target_keys.json")
+  out <- suppressMessages(
+    validate_config(
+      config_path = config_path,
+      # TDOD: remove branch argument when v4.0.1 is released.
+      branch = "ak/v4.0.1/restrict-target-key-value-pair-n/117"
+    )
+  )
+  expect_false(out)
+
+  expect_equal(
+    unique(attr(out, "errors")$message),
+    "must NOT have more than 1 items"
+  )
+  expect_equal(nrow(attr(out, "errors")), 2L)
+})
+
+test_that("v4.0.1 target keys with NULL properties passes", {
+  # Ensure NULL target keys are still allowed.
+  config_path <- testthat::test_path("testdata", "v4.0.1-tasks-null-target_keys.json")
+  out <- suppressMessages(
+    validate_config(
+      config_path = config_path,
+      # TDOD: remove branch argument when v4.0.1 is released.
+      branch = "ak/v4.0.1/restrict-target-key-value-pair-n/117"
+    )
+  )
+  expect_true(out)
+})

tests/testthat/test-validate_model_metadata_schema.R

@@ -6,7 +6,7 @@ test_that("Missing files returns an invalid config with an immediate message", {
       "File does not exist"
     )
   })
-  expect_false(out)
+  expect_false(unclass(out))
 })
 
 test_that("validate_model_metadata_schema works", {
@@ -28,7 +28,7 @@ test_that("validate_model_metadata_schema works", {
       )
     )
   )
-  expect_false(out_error)
+  expect_false(unclass(out_error))
   expect_snapshot(out_error) # prints .Last.value
   expect_snapshot(print(out_error)) # prints out_error
   expect_snapshot(str(attr(out_error, "errors")))
@@ -51,6 +51,6 @@ test_that("validate_model_metadata_schema errors for imparsable json", {
       "SyntaxError"
     )
   })
-  expect_false(out)
+  expect_false(unclass(out))
 
 })