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).
 - Fixed the sample-based metrics `bias_sample()`, `ae_median_sample()`, `se_mean_sample()` and `mad_sample()` mishandling the documented vector input for a single observation (a scalar `observed` with `predicted` given as a vector of samples). `ae_median_sample()` and `se_mean_sample()` silently treated the samples as separate one-sample forecasts and returned wrong results, while `bias_sample()` and `mad_sample()` errored. All sample metrics now treat this input as one forecast with N samples, consistent with `crps_sample()`. Also corrected the integer bias formula in the `bias_sample()` documentation, which stated P_t(x_t + 1) instead of P_t(x_t - 1) (the code was correct) (#1197).
 - `summarise_scores()` now errors when `by` contains a metric column (e.g. `by = c("model", "wis")`). Previously, such calls silently returned an unsummarised table with duplicate column names, because the score column was used both as a grouping column and as a column to summarise. This complements the fix for the empty-metrics case in #1179 (#1204).
 - Fixed `bias_quantile()` returning wrong values when quantile levels were passed unsorted: predictions were reordered by quantile level but the quantile levels themselves were not, so predictions and levels became mispaired. Also fixed a crash ("argument is of length zero") when `na.rm = TRUE` removed all quantile levels on one side of the median; `bias_quantile()` now returns `NA` in this case, consistent with `na.rm = FALSE` (#1198).

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

@@ -146,10 +146,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

@@ -135,10 +135,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
 # =============================================================================