Fix duplicate column names from summarise_scores() with empty metrics (#1179)

NEWS.md

@@ -1,6 +1,7 @@
 # scoringutils (development version)
 
 - 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).
 - Added internal S3 generic `get_forecast_type_ids()` so each forecast type declares the columns (beyond the forecast unit) that identify a unique row. `get_duplicate_forecasts()` now uses this instead of hard-coded column names (#888).
 - Removed the deprecated vignettes `Deprecated-functions` and `Deprecated-visualisations`. The code for removed functions (`plot_predictions()`, `make_NA()`, `plot_ranges()`, `plot_score_table()`, `merge_pred_and_obs()`) can still be found in the [git history](https://github.com/epiforecasts/scoringutils/tree/d0cd8e2/vignettes) (#1158).
 

R/summarise_scores.R

@@ -46,6 +46,7 @@
 #' @export
 #' @importFrom checkmate assert_subset assert_function test_subset
 #'   assert_data_frame
+#' @importFrom cli cli_abort
 #' @keywords scoring
 
 summarise_scores <- function(scores,
@@ -59,11 +60,23 @@ summarise_scores <- function(scores,
   assert_function(fun)
 
   metrics <- get_metrics.scores(scores, error = TRUE)
+  metric_cols <- intersect(colnames(scores), metrics)
+  if (length(metric_cols) == 0) {
+    cli_abort(
+      c(
+        `!` = "No score columns to summarise.",
+        i = "The {.cls scores} object has no columns matching its
+             {.code metrics} attribute. This usually means every metric
+             passed to {.fn score} failed (e.g. warned and returned no
+             values)."
+      )
+    )
+  }
 
   # summarise scores -----------------------------------------------------------
   scores <- scores[, lapply(.SD, fun, ...),
     by = c(by),
-    .SDcols = colnames(scores) %like% paste(metrics, collapse = "|")
+    .SDcols = metric_cols
   ]
 
   attr(scores, "metrics") <- metrics

tests/testthat/test-summarise_scores.R

@@ -71,3 +71,53 @@ test_that("summarise_scores() errors if `by = NULL", {
     "Assertion on 'by' failed: Must be a subset of"
   )
 })
+
+test_that("summarise_scores() errors if there are no score columns", {
+  # mimics the situation in which every metric passed to `score()` failed:
+  # `scores` carries an empty `metrics` attribute, so there is nothing to
+  # summarise. Previously this silently produced a data.table with a
+  # duplicate `by` column (gh #1179).
+  empty_scores <- data.table::copy(scores_quantile)
+  metric_cols <- attr(empty_scores, "metrics")
+  empty_scores[, (metric_cols) := NULL]
+  attr(empty_scores, "metrics") <- character(0)
+
+  expect_error(
+    summarise_scores(empty_scores, by = "model"),
+    "No score columns to summarise"
+  )
+})
+
+test_that("summarise_scores() errors on the empty-metrics reprex (#1179)", {
+  # end-to-end version of the issue reprex: the 55% interval requires the
+  # 0.225 and 0.775 quantiles, which are absent from `example_quantile`, so
+  # the only metric warns and produces no score columns. `summarise_scores()`
+  # should then error rather than return a data.table with a duplicate `by`
+  # column (gh #1179).
+  fc <- as_forecast_quantile(example_quantile)
+  expect_warning(
+    sc <- score(fc, metrics = list(
+      interval_coverage_55 = purrr::partial(
+        interval_coverage,
+        interval_range = 55
+      )
+    )),
+    "interval coverage"
+  )
+  expect_length(intersect(colnames(sc), attr(sc, "metrics")), 0)
+
+  expect_error(
+    summarise_scores(sc, by = "model"),
+    "No score columns to summarise"
+  )
+})
+
+test_that("summarise_scores() does not partial-match metric names", {
+  # ensures we use exact column matching rather than regex partial matching:
+  # a metric named e.g. "wis" should not pull in a column called
+  # "wis_something_else" that happens to share a prefix.
+  test <- data.table::copy(scores_quantile)
+  test[, wis_extra := 0]
+  result <- summarise_scores(test, by = "model")
+  expect_false("wis_extra" %in% colnames(result))
+})