diff --git a/NEWS.md b/NEWS.md index 23bdc1ba9..0f42a87d2 100644 --- a/NEWS.md +++ b/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). diff --git a/R/summarise_scores.R b/R/summarise_scores.R index 4f2eafe22..acf53e9f9 100644 --- a/R/summarise_scores.R +++ b/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 diff --git a/tests/testthat/test-summarise_scores.R b/tests/testthat/test-summarise_scores.R index e5b61fe32..b7088b9c3 100644 --- a/tests/testthat/test-summarise_scores.R +++ b/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)) +})