Issue 432: Add some basic functions for as_point and as_quantile

NAMESPACE

@@ -2,6 +2,11 @@
 
 S3method(`[`,scores)
 S3method(as_forecast,default)
+S3method(as_point,default)
+S3method(as_point,forecast_quantile)
+S3method(as_point,forecast_sample)
+S3method(as_quantile,default)
+S3method(as_quantile,forecast_sample)
 S3method(assert_forecast,default)
 S3method(assert_forecast,forecast_binary)
 S3method(assert_forecast,forecast_point)
@@ -27,6 +32,8 @@ export(add_relative_skill)
 export(ae_median_quantile)
 export(ae_median_sample)
 export(as_forecast)
+export(as_point)
+export(as_quantile)
 export(assert_forecast)
 export(assert_forecast_generic)
 export(bias_quantile)

NEWS.md

@@ -51,6 +51,9 @@ scores <- score(forecast_quantile)
 - To create and validate a new `forecast` object, users can use `as_forecast()`. To revalidate an existing `forecast` object users can call `assert_forecast()` (which validates the input and returns `invisible(NULL)`. `assert_forecast()` is a generic with methods for the different forecast types. Alternatively, `validate_forecast()` can be used (which calls `assert_forecast()`), which returns the input and is useful in a pipe. Lastly, users can simply print the object to obtain additional information. 
 - Users can test whether an object is of class `forecast_*()` using the function `is_forecast()`. Users can also test for a specific `forecast_*` class using the appropriate `is_forecast.forecast_*` method. For example, to check whether an object is of class `forecast_quantile`, you would use you would use `scoringutils:::is_forecast.forecast_quantile()`.
 
+### Updating a forecast object
+- The functions `as_point` and `as_quantile` have been added to allow conversion of various forecast types to point and quantile forecasts respectively.
+
 ### Pairwise comparisons and relative skill
 - The functionality for computing pairwise comparisons was now split from `summarise_scores()`. Instead of doing pairwise comparisons as part of summarising scores, a new function, `add_relative_skill()`, was introduced that takes summarised scores as an input and adds columns with relative skill scores and scaled relative skill scores.
 - The function `pairwise_comparison()` was renamed to `get_pairwise_comparisons()`, in line with other `get_`-functions. Analogously, `plot_pairwise_comparison()` was renamed to `plot_pairwise_comparisons()`.

R/as_point.R

@@ -0,0 +1,109 @@
+#' @title Convert a forecast object to a point forecast
+#'
+#' @description
+#' The `as_point` function is used to convert a forecast object to a point
+#' forecast. It is a generic function that dispatches the conversion to the
+#' appropriate method based on the class of the input forecast object.
+#'
+#' @param forecast An object of class `forecast_{type}`,
+#' representing a forecast.
+#' @param ... Additional arguments to be passed to the specific method.
+#' @return The function returns a point forecast object, which is a specific
+#' type of forecast object that represents a single value prediction.
+#'
+#' @export
+#' @keywords check-forecasts
+#' @examples
+#' as_point(as_forecast(example_quantile))
+#' as_point(as_forecast(example_sample_continuous))
+as_point <- function(forecast, ...) {
+  UseMethod("as_point")
+}
+
+#' @rdname as_point
+#' @export
+#' @importFrom cli cli_abort
+as_point.default <- function(forecast, ...) {
+  cli_abort(
+    c(
+      "!" = "The input needs to be a forecast object.",
+      "i" = "Please run `as_forecast()` first." # nolint
+    )
+  )
+}
+
+#' Convert a quantile forecast to a point forecast
+#'
+#' This function takes a quantile forecast and converts it to a point forecast
+#' by selecting the forecast corresponding to the specified quantile level.
+#'
+#' @param forecast The `forecast_quantile` object.
+#' @param quantile_level The desired quantile level for the point forecast.
+#' Defaults to 0.5 (median).
+#' @param ... Additional arguments passing inherited from the default method but
+#' unused.
+#'
+#' @return A `forecast_point` object.
+#'
+#' @export
+#' @keywords check-forecasts
+#' @examples
+#' as_point(as_forecast(example_quantile))
+as_point.forecast_quantile <- function(forecast, quantile_level = 0.5, ...) {
+  assert_forecast(forecast, verbose = FALSE)
+  assert_numeric(quantile_level, lower = 0, upper = 1, len = 1)
+
+  forecast <- forecast[
+    quantile_level == target_quantile_level, ,
+    env = list(target_quantile_level = quantile_level)
+  ]
+  forecast[, "quantile_level" := NULL]
+
+  point_forecast <- remake_forecast(
+    forecast, "forecast_quantile", "forecast_point", verbose = FALSE
+  )
+  return(point_forecast)
+}
+
+#' Convert a sample based forecast to a point forecast
+#'
+#' This function converts a forecast object to a point forecast by either
+#' taking the quantile forecast at a specified quantile level or by summarizing
+#' the forecast using a custom function (for example `mean`).
+#'
+#' @param forecast The `forecast_sample` object to be converted to a point
+#' forecast.
+#'
+#' @param fun A custom function to summarize the forecast. If provided, this
+#' function will be used instead of the quantile method. An example could
+#' be the `mean`.
+#' @inheritParams as_point.forecast_quantile
+#' @return A `forecast_point` object.
+#' @export
+#' @keywords check-forecasts
+#' @examples
+#' sample_forecast <- as_forecast(example_sample_continuous)
+#'
+#' # Quantile approach
+#' as_point(sample_forecast)
+#'
+#' # Function approach
+#' as_point(sample_forecast, fun = mean)
+as_point.forecast_sample <- function(forecast, quantile_level = 0.5, fun, ...) {
+  assert_forecast(forecast, verbose = FALSE)
+  if (missing(fun)) {
+    quantile_forecast <- as_quantile(forecast, quantile_levels = quantile_level)
+    point_forecast <- as_point(
+      quantile_forecast, quantile_level = quantile_level
+    )
+  } else {
+    sum_forecast <- summarise_scores(
+      forecast, fun = fun, by = c(get_forecast_unit(forecast), "observed"),
+      metrics = "predicted"
+    )
+    point_forecast <- remake_forecast(
+      sum_forecast, "forecast_sample", "forecast_point"
+    )
+  }
+  return(point_forecast)
+}

R/as_quantile.R

@@ -0,0 +1,80 @@
+#' Convert a forecast object to a quantile object
+#'
+#' This function is used to convert a forecast object to a quantile object.
+#' It dispatches to the appropriate method based on the class of the forecast
+#' object.
+#'
+#' @inheritParams as_point
+#'
+#' @return A `forecast_quantile` object.
+#'
+#' @export
+#' @keywords check-forecasts
+#' @examples
+#' as_quantile(as_forecast(example_sample_continuous))
+#'
+as_quantile <- function(forecast, ...) {
+  UseMethod("as_quantile")
+}
+
+#' @rdname as_quantile
+#' @export
+#' @importFrom cli cli_abort
+as_quantile.default <- function(forecast, ...) {
+  cli_abort(
+    c(
+      "!" = "The input needs to be a forecast object.",
+      "i" = "Please run `as_forecast()` first." # nolint
+    )
+  )
+}
+
+#' Convert a sample forecast to a quantile forecast
+#'
+#' This function takes a sample forecast and converts it to a quantile forecast
+#' sample.
+#'
+#' @param forecast The `forecast_sample`` object to convert to a
+#' `forecast_quantile`.
+#'
+#' @param quantile_levels A vector of quantile levels. Defaults to
+#' 0.01 to 0.99 by 0.01.
+#' @inheritParams as_point.forecast_quantile
+#'
+#' @return A `forecast_quantile` object.
+#' @export
+#' @keywords check-forecasts
+#' @importFrom data.table melt
+#'
+#' @export
+#' @examples
+#' as_quantile(as_forecast(example_sample_continuous))
+as_quantile.forecast_sample <- function(
+  forecast, quantile_levels = seq(from = 0.01, to = 0.99, by = 0.01), ...
+) {
+  assert_forecast(forecast, verbose = FALSE)
+  assert_numeric(quantile_levels, lower = 0, upper = 1)
+
+  sum_forecast <- forecast[,
+    as.list(quantile(predicted, probs = quantile_levels, na.rm = TRUE)),
+    by = c(eval(get_forecast_unit(forecast)), "observed")
+  ]
+
+  sum_forecast <- melt(
+    sum_forecast,
+    measure.vars = paste0(quantile_levels * 100, "%"),
+    variable.name = "quantile_level",
+    value.name = "predicted"
+  )
+
+  sum_forecast[,
+    quantile_level := as.numeric(
+      gsub("%", "", quantile_level, fixed = TRUE)
+    ) / 100
+  ]
+
+  quantile_forecast <- remake_forecast(
+    sum_forecast, "forecast_sample", "forecast_quantile"
+  )
+  return(quantile_forecast)
+}

R/forecast.R

@@ -65,6 +65,9 @@ as_forecast <- function(data,
 #' @param sample_id (optional) Name of the column in `data` that contains the
 #'   sample id. This column will be renamed to "sample_id". Only applicable to
 #'   sample-based forecasts.
+#' @param check_forecast_type Logical, defaults to `FALSE`. Should the
+#' `forecast_type` be checked and reset if not as implied by the `data`?
+#'
 #' @export
 #' @importFrom cli cli_warn
 as_forecast.default <- function(data,
@@ -75,6 +78,7 @@ as_forecast.default <- function(data,
                                 model = NULL,
                                 quantile_level = NULL,
                                 sample_id = NULL,
+                                check_forecast_type = TRUE,
                                 ...) {
   # check inputs
   data <- ensure_data.table(data)
@@ -119,42 +123,44 @@ as_forecast.default <- function(data,
   }
 
   # assert forecast type is as expected
-  assert_forecast_type(data, desired = forecast_type)
-  forecast_type <- get_forecast_type(data)
+  if (isTRUE(check_forecast_type)) {
+    assert_forecast_type(data, desired = forecast_type)
+    forecast_type <- get_forecast_type(data)
 
-  # produce warning if old format is suspected
-  # old quantile format
-  if (forecast_type == "point" && "quantile" %in% colnames(data)) {
-    #nolint start: keyword_quote_linter
-    cli_warn(
-      c(
-        "Found column 'quantile' in the input data",
-        "i" = "This column name was used before scoringutils version 2.0.0.
-        Should the column be called 'quantile_level' instead?"
-      ),
-      .frequency = "once",
-      .frequency_id = "quantile_col_present"
-    )
-    #nolint end
-  }
-  #old binary format
-  if (forecast_type == "point") {
-    looks_binary <- check_input_binary(factor(data$observed), data$predicted)
-    if (is.logical(looks_binary)) {
-      #nolint start: keyword_quote_linter duplicate_argument_linter
+    # produce warning if old format is suspected
+    # old quantile format
+    if (forecast_type == "point" && "quantile" %in% colnames(data)) {
+      #nolint start: keyword_quote_linter
       cli_warn(
         c(
-          "All observations are either 1 or 0.",
-          "i" = "The forecast type was classified as 'point', but it looks like
-          it could be a binary forecast as well.",
-          "i" = "In case you want it to be a binary forecast, convert `observed`
-          to a factor. See `?as_forecast()` for more information."
+          "Found column 'quantile' in the input data",
+          "i" = "This column name was used before scoringutils version 2.0.0.
+          Should the column be called 'quantile_level' instead?"
         ),
         .frequency = "once",
-        .frequency_id = "looks_binary"
+        .frequency_id = "quantile_col_present"
       )
       #nolint end
     }
+    #old binary format
+    if (forecast_type == "point") {
+      looks_binary <- check_input_binary(factor(data$observed), data$predicted)
+      if (is.logical(looks_binary)) {
+        #nolint start: keyword_quote_linter duplicate_argument_linter
+        cli_warn(
+          c(
+            "All observations are either 1 or 0.",
+            "i" = "The forecast type was classified as 'point', but it looks like
+            it could be a binary forecast as well.",
+            "i" = "In case you want it to be a binary forecast, convert `observed`
+            to a factor. See `?as_forecast()` for more information."
+          ),
+          .frequency = "once",
+          .frequency_id = "looks_binary"
+        )
+        #nolint end
+      }
+    }
   }
 
   # construct class
@@ -426,6 +432,33 @@ new_forecast <- function(data, classname) {
 }
 
 
+#' Remakes a forecast object with a subclass
+#'
+#' This function takes a forecast object and modifies its class name by removing
+#' the old class name and adding a new class name. It also performs an assertion
+#' check on the modified forecast object.
+#'
+#' @param forecast The forecast object to be modified
+#' @param old_classname The name of the class to be removed from the forecast
+#' object
+#' @param new_classname The name of the class to be added to the forecast object
+#' @param verbose A logical value indicating whether to print verbose output
+#'
+#' @return The modified forecast object
+#' @keywords internal
+remake_forecast <- function(
+  forecast, old_classname, new_classname, verbose = TRUE
+) {
+  remade_forecast <- forecast
+  class(remade_forecast) <- setdiff(class(forecast), old_classname)
+  remade_forecast <- new_forecast(
+    remade_forecast, classname = new_classname
+  )
+  assert_forecast(remade_forecast, verbose = verbose)
+  return(remade_forecast)
+}
+
+
 #' @title Test whether an object is a forecast object
 #'
 #' @description

R/summarise_scores.R

@@ -20,6 +20,8 @@
 #'   alternative to specifying `by` directly. If `across` is set, `by` will be
 #'   ignored. If `across` is `NULL` (default), then `by` will be used.
 #' @param fun A function used for summarising scores. Default is [mean()].
+#' @param metrics The metrics to summarise. If missing then `get_metrics()`
+#' is used internally to infer these.
 #' @param ... Additional parameters that can be passed to the summary function
 #'   provided to `fun`. For more information see the documentation of the
 #'   respective function.
@@ -60,13 +62,17 @@ summarise_scores <- function(scores,
                              by = "model",
                              across = NULL,
                              fun = mean,
+                             metrics,
                              ...) {
   # input checking ------------------------------------------------------------
   assert_data_frame(scores)
   assert_subset(by, names(scores), empty.ok = TRUE)
   assert_subset(across, names(scores), empty.ok = TRUE)
   assert_function(fun)
-  metrics <- get_metrics(scores, error = TRUE)
+  if (missing(metrics)) {
+    metrics <- get_metrics(scores, error = TRUE)
+  }
+
 
   forecast_unit <- get_forecast_unit(scores)
 

R/z_globalVariables.R

@@ -80,5 +80,6 @@ globalVariables(c(
   "wis_component_name",
   "x",
   "y",
-  "g"
+  "g",
+  "target_quantile_level"
 ))