Validate forecasts only twice in transform_forecasts() (#1236)

NEWS.md

@@ -1,5 +1,7 @@
 # scoringutils (development version)
 
+- `transform_forecasts()` is faster: it now validates the forecast object twice (input and output) instead of after every internal update to it. On a forecast hub-sized example, it takes about half as long as before. With `append = FALSE`, a transformation that produces an invalid forecast now errors, as it already did with `append = TRUE`, instead of returning the invalid forecast with validation warnings (#1236).
+
 # scoringutils 2.3.0
 
 This release adds tools for handling missing forecasts (`filter_scores()`, `impute_missing_scores()`), a new `plot_discrimination()` for binary forecasts, and a much faster `get_pairwise_comparisons()`. It also fixes a number of bugs, several of which silently produced wrong scores. Many of these fixes mean that invalid input which was previously accepted now raises an error. Please read the "Breaking changes" section below if you are upgrading.

R/transform-forecasts.R

@@ -44,7 +44,9 @@
 #'   has the value passed to the argument `label`).
 #'
 #' @param label A string for the newly created 'scale' column to denote the
-#'   newly transformed values. Only relevant if `append = TRUE`.
+#'   newly transformed values. Only relevant if `append = TRUE` or if the
+#'   forecast already has a 'scale' column. In the latter case, `label` must
+#'   not already be present in that column.
 #'
 #' @param ... Additional parameters to pass to the function you supplied. For
 #'   the default option of [log_shift()] this could be the `offset` argument.
@@ -144,71 +146,11 @@ transform_forecasts.forecast <- function(forecast,
                                          append = TRUE,
                                          label = "log",
                                          ...) {
-  original_forecast <- clean_forecast(forecast, copy = TRUE)
-  assert_function(fun)
-  assert_logical(append, len = 1)
-  assert_character(label, len = 1)
-
-  forecast_type <- get_forecast_type(original_forecast)
-  scale_col_present <- ("scale" %in% colnames(original_forecast))
-
-  if (scale_col_present) {
-    if (!("natural" %in% original_forecast$scale)) {
-      cli_abort(
-        c(
-          `!` = "If a column 'scale' is present, entries with
-          scale =='natural' are required for the transformation."
-        )
-      )
-    }
-    if (append && (label %in% original_forecast$scale)) {
-      cli_warn(
-        c(
-          i = "Appending new transformations with label
-          '{label}' even though that entry is already present
-          in column 'scale'."
-        )
-      )
-    }
-  }
-
-  if (append) {
-    if (scale_col_present) {
-      transformed_forecast <- copy(
-        original_forecast
-      )[scale == "natural"]
-    } else {
-      transformed_forecast <- copy(original_forecast)
-      original_forecast[, scale := "natural"]
-    }
-    transformed_forecast[, predicted := fun(predicted, ...)]
-    transformed_forecast[, observed := fun(observed, ...)]
-    transformed_forecast[, scale := label]
-    out <- rbind(original_forecast, transformed_forecast)
-
-    fn_name <- paste0("as_forecast_", forecast_type)
-    fn <- get(fn_name)
-    out <- suppressWarnings(suppressMessages(
-      fn(data = out)
-    ))
-    return(out[])
-  }
-
-  if (scale_col_present) {
-    original_forecast[
-      scale == "natural",
-      predicted := fun(predicted, ...)
-    ]
-    original_forecast[
-      scale == "natural",
-      observed := fun(observed, ...)
-    ]
-    original_forecast[scale == "natural", scale := label]
-  } else {
-    original_forecast[, predicted := fun(predicted, ...)]
-    original_forecast[, observed := fun(observed, ...)]
-  }
-  return(original_forecast[])
+  out <- transform_forecast_data(forecast, fun, append, label, ...)
+  fn <- get(paste0("as_forecast_", get_forecast_type(forecast)))
+  suppressWarnings(suppressMessages(
+    fn(data = out)
+  ))
 }
 
 
@@ -221,18 +163,18 @@ transform_forecasts.forecast_multivariate_sample <- function(
     append = TRUE,
     label = "log",
     ...) {
-  out <- transform_forecasts.forecast(
-    forecast, fun, append, label, ...
-  )
-  if (!append) return(out)
+  out <- transform_forecast_data(forecast, fun, append, label, ...)
+  fn <- get(paste0("as_forecast_", get_forecast_type(forecast)))
+  # without appending, the rows (and therefore the groups) are unchanged and
+  # the existing `.mv_group_id` can be kept
+  if (!append) {
+    return(suppressWarnings(suppressMessages(fn(data = out))))
+  }
   joint_across <- setdiff(
     get_forecast_unit(forecast),
     get_grouping(forecast)
   )
-  out <- as.data.table(out)
   out[, .mv_group_id := NULL]
-  forecast_type <- get_forecast_type(forecast)
-  fn <- get(paste0("as_forecast_", forecast_type))
   suppressWarnings(suppressMessages(
     fn(data = out, joint_across = joint_across)
   ))
@@ -256,6 +198,86 @@ transform_forecasts.forecast_multivariate_point <- function(
 # nolint end
 
 
+#' @title Apply a transformation to the data of a forecast object
+#'
+#' @description
+#' Internal helper for the [transform_forecasts()] methods. It validates the
+#' forecast object once and then applies the transformation to a plain
+#' `data.table` copy of it. Working on a plain `data.table` avoids
+#' `[.forecast`, which re-validates the whole forecast object after every
+#' `:=` update. The caller is responsible for turning the result back into
+#' a forecast object (which validates it once more).
+#'
+#' @inheritParams transform_forecasts
+#' @returns A plain `data.table` with the transformed (and, if
+#'   `append = TRUE`, the original) forecasts.
+#' @importFrom data.table as.data.table
+#' @keywords internal
+transform_forecast_data <- function(forecast, fun, append, label, ...) {
+  # as.data.table() copies, so the input is not modified
+  data <- as.data.table(clean_forecast(forecast))
+  assert_function(fun)
+  assert_logical(append, len = 1)
+  assert_character(label, len = 1)
+
+  scale_col_present <- ("scale" %in% colnames(data))
+
+  if (scale_col_present) {
+    if (!("natural" %in% data$scale)) {
+      cli_abort(
+        c(
+          `!` = "If a column 'scale' is present, entries with
+          scale =='natural' are required for the transformation."
+        )
+      )
+    }
+    if (!append && (label %in% data$scale)) {
+      cli_abort(
+        c(
+          `!` = "Can't transform with label '{label}': that entry is
+          already present in column 'scale'.",
+          i = "With {.code append = FALSE}, the 'natural' entries are
+          replaced by the transformed ones. Choose a different
+          {.arg label}."
+        )
+      )
+    }
+    if (append && (label %in% data$scale)) {
+      cli_warn(
+        c(
+          i = "Appending new transformations with label
+          '{label}' even though that entry is already present
+          in column 'scale'."
+        )
+      )
+    }
+  }
+
+  if (append) {
+    if (scale_col_present) {
+      transformed <- data[scale == "natural"]
+    } else {
+      transformed <- copy(data)
+      data[, scale := "natural"]
+    }
+    transformed[, predicted := fun(predicted, ...)]
+    transformed[, observed := fun(observed, ...)]
+    transformed[, scale := label]
+    return(rbind(data, transformed))
+  }
+
+  if (scale_col_present) {
+    data[scale == "natural", predicted := fun(predicted, ...)]
+    data[scale == "natural", observed := fun(observed, ...)]
+    data[scale == "natural", scale := label]
+  } else {
+    data[, predicted := fun(predicted, ...)]
+    data[, observed := fun(observed, ...)]
+  }
+  return(data[])
+}
+
+
 #' @title Log transformation with an additive shift
 #'
 #' @description

tests/testthat/test-transform-forecasts.R

@@ -60,6 +60,83 @@ test_that("transform_forecasts() outputs an object of class forecast_*", {
   expect_s3_class(transformed, "forecast_binary")
 })
 
+test_that("transform_forecasts() validates the forecast only twice", {
+  # once for the input and once for the output, not after every internal `:=`
+  # update (#1236)
+  counter <- new.env()
+  assert_forecast_generic_orig <- assert_forecast_generic
+  local_mocked_bindings(
+    assert_forecast_generic = function(...) {
+      counter$n <- counter$n + 1
+      assert_forecast_generic_orig(...)
+    }
+  )
+  add_one <- function(x) x + 1
+  forecast <- na.omit(example_quantile)
+  counter$n <- 0
+  transform_forecasts(forecast, fun = add_one)
+  expect_identical(counter$n, 2)
+
+  counter$n <- 0
+  transform_forecasts(forecast, fun = add_one, append = FALSE)
+  expect_identical(counter$n, 2)
+
+  for (append in c(TRUE, FALSE)) {
+    counter$n <- 0
+    transform_forecasts(example_multivariate_sample, fun = add_one, append = append)
+    expect_identical(counter$n, 2)
+  }
+})
+
+test_that("transform_forecasts() does not modify its input", {
+  add_one <- function(x) x + 1
+  forecast <- data.table::copy(na.omit(example_quantile))
+  original <- data.table::copy(forecast)
+  transform_forecasts(forecast, fun = add_one)
+  transform_forecasts(forecast, fun = add_one, append = FALSE)
+  expect_identical(as.data.table(forecast), as.data.table(original))
+
+  # with an existing 'scale' column
+  transformed <- transform_forecasts(forecast, fun = add_one)
+  transformed_original <- data.table::copy(transformed)
+  transform_forecasts(transformed, fun = add_one, label = "sqrt")
+  transform_forecasts(transformed, fun = add_one, label = "sqrt", append = FALSE)
+  expect_identical(
+    as.data.table(transformed), as.data.table(transformed_original)
+  )
+})
+
+test_that("transform_forecasts() errors if `label` is reused with append = FALSE", {
+  transformed <- transform_forecasts(
+    na.omit(example_quantile), fun = function(x) x + 1
+  )
+  expect_error(
+    transform_forecasts(transformed, fun = sqrt, append = FALSE),
+    "Can't transform with label 'log'"
+  )
+})
+
+test_that("transform_forecasts() keeps the grouping of multivariate forecasts with append = FALSE", {
+  # every forecast unit column is constant within groups here, so the grouping
+  # can't be inferred from the data (only from `.mv_group_id`)
+  mv <- as_forecast_multivariate_sample(
+    na.omit(example_sample_continuous)[location == "DE"],
+    joint_across = c("location", "location_name")
+  )
+  transformed <- transform_forecasts(mv, fun = function(x) x + 1, append = FALSE)
+  expect_s3_class(transformed, "forecast_multivariate_sample")
+  expect_identical(transformed$.mv_group_id, mv$.mv_group_id)
+})
+
+test_that("transform_forecasts() errors if the result is not a valid forecast", {
+  expect_error(
+    transform_forecasts(
+      na.omit(example_quantile), fun = as.character, append = FALSE
+    ),
+    "Must be of type 'numeric'"
+  )
+})
+
 test_that("transform_forecasts() errors on non-forecast objects", {
   expect_error(
     transform_forecasts(data.frame(x = 1)),