BOT: Fix #880: Add quantile_level parameter to as_forecast_point.forecast_quantile()

R/class-forecast-quantile.R

@@ -99,20 +99,28 @@ is_forecast_quantile <- function(x) {
 #' @rdname as_forecast_point
 #' @description
 #' When converting a `forecast_quantile` object into a `forecast_point` object,
-#' the 0.5 quantile is extracted and returned as the point forecast.
+#' the quantile specified by `quantile_level` (default `0.5`, i.e. the median)
+#' is extracted and returned as the point forecast.
+#' @param quantile_level Numeric scalar specifying which quantile level to
+#'   extract as the point forecast. Defaults to `0.5` (the median). The
+#'   requested quantile level must be present in the data.
 #' @export
 #' @keywords as_forecast
-as_forecast_point.forecast_quantile <- function(data, ...) {
+#' @importFrom checkmate assert_number
+as_forecast_point.forecast_quantile <- function(data, quantile_level = 0.5,
+                                                ...) {
+  assert_number(quantile_level)
   assert_forecast(data, verbose = FALSE)
-  assert_subset(0.5, unique(data$quantile_level))
+  assert_subset(quantile_level, unique(data$quantile_level))
 
   # At end of this function, the object will have be turned from a
   # forecast_quantile to a forecast_point and we don't want to validate it as a
   # forecast_point during the conversion process. The correct class is restored
   # at the end.
   data <- as.data.table(data)
 
-  forecast <- data[quantile_level == 0.5]
+  target_quantile <- quantile_level
+  forecast <- data[quantile_level == target_quantile]
   forecast[, "quantile_level" := NULL]
 
   point_forecast <- new_forecast(forecast, "forecast_point")

tests/testthat/test-class-forecast-point.R

@@ -8,6 +8,59 @@ test_that("as_forecast_point() works", {
   )
 })
 
+test_that("as_forecast_point.forecast_quantile() uses default quantile_level = 0.5", {
+  data <- as_forecast_quantile(na.omit(example_quantile))
+  result <- as_forecast_point(data)
+  expect_s3_class(result, c("forecast_point", "forecast", "data.table", "data.frame"), exact = TRUE)
+  # predicted values should match those at quantile_level 0.5
+  expected <- na.omit(as.data.table(example_quantile))[quantile_level == 0.5]
+  expect_equal(sort(result$predicted), sort(expected$predicted))
+  expect_false("quantile_level" %in% colnames(result))
+})
+
+test_that("as_forecast_point.forecast_quantile() accepts custom quantile_level", {
+  data <- as_forecast_quantile(na.omit(example_quantile))
+  result <- as_forecast_point(data, quantile_level = 0.25)
+  expect_s3_class(result, c("forecast_point", "forecast", "data.table", "data.frame"), exact = TRUE)
+  expected <- na.omit(as.data.table(example_quantile))[quantile_level == 0.25]
+  expect_equal(sort(result$predicted), sort(expected$predicted))
+  expect_false("quantile_level" %in% colnames(result))
+})
+
+test_that("as_forecast_point.forecast_quantile() errors when requested quantile_level is not present", {
+  data <- as_forecast_quantile(na.omit(example_quantile))
+  expect_error(
+    as_forecast_point(data, quantile_level = 0.33),
+    "0.33"
+  )
+})
+
+test_that("as_forecast_point.forecast_quantile() errors when quantile_level is not a single numeric value", {
+  data <- as_forecast_quantile(na.omit(example_quantile))
+  expect_error(
+    as_forecast_point(data, quantile_level = c(0.25, 0.75))
+  )
+  expect_error(
+    as_forecast_point(data, quantile_level = "0.5")
+  )
+})
+
+test_that("as_forecast_point.forecast_quantile() with custom quantile_level produces correct predicted values", {
+  dt <- data.frame(
+    observed = c(10, 10, 20, 20),
+    predicted = c(8, 12, 18, 22),
+    quantile_level = c(0.25, 0.75, 0.25, 0.75),
+    model = c("m", "m", "m", "m"),
+    target = c("a", "a", "b", "b")
+  )
+  data <- suppressMessages(as_forecast_quantile(dt))
+  result <- as_forecast_point(data, quantile_level = 0.25)
+  expect_equal(nrow(result), 2)
+  expect_equal(sort(result$predicted), c(8, 18))
+  expect_equal(sort(result$observed), c(10, 20))
+  expect_false("quantile_level" %in% colnames(result))
+})
+
 
 # ==============================================================================
 # is_forecast_point() # nolint: commented_code_linter