1196: Fix as_forecast_quantile() from samples for asymmetric probs

NEWS.md

@@ -1,5 +1,6 @@
 # scoringutils (development version)
 
+- Fixed `as_forecast_quantile()` for sample-based forecasts producing silently wrong quantiles or erroring when `probs` was not symmetric around 0.5 (e.g. `probs = 0.4` or `probs = c(0.1, 0.2)`). Quantiles are now computed at exactly the requested `probs` (deduplicated), and out-of-range `probs` produce a clear assertion error (#1196).
 - Added `filter_scores()` and `impute_missing_scores()` for handling missing forecasts before summarisation. `filter_scores()` removes target combinations with insufficient model coverage, while `impute_missing_scores()` fills in missing scores using configurable strategies (worst, mean, NA, or reference model). Both use a strategy function pattern for extensibility. See `vignette("handling-missing-forecasts")` for details (#1122).
 - Added `plot_discrimination()` to visualise the discrimination ability of binary forecasts by plotting the distribution of predicted probabilities, stratified by the observed outcome. The function requires a `forecast_binary` object (created with `as_forecast_binary()`) (#942).
 - Fixed `summarise_scores()` producing a data.table with duplicate column names when the input `scores` object had no score columns (e.g. because every metric in `score()` warned and returned nothing). `summarise_scores()` now matches metric columns by exact name rather than regex partial match, and errors with a clear message when there is nothing to summarise (#1179).

R/class-forecast-sample.R

@@ -103,17 +103,15 @@ as_forecast_quantile.forecast_sample <- function(
   ...
 ) {
   forecast <- as.data.table(data)
-  assert_numeric(probs, min.len = 1)
+  assert_numeric(probs, min.len = 1, lower = 0, upper = 1, any.missing = FALSE)
   reserved_columns <- c("predicted", "sample_id")
   by <- setdiff(colnames(forecast), reserved_columns)
 
-  quantile_level <- unique(
-    round(c(probs, 1 - probs), digits = 10)
-  )
+  quantile_level <- unique(round(probs, digits = 10))
 
   forecast <-
     forecast[, .(quantile_level = quantile_level,
-                 predicted = quantile(x = predicted, probs = ..probs,
+                 predicted = quantile(x = predicted, probs = ..quantile_level,
                                       type = ..type, na.rm = TRUE)),
              by = by]
 

R/z-globalVariables.R

@@ -6,6 +6,7 @@ globalVariables(c(
   "..forecast_unit",
   "..index",
   "..probs",
+  "..quantile_level",
   "..samplecols",
   "..type",
   ".BY",

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

@@ -148,6 +148,93 @@ test_that("as_forecast_quantiles works", {
   )
 })
 
+test_that("as_forecast_quantiles handles a single asymmetric prob", {
+  samples <- data.table(
+    model = "model1",
+    observed = 50,
+    predicted = 1:100,
+    sample_id = 1:100
+  ) |>
+    as_forecast_sample()
+
+  quantile <- as_forecast_quantile(samples, probs = 0.4)
+
+  expect_identical(nrow(quantile), 1L)
+  expect_identical(quantile$quantile_level, 0.4)
+  expect_identical(
+    quantile$predicted,
+    unname(quantile(1:100, probs = 0.4, type = 7))
+  )
+})
+
+test_that("as_forecast_quantiles handles multiple asymmetric probs", {
+  samples <- data.table(
+    model = "model1",
+    observed = 50,
+    predicted = 1:100,
+    sample_id = 1:100
+  ) |>
+    as_forecast_sample()
+
+  expect_no_condition(
+    quantile <- as_forecast_quantile(samples, probs = c(0.1, 0.2))
+  )
+  expect_identical(quantile$quantile_level, c(0.1, 0.2))
+  expect_identical(
+    quantile$predicted,
+    unname(quantile(1:100, probs = c(0.1, 0.2), type = 7))
+  )
+})
+
+test_that("as_forecast_quantiles deduplicates repeated probs", {
+  samples <- data.table(
+    model = "model1",
+    observed = 50,
+    predicted = 1:100,
+    sample_id = 1:100
+  ) |>
+    as_forecast_sample()
+
+  quantile <- as_forecast_quantile(samples, probs = c(0.5, 0.5))
+
+  expect_identical(nrow(quantile), 1L)
+  expect_identical(quantile$quantile_level, 0.5)
+  expect_identical(
+    quantile$predicted,
+    unname(quantile(1:100, probs = 0.5, type = 7))
+  )
+})
+
+test_that("as_forecast_quantiles errors on out-of-range probs", {
+  samples <- data.table(
+    model = "model1",
+    observed = 50,
+    predicted = 1:100,
+    sample_id = 1:100
+  ) |>
+    as_forecast_sample()
+
+  expect_error(
+    as_forecast_quantile(samples, probs = c(0.5, 1.5)),
+    "Assertion on 'probs' failed"
+  )
+})
+
+test_that("as_forecast_quantiles errors on missing values in probs", {
+  samples <- data.table(
+    model = "model1",
+    observed = 50,
+    predicted = 1:100,
+    sample_id = 1:100
+  ) |>
+    as_forecast_sample()
+
+  expect_error(
+    as_forecast_quantile(samples, probs = c(0.5, NA)),
+    "Assertion on 'probs' failed"
+  )
+})
+
 test_that("as_forecast_quantiles issue 557 fix", {
   out <- example_sample_discrete |>
     na.omit() |>