941: Consolidate score() input preparation into a single helper

NEWS.md

@@ -1,5 +1,6 @@
 # scoringutils (development version)
 
+- Added an internal helper `prepare_forecast_for_scoring()` that consolidates the input preparation steps previously duplicated across the `score()` methods: cleaning the forecast, validating the metrics and converting to a plain `data.table`, plus determining the forecast unit for the methods that need it (#941).
 - 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-binary.R

@@ -103,9 +103,9 @@ is_forecast_binary <- function(x) {
 #' @rdname score
 #' @export
 score.forecast_binary <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
 
   scores <- apply_metrics(
     forecast, metrics,

R/class-forecast-multivariate-point.R

@@ -107,11 +107,9 @@ is_forecast_multivariate_point <- function(x) {
 score.forecast_multivariate_point <- function(
   forecast, metrics = get_metrics(forecast), ...
 ) {
-  forecast <- clean_forecast(
-    forecast, copy = TRUE, na.omit = TRUE
-  )
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
 
   observed <- forecast$observed
   predicted <- matrix(forecast$predicted, ncol = 1)

R/class-forecast-multivariate-sample.R

@@ -144,10 +144,10 @@ is_forecast_multivariate_sample <- function(x) {
 #' @rdname score
 #' @export
 score.forecast_multivariate_sample <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  forecast_unit <- get_forecast_unit(forecast)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
+  forecast_unit <- prep$forecast_unit
 
   # transpose the forecasts that belong to the same forecast unit
   f_transposed <- forecast[, .(

R/class-forecast-nominal.R

@@ -134,10 +134,10 @@ is_forecast_nominal <- function(x) {
 #' @rdname score
 #' @export
 score.forecast_nominal <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  forecast_unit <- get_forecast_unit(forecast)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
+  forecast_unit <- prep$forecast_unit
 
   # transpose the forecasts that belong to the same forecast unit
   # make sure the labels and predictions are ordered in the same way

R/class-forecast-ordinal.R

@@ -140,10 +140,10 @@ is_forecast_ordinal <- function(x) {
 #' @rdname score
 #' @export
 score.forecast_ordinal <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  forecast_unit <- get_forecast_unit(forecast)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
+  forecast_unit <- prep$forecast_unit
 
   # transpose the forecasts that belong to the same forecast unit
   # make sure the labels and predictions are ordered in the same way

R/class-forecast-point.R

@@ -80,9 +80,9 @@ is_forecast_point <- function(x) {
 #' @rdname score
 #' @export
 score.forecast_point <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
 
   scores <- apply_metrics(
     forecast, metrics,

R/class-forecast-quantile.R

@@ -133,10 +133,10 @@ as_forecast_point.forecast_quantile <- function(data, ...) {
 #' @rdname score
 #' @export
 score.forecast_quantile <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  forecast_unit <- get_forecast_unit(forecast)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
+  forecast_unit <- prep$forecast_unit
 
   # transpose the forecasts that belong to the same forecast unit
   # make sure the quantiles and predictions are ordered in the same way

R/class-forecast-sample.R

@@ -129,10 +129,10 @@ as_forecast_quantile.forecast_sample <- function(
 #' @rdname score
 #' @export
 score.forecast_sample <- function(forecast, metrics = get_metrics(forecast), ...) {
-  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
-  forecast_unit <- get_forecast_unit(forecast)
-  metrics <- validate_metrics(metrics)
-  forecast <- as.data.table(forecast)
+  prep <- prepare_forecast_for_scoring(forecast, metrics)
+  forecast <- prep$forecast
+  metrics <- prep$metrics
+  forecast_unit <- prep$forecast_unit
 
   # transpose the forecasts that belong to the same forecast unit
   f_transposed <- forecast[, .(predicted = list(predicted),

R/score.R

@@ -132,6 +132,44 @@ score.default <- function(forecast, metrics, ...) {
 }
 
 
+#' @title Prepare a forecast object for scoring
+#'
+#' @description
+#' This function performs the input preparation steps shared by all
+#' [score()] methods: it validates and cleans the forecast object (removing
+#' rows with missing values), determines the forecast unit, validates the
+#' metrics, and converts the forecast to a plain `data.table`.
+#'
+#' The metrics are validated within this function so that the lazy default
+#' `metrics = get_metrics(forecast)` of the [score()] methods is forced
+#' before those methods rebind `forecast` to a plain `data.table` (there is
+#' no `get_metrics.default()`, so forcing the default after that rebind
+#' would fail). The default is thereby evaluated on the original forecast
+#' object passed to [score()], i.e. before rows with missing values are
+#' removed. This makes no difference for the built-in [get_metrics()]
+#' methods, which do not inspect the data.
+#'
+#' @inheritParams score
+#' @param metrics A named list of scoring functions. See [score()] for
+#'   details.
+#' @returns A list with three elements: `forecast` (the cleaned forecast as
+#'   a plain `data.table`), `metrics` (the validated list of metrics) and
+#'   `forecast_unit` (a character vector with the columns that define the
+#'   unit of a single forecast).
+#' @importFrom data.table as.data.table
+#' @keywords internal
+prepare_forecast_for_scoring <- function(forecast, metrics) {
+  forecast <- clean_forecast(forecast, copy = TRUE, na.omit = TRUE)
+  forecast_unit <- get_forecast_unit(forecast)
+  metrics <- validate_metrics(metrics)
+  list(
+    forecast = as.data.table(forecast),
+    metrics = metrics,
+    forecast_unit = forecast_unit
+  )
+}
+
+
 #' @title Apply a list of functions to a data table of forecasts
 #' @description
 #' This helper function applies scoring rules (stored as a list of

tests/testthat/test-score.R

@@ -108,6 +108,33 @@ test_that("function produces output for a nominal format case", {
 })
 
 
+# test ordinal case ------------------------------------------------------------
+test_that("function produces output for an ordinal format case", {
+  expect_no_condition(score(as_forecast_ordinal(na.omit(example_ordinal))))
+})
+
+
+# =============================================================================
+# prepare_forecast_for_scoring() # nolint: commented_code_linter
+# =============================================================================
+
+test_that("prepare_forecast_for_scoring() prepares a forecast for scoring", {
+  input <- data.table::copy(example_quantile)
+  prep <- prepare_forecast_for_scoring(input, get_metrics(input))
+  expect_named(prep, c("forecast", "metrics", "forecast_unit"))
+
+  # the forecast is returned as a plain data.table with NA rows removed
+  expect_s3_class(prep$forecast, c("data.table", "data.frame"), exact = TRUE)
+  expect_identical(nrow(prep$forecast), nrow(na.omit(example_quantile)))
+
+  # the input is not modified by reference
+  expect_identical(input, example_quantile)
+
+  expect_identical(prep$metrics, get_metrics(example_quantile))
+  expect_identical(prep$forecast_unit, get_forecast_unit(example_quantile))
+})
+
+
 # =============================================================================
 # apply_metrics() # nolint: commented_code_linter
 # =============================================================================