Merge pull request #501 from epiforecasts/improve-bias-quantile

Issue #500: Reduce messages in `bias_quantile()`
epiforecasts · Nov 28, 2023 · accb868 · accb868
2 parents 55e5744 + 5f182da
commit accb868
Show file tree

Hide file tree

Showing 2 changed files with 14 additions and 5 deletions.
diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R
@@ -394,8 +394,14 @@ bias_quantile <- function(observed, predicted, quantile, na.rm = TRUE) {
   if (is.null(dim(predicted))) {
     dim(predicted) <- c(n, N)
   }
+  if (!(0.5 %in% quantile)) {
+    message(
+      "Median not available, computing bias as mean of the two innermost ",
+      "quantiles in order to compute bias."
+    )
+  }
   bias <- sapply(1:n, function(i) {
-    bias_quantile_single_vector(observed[i], predicted[i,], quantile, na.rm)
+    bias_quantile_single_vector(observed[i], predicted[i, ], quantile, na.rm)
   })
   return(bias)
 }
@@ -442,10 +448,6 @@ bias_quantile_single_vector <- function(observed, predicted, quantile, na.rm) {
     median_prediction <- predicted[quantile == 0.5]
   } else {
     # if median is not available, compute as mean of two innermost quantile
-    message(
-      "Median not available, computing as mean of two innermost quantile",
-      " in order to compute bias."
-    )
     median_prediction <-
       0.5 * predicted[quantile == max(quantile[quantile < 0.5])] +
       0.5 * predicted[quantile == min(quantile[quantile > 0.5])]

diff --git a/tests/testthat/test-metrics-quantile.R b/tests/testthat/test-metrics-quantile.R
@@ -791,3 +791,10 @@ test_that("bias_quantile(): quantiles must be unique", {
   quantiles <- c(0.3, 0.5, 0.8, 0.9)
   expect_silent(bias_quantile(observed = 3, predicted, quantiles))
 })
+
+test_that("bias_quantile only produces one message", {
+  expect_message(
+    bias_quantile(observed, predicted[, -3], quantile[-3]),
+    "Median not available, computing bias as mean of the two innermost quantiles in order to compute bias."
+  )
+})