1199: Error when as_forecast_<type>() renaming would create duplicate columns

NEWS.md

@@ -1,5 +1,6 @@
 # scoringutils (development version)
 
+- Fixed `as_forecast_<type>()` functions silently creating forecast objects with duplicate column names when asked to rename a column onto a name that already exists in the data (e.g. `predicted = "prob"` while a stale `predicted` column is present). This produced corrupted objects that passed validation and were scored on the wrong column. The constructors now error with a clear message, and `assert_forecast_generic()` rejects data with duplicate column names (#1199).
 - 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

@@ -7,6 +7,7 @@
 #' @param ... Named arguments that are used to rename columns. The names of the
 #'  arguments are the names of the columns that should be renamed. The values
 #'  are the new names.
+#' @importFrom cli cli_abort
 #' @keywords as_forecast
 as_forecast_generic <- function(data,
                                 forecast_unit = NULL,
@@ -26,6 +27,24 @@ as_forecast_generic <- function(data,
   oldnames <- unlist(oldnames[provided])
   newnames <- unlist(newnames[provided])
   if (!is.null(oldnames) && length(oldnames) > 0) {
+    # renaming a column onto a name that already exists (and is not itself
+    # being renamed away) would create duplicate column names
+    remaining <- setdiff(colnames(data), oldnames)
+    collides <- newnames %in% remaining
+    if (any(collides)) {
+      # sources/targets are used inside the cli glue strings below
+      sources <- oldnames[collides] # nolint: object_usage_linter.
+      targets <- newnames[collides] # nolint: object_usage_linter.
+      cli_abort(
+        c(
+          `!` = "Cannot rename {cli::qty(sources)} column{?s} {.val {sources}}
+          to {.val {targets}}: {?a column/columns} with {?this name/these
+          names} already exist{?s/} in the data.",
+          i = "Rename or remove the existing {cli::qty(targets)}
+          column{?s} first."
+        )
+      )
+    }
     setnames(data, old = oldnames, new = newnames)
   }
 
@@ -110,6 +129,16 @@ assert_forecast.default <- function(
 assert_forecast_generic <- function(data, verbose = TRUE) {
   # check that data is a data.table and that the columns look fine
   assert_data_table(data, min.rows = 1)
+  duplicated_cols <- unique(colnames(data)[duplicated(colnames(data))])
+  if (length(duplicated_cols) > 0) {
+    cli_abort(
+      c(
+        `!` = "Found duplicate column{?s} in the data:
+        {.val {duplicated_cols}}.",
+        i = "Column names must be unique."
+      )
+    )
+  }
   assert_subset(c("observed", "predicted"), colnames(data))
   problem <- test_subset(c("sample_id", "quantile_level"), colnames(data))
   if (problem) {

tests/testthat/test-class-forecast.R

@@ -4,6 +4,66 @@
 # see tests for each forecast type for more specific tests.
 
 
+test_that("as_forecast_generic() errors when renaming onto an existing column", {
+  # stale `predicted` column alongside the column that should be renamed
+  dt <- data.table::data.table(
+    model = "m",
+    id = 1:2,
+    observed = factor(c(0, 1)),
+    predicted = c(0.9, 0.9),
+    prob = c(0.3, 0.7)
+  )
+  expect_error(
+    as_forecast_binary(dt, predicted = "prob"),
+    'rename column "prob" to "predicted".*already exists'
+  )
+
+  # same for other renameable columns, e.g. `quantile_level`
+  quantile_dt <- data.table::data.table(
+    model = "m",
+    target = "t",
+    observed = 5,
+    predicted = c(1, 5, 9),
+    quantile_level = c(0.1, 0.5, 0.9),
+    q = c(0.1, 0.5, 0.9)
+  )
+  expect_error(
+    as_forecast_quantile(quantile_dt, quantile_level = "q"),
+    'rename column "q" to "quantile_level".*already exists'
+  )
+
+  # multiple collisions produce a correctly pluralised message naming all
+  # source and target columns
+  multi_dt <- data.table::data.table(
+    model = "m",
+    id = 1:2,
+    observed = 1,
+    obs = 2,
+    predicted = 3,
+    prob = 4
+  )
+  expect_error(
+    as_forecast_binary(multi_dt, observed = "obs", predicted = "prob"),
+    paste0(
+      'rename\\s+columns\\s+"obs"\\s+and\\s+"prob"\\s+to\\s+"observed"',
+      '\\s+and\\s+"predicted".*already\\s+exist\\s+in\\s+the\\s+data'
+    )
+  )
+})
+
+test_that("as_forecast_generic() still allows identity renames", {
+  dt <- data.table::data.table(
+    model = "m",
+    id = 1:2,
+    observed = factor(c(0, 1)),
+    predicted = c(0.3, 0.7)
+  )
+  expect_no_condition(
+    as_forecast_binary(dt, observed = "observed", predicted = "predicted")
+  )
+})
+
+
 # ==============================================================================
 # is_forecast() # nolint: commented_code_linter
 # ==============================================================================
@@ -39,6 +99,21 @@ test_that("assert_forecast_generic() works as expected with a data.frame", {
   )
 })
 
+test_that("assert_forecast_generic() errors on duplicate column names", {
+  dt <- data.table::data.table(
+    model = "m",
+    id = 1:2,
+    observed = factor(c(0, 1)),
+    predicted = c(0.3, 0.7),
+    stale = c(0.9, 0.9)
+  )
+  data.table::setnames(dt, "stale", "predicted")
+  expect_error(
+    assert_forecast_generic(dt),
+    "duplicate"
+  )
+})
+
 
 # ==============================================================================
 # new_forecast() # nolint: commented_code_linter