diff --git a/NEWS.md b/NEWS.md index a639a3909..6e5183f78 100644 --- a/NEWS.md +++ b/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. diff --git a/R/transform-forecasts.R b/R/transform-forecasts.R index edd4bb616..9201282ea 100644 --- a/R/transform-forecasts.R +++ b/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 diff --git a/man/transform_forecast_data.Rd b/man/transform_forecast_data.Rd new file mode 100644 index 000000000..3c0826f35 --- /dev/null +++ b/man/transform_forecast_data.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transform-forecasts.R +\name{transform_forecast_data} +\alias{transform_forecast_data} +\title{Apply a transformation to the data of a forecast object} +\usage{ +transform_forecast_data(forecast, fun, append, label, ...) +} +\arguments{ +\item{forecast}{A forecast object (a validated data.table with predicted and +observed values).} + +\item{fun}{A function used to transform both observed values and predictions. +The default function is \code{\link[=log_shift]{log_shift()}}, a custom function that is +essentially the same as \code{\link[=log]{log()}}, but has an additional arguments (\code{offset}) +that allows you add an offset before applying the logarithm. This is often +helpful as the natural log transformation is not defined at zero. A +common, and pragmatic solution, is to add a small offset to the data +before applying the log transformation. In our work we have often used an +offset of 1 but the precise value will depend on your application.} + +\item{append}{Logical, defaults to \code{TRUE}. Whether or not to append a +transformed version of the data to the currently existing data (\code{TRUE}). If +selected, the data gets transformed and appended to the existing data, +making it possible to use the outcome directly in \code{\link[=score]{score()}}. An additional +column, 'scale', gets created that denotes which rows or untransformed +('scale' has the value "natural") and which have been transformed ('scale' +has the value passed to the argument \code{label}).} + +\item{label}{A string for the newly created 'scale' column to denote the +newly transformed values. Only relevant if \code{append = TRUE} or if the +forecast already has a 'scale' column. In the latter case, \code{label} must +not already be present in that column.} + +\item{...}{Additional parameters to pass to the function you supplied. For +the default option of \code{\link[=log_shift]{log_shift()}} this could be the \code{offset} argument.} +} +\value{ +A plain \code{data.table} with the transformed (and, if +\code{append = TRUE}, the original) forecasts. +} +\description{ +Internal helper for the \code{\link[=transform_forecasts]{transform_forecasts()}} methods. It validates the +forecast object once and then applies the transformation to a plain +\code{data.table} copy of it. Working on a plain \code{data.table} avoids +\verb{[.forecast}, which re-validates the whole forecast object after every +\verb{:=} update. The caller is responsible for turning the result back into +a forecast object (which validates it once more). +} +\keyword{internal} diff --git a/man/transform_forecasts.Rd b/man/transform_forecasts.Rd index a235a1d69..4fac2a0de 100644 --- a/man/transform_forecasts.Rd +++ b/man/transform_forecasts.Rd @@ -70,7 +70,9 @@ column, 'scale', gets created that denotes which rows or untransformed has the value passed to the argument \code{label}).} \item{label}{A string for the newly created 'scale' column to denote the -newly transformed values. Only relevant if \code{append = TRUE}.} +newly transformed values. Only relevant if \code{append = TRUE} or if the +forecast already has a 'scale' column. In the latter case, \code{label} must +not already be present in that column.} \item{...}{Additional parameters to pass to the function you supplied. For the default option of \code{\link[=log_shift]{log_shift()}} this could be the \code{offset} argument.} diff --git a/tests/testthat/test-transform-forecasts.R b/tests/testthat/test-transform-forecasts.R index 1cef4b9c0..8be8f7277 100644 --- a/tests/testthat/test-transform-forecasts.R +++ b/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)),