1201: Error on conflicting observed values within a forecast unit

NEWS.md

@@ -1,5 +1,6 @@
 # scoringutils (development version)
 
+- Forecast validation now errors when the same forecast unit has conflicting observed values. Previously, such invalid data passed validation for quantile, sample, nominal, ordinal and multivariate sample forecasts and `score()` silently returned multiple wrong score rows for a single forecast (#1201).
 - Added `filter_scores()` and `impute_missing_scores()` for handling missing forecasts before summarisation. `filter_scores()` removes target combinations with insufficient model coverage, while `impute_missing_scores()` fills in missing scores using configurable strategies (worst, mean, NA, or reference model). Both use a strategy function pattern for extensibility. See `vignette("handling-missing-forecasts")` for details (#1122).
 - Added `plot_discrimination()` to visualise the discrimination ability of binary forecasts by plotting the distribution of predicted probabilities, stratified by the observed outcome. The function requires a `forecast_binary` object (created with `as_forecast_binary()`) (#942).
 - Fixed `summarise_scores()` producing a data.table with duplicate column names when the input `scores` object had no score columns (e.g. because every metric in `score()` warned and returned nothing). `summarise_scores()` now matches metric columns by exact name rather than regex partial match, and errors with a clear message when there is nothing to summarise (#1179).

R/class-forecast.R

@@ -97,6 +97,7 @@ assert_forecast.default <- function(
 #' `predicted`
 #' - checks the forecast type and forecast unit
 #' - checks there are no duplicate forecasts
+#' - checks that observed values are constant within each forecast unit
 #' - if appropriate, checks the number of samples / quantiles is the same
 #' for all forecasts.
 #' @param data A data.table with forecasts and observed values that should
@@ -125,6 +126,9 @@ assert_forecast_generic <- function(data, verbose = TRUE) {
   forecast_unit <- get_forecast_unit(data)
   assert(check_duplicates(data))
 
+  # check that observed values are constant within each forecast unit
+  assert(check_observed_constant(data, forecast_unit))
+
   # check that the number of forecasts per sample / quantile level is the same
   number_quantiles_samples <- check_number_per_forecast(data, forecast_unit)
   if (!isTRUE(number_quantiles_samples) && verbose) {
@@ -189,6 +193,37 @@ check_number_per_forecast <- function(data, forecast_unit) {
 }
 
 
+#' Check that observed values are constant within each forecast unit
+#' @description
+#' Helper function that checks that all rows belonging to the same forecast
+#' (as defined by the forecast unit) share a single observed value. Rows
+#' where `observed` is `NA` are ignored.
+#' If the observed values are constant within each forecast unit, the
+#' function returns `TRUE` and a string with an error message otherwise.
+#' @param forecast_unit Character vector denoting the unit of a single forecast.
+#' @importFrom data.table as.data.table uniqueN
+#' @inherit document_check_functions params return
+#' @keywords internal_input_check
+check_observed_constant <- function(data, forecast_unit) {
+  # This function doesn't return a forecast object so it's fine to unclass it
+  # to avoid validation error while subsetting
+  data <- as.data.table(data)
+  data <- data[!is.na(observed)]
+  data <- data[, .(scoringutils_InternalNumCheck = uniqueN(observed)),
+               by = forecast_unit]
+  if (any(data$scoringutils_InternalNumCheck > 1)) {
+    msg <- paste0(
+      "There are instances with different observed values for the ",
+      "same forecast. Observed values must be constant within each ",
+      "forecast unit. This can't be right and needs to be resolved. ",
+      "Maybe you need to check the unit of a single forecast and ",
+      "add missing columns?"
+    )
+    return(msg)
+  }
+  return(TRUE)
+}
+
 
 #' Clean forecast object
 #' @description

tests/testthat/test-class-forecast-ordinal.R

@@ -30,6 +30,21 @@ test_that("as_forecast.forecast_ordinal() breaks when rows with zero probability
   )
 })
 
+test_that("as_forecast_ordinal() errors on conflicting observed values in a forecast unit", {
+  expect_error(
+    as_forecast_ordinal(data.table::data.table(
+      model = "m1", target = "t1",
+      predicted_label = factor(c("a", "b", "c"), ordered = TRUE),
+      predicted = c(0.2, 0.3, 0.5),
+      observed = factor(
+        c("a", "a", "b"),
+        levels = c("a", "b", "c"), ordered = TRUE
+      )
+    )),
+    "different observed values"
+  )
+})
+
 test_that("assert_forecast.forecast_ordinal() fails if factors are not ordered", {
   ex_faulty <- na.omit(data.table::copy(example_nominal))
   expect_error(

tests/testthat/test-class-forecast.R

@@ -324,6 +324,102 @@ test_that("check_number_per_forecast works", {
 })
 
 
+# ==============================================================================
+# check_observed_constant() # nolint: commented_code_linter
+# ==============================================================================
+test_that("check_observed_constant() works as expected", {
+  consistent <- data.table::data.table(
+    model = "m1", target = "t1",
+    quantile_level = c(0.25, 0.5, 0.75),
+    predicted = 1:3,
+    observed = 10
+  )
+  expect_true(
+    check_observed_constant(consistent, forecast_unit = c("model", "target"))
+  )
+
+  conflicting <- data.table::copy(consistent)
+  conflicting$observed <- c(10, 10, 20)
+  result <- check_observed_constant(
+    conflicting,
+    forecast_unit = c("model", "target")
+  )
+  expect_type(result, "character")
+  expect_match(result, "different observed values")
+})
+
+test_that("check_observed_constant() ignores rows with NA observed values", {
+  dt <- data.table::data.table(
+    model = "m1", target = "t1",
+    sample_id = 1:4,
+    predicted = c(1, 2, 3, 4),
+    observed = c(5, 5, 5, NA)
+  )
+  expect_true(
+    check_observed_constant(dt, forecast_unit = c("model", "target"))
+  )
+})
+
+test_that("validation errors on conflicting observed values in a forecast unit", {
+  # quantile
+  expect_error(
+    as_forecast_quantile(data.table::data.table(
+      model = "m1", target = "t1",
+      quantile_level = c(0.25, 0.5, 0.75),
+      predicted = 1:3,
+      observed = c(10, 10, 20)
+    )),
+    "different observed values"
+  )
+
+  # sample
+  expect_error(
+    as_forecast_sample(data.table::data.table(
+      model = "m1", target = "t1",
+      sample_id = 1:4,
+      predicted = c(1, 2, 3, 4),
+      observed = c(5, 5, 5, 7)
+    )),
+    "different observed values"
+  )
+
+  # nominal
+  expect_error(
+    as_forecast_nominal(data.table::data.table(
+      model = "m1", target = "t1",
+      predicted_label = factor(c("a", "b", "c")),
+      predicted = c(0.2, 0.3, 0.5),
+      observed = factor(c("a", "a", "b"), levels = c("a", "b", "c"))
+    )),
+    "different observed values"
+  )
+})
+
+test_that("validation still passes when observed is constant apart from NAs", {
+  dt <- data.table::data.table(
+    model = "m1", target = "t1",
+    sample_id = 1:4,
+    predicted = c(1, 2, 3, 4),
+    observed = c(5, 5, 5, NA)
+  )
+  expect_s3_class(
+    suppressMessages(as_forecast_sample(dt)),
+    "forecast_sample"
+  )
+})
+
+test_that("multivariate sample forecasts with constant observed still validate", {
+  # observed varies across the multivariate group but not within a single
+  # (univariate) forecast unit, so this must not trigger the constancy check
+  expect_no_condition(
+    as_forecast_multivariate_sample(
+      na.omit(data.table::copy(example_sample_continuous)),
+      joint_across = c("location", "location_name")
+    )
+  )
+})
+
+
 # ==============================================================================
 # Test removing `NA` values from the data # nolint: commented_code_linter
 # ==============================================================================