1198: Fix bias_quantile() quantile level sorting and na.rm crash

NEWS.md

@@ -1,5 +1,6 @@
 # scoringutils (development version)
 
+- Fixed `bias_quantile()` returning wrong values when quantile levels were passed unsorted: predictions were reordered by quantile level but the quantile levels themselves were not, so predictions and levels became mispaired. Also fixed a crash ("argument is of length zero") when `na.rm = TRUE` removed all quantile levels on one side of the median; `bias_quantile()` now returns `NA` in this case, consistent with `na.rm = FALSE` (#1198).
 - 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/metrics-quantile.R

@@ -475,10 +475,16 @@ bias_quantile_single_vector <- function(observed, predicted,
     predicted <- predicted[!is.na(predicted)]
     predicted <- predicted[!is.na(quantile_level)]
     quantile_level <- quantile_level[!is.na(quantile_level)]
+    # if NA removal leaves no quantile level on one side of the median, the
+    # median cannot be interpolated and no bias can be computed
+    if (!any(quantile_level <= 0.5) || !any(quantile_level >= 0.5)) {
+      return(NA_real_)
+    }
   }
 
   order <- order(quantile_level)
   predicted <- predicted[order]
+  quantile_level <- quantile_level[order]
   if (!all(diff(predicted) >= 0)) {
     cli_abort(
       c(

tests/testthat/test-metrics-quantile.R

@@ -751,6 +751,35 @@ test_that("bias_quantile() handles NA values", {
   )
 })
 
+test_that("bias_quantile() is invariant to the order of quantile levels", {
+  expect_equal( # nolint: expect_identical_linter
+    bias_quantile(observed = 1.5, c(3, 1, 2), c(0.75, 0.25, 0.5)),
+    0.5
+  )
+  expect_equal(
+    bias_quantile(observed = 1.5, c(3, 1, 2), c(0.75, 0.25, 0.5)),
+    bias_quantile(observed = 1.5, c(1, 2, 3), c(0.25, 0.5, 0.75))
+  )
+})
+
+test_that("bias_quantile() returns NA when na.rm removes one side of the median", {
+  expect_equal( # nolint: expect_identical_linter
+    bias_quantile(observed = 2, c(NA, NA, 3), c(0.25, 0.5, 0.75), na.rm = TRUE),
+    NA_real_
+  )
+  expect_equal( # nolint: expect_identical_linter
+    suppressMessages(
+      bias_quantile(observed = 2, c(NA, 3), c(0.25, 0.75), na.rm = TRUE)
+    ),
+    NA_real_
+  )
+  # if the median itself survives NA removal, the forecast can still be scored
+  expect_equal( # nolint: expect_identical_linter
+    bias_quantile(observed = 1, c(NA, 2, 3), c(0.25, 0.5, 0.75), na.rm = TRUE),
+    1
+  )
+})
+
 test_that("bias_quantile() errors if no predictions", {
   expect_error(
     bias_quantile(observed = 2, numeric(0), numeric(0)),