BOT: Fix #492: Expose get_interval_range() and add add_interval_range()

NAMESPACE

@@ -44,6 +44,7 @@ S3method(score,forecast_quantile)
 S3method(score,forecast_sample)
 S3method(score,forecast_sample_multivariate)
 S3method(tail,forecast)
+export(add_interval_range)
 export(add_relative_skill)
 export(ae_median_quantile)
 export(ae_median_sample)
@@ -69,6 +70,7 @@ export(get_duplicate_forecasts)
 export(get_forecast_counts)
 export(get_forecast_unit)
 export(get_grouping)
+export(get_interval_range)
 export(get_metrics)
 export(get_pairwise_comparisons)
 export(get_pit_histogram)

R/get-coverage.R

@@ -75,7 +75,7 @@ get_coverage <- function(forecast, by = "model") {
 
   # merge interval range data with original data -------------------------------
   # preparations
-  forecast[, interval_range := get_range_from_quantile(quantile_level)]
+  forecast[, interval_range := get_interval_range(quantile_level)]
   forecast_cols <- colnames(forecast) # store so we can reset column order later
   forecast_unit <- get_forecast_unit(forecast)
 

R/helper-quantile-interval-range.R

@@ -68,7 +68,7 @@ quantile_to_interval_dataframe <- function(forecast,
   forecast <- as.data.table(forecast)
 
   forecast[, boundary := ifelse(quantile_level <= 0.5, "lower", "upper")]
-  forecast[, interval_range := get_range_from_quantile(quantile_level)]
+  forecast[, interval_range := get_interval_range(quantile_level)]
 
   # add median quantile
   median <- forecast[quantile_level == 0.5, ]
@@ -172,7 +172,7 @@ sample_to_interval_long <- function(data,
 #' Get interval range belonging to a quantile
 #' @description
 #' Every quantile can be thought of either as the lower or the
-#' upper bound of a symmetric central prediction interval. This helper function
+#' upper bound of a symmetric central prediction interval. This function
 #' returns the range of the central prediction interval to which the quantile
 #' belongs.
 #'
@@ -181,8 +181,10 @@ sample_to_interval_long <- function(data,
 #' use cases, but it is something to be aware of.
 #' @param quantile_level A numeric vector of quantile levels of size N.
 #' @returns a numeric vector of interval ranges of size N
-#' @keywords internal
-get_range_from_quantile <- function(quantile_level) {
+#' @examples
+#' get_interval_range(c(0.05, 0.25, 0.5, 0.75, 0.95))
+#' @export
+get_interval_range <- function(quantile_level) {
   boundary <- ifelse(quantile_level <= 0.5, "lower", "upper")
   interval_range <- ifelse(
     boundary == "lower",
@@ -191,3 +193,32 @@ get_range_from_quantile <- function(quantile_level) {
   )
   return(interval_range)
 }
+
+
+#' Add interval range column to a data.table with quantile-level forecasts
+#'
+#' @description
+#' Adds an `interval_range` column to a data.table that has a
+#' `quantile_level` column. The interval range is computed using
+#' [get_interval_range()].
+#'
+#' @param data A data.table (or object coercible to data.table) with a
+#'   `quantile_level` column.
+#' @returns A data.table with an additional `interval_range` column.
+#' @examples
+#' library(data.table)
+#' dt <- data.table(
+#'   observed = 5,
+#'   predicted = c(1, 3, 5, 7, 9),
+#'   quantile_level = c(0.05, 0.25, 0.5, 0.75, 0.95)
+#' )
+#' add_interval_range(dt)
+#' @importFrom data.table as.data.table
+#' @importFrom checkmate assert_names
+#' @export
+add_interval_range <- function(data) {
+  data <- ensure_data.table(data)
+  assert_names(colnames(data), must.include = "quantile_level")
+  data[, interval_range := get_interval_range(quantile_level)]
+  return(data[])
+}

R/metrics-quantile.R

@@ -185,7 +185,7 @@ wis <- function(observed,
   reformatted <- quantile_to_interval(observed, predicted, quantile_level)
 
   # check that all quantile levels form valid prediction intervals
-  interval_ranges <- get_range_from_quantile(
+  interval_ranges <- get_interval_range(
     quantile_level[quantile_level != 0.5]
   )
   complete_intervals <-

tests/testthat/test-get-coverage.R

@@ -37,7 +37,7 @@ test_that("get_coverage() can deal with non-symmetric prediction intervals", {
 
   cov <- expect_no_condition(get_coverage(test))
 
-  prediction_intervals <- get_range_from_quantile(c(0.2, 0.3, 0.5))
+  prediction_intervals <- get_interval_range(c(0.2, 0.3, 0.5))
 
   missing <- cov[interval_range %in% prediction_intervals]
   not_missing <- cov[!interval_range %in% prediction_intervals]

tests/testthat/test-helper-quantile-interval-range.R

@@ -219,3 +219,76 @@ test_that("quantile_to_interval works - data.frame case", {
     "Input must be either a data.frame or a numeric vector."
   )
 })
+
+
+# ==============================================================================
+# get_interval_range() # nolint: commented_code_linter
+# ==============================================================================
+
+test_that("get_interval_range() returns correct interval ranges for standard quantiles", {
+  result <- get_interval_range(c(0.05, 0.25, 0.5, 0.75, 0.95))
+  expect_identical(result, c(90, 50, 0, 50, 90))
+})
+
+test_that("get_interval_range() handles edge cases correctly", {
+  expect_identical(get_interval_range(c(0, 1)), c(100, 100))
+  expect_identical(get_interval_range(0.5), 0)
+  expect_identical(get_interval_range(c(0.1, 0.9)), c(80, 80))
+})
+
+test_that("get_interval_range() is exported and accessible without :::", {
+  expect_no_error(get_interval_range(0.25))
+  expect_identical(get_interval_range(0.25), 50)
+})
+
+
+# ==============================================================================
+# add_interval_range() # nolint: commented_code_linter
+# ==============================================================================
+
+test_that("add_interval_range() adds interval_range column to quantile forecast", {
+  dt <- data.table::data.table(
+    observed = 5,
+    predicted = c(1, 3, 5, 7, 9),
+    quantile_level = c(0.05, 0.25, 0.5, 0.75, 0.95)
+  )
+  ncol_before <- ncol(dt)
+  result <- add_interval_range(dt)
+  expect_true("interval_range" %in% colnames(result))
+  expect_identical(result$interval_range, c(90, 50, 0, 50, 90))
+  expect_identical(ncol(result), ncol_before + 1L)
+})
+
+test_that("add_interval_range() works with example_quantile dataset", {
+  ex <- na.omit(example_quantile)
+  result <- add_interval_range(ex)
+  expect_true("interval_range" %in% colnames(result))
+  expect_identical(nrow(result), nrow(ex))
+  expect_identical(result$interval_range, get_interval_range(result$quantile_level))
+})
+
+test_that("add_interval_range() returns a copy (does not modify input in place)", {
+  dt <- data.table::data.table(
+    observed = 5,
+    predicted = c(1, 3, 5, 7, 9),
+    quantile_level = c(0.05, 0.25, 0.5, 0.75, 0.95)
+  )
+  result <- add_interval_range(dt)
+  # ensure_data.table() copies, so original dt should be unchanged
+  expect_false("interval_range" %in% colnames(dt))
+  expect_true("interval_range" %in% colnames(result))
+})
+
+test_that("add_interval_range() errors gracefully on non-quantile input", {
+  dt <- data.table::data.table(
+    observed = 1:5,
+    predicted = 2:6,
+    sample_id = 1:5
+  )
+  expect_error(add_interval_range(dt))
+})
+
+test_that("internal call sites work correctly after rename", {
+  expect_no_error(get_coverage(as_forecast_quantile(example_quantile)))
+  expect_no_error(score(as_forecast_quantile(example_quantile)))
+})

vignettes/Deprecated-visualisations.Rmd

@@ -26,7 +26,7 @@
 library(scoringutils)
 library(data.table)
 library(ggplot2)
 library(ggdist)
 ```
 
 # Functions `plot_predictions()` and `make_na()`
@@ -438,7 +438,7 @@
 ```{r}
 range_example <- copy(example_quantile) |>
   na.omit()
-range_example[, range := scoringutils:::get_range_from_quantile(quantile_level)] # nolint: undesirable_operator_linter
+range_example[, range := scoringutils::get_interval_range(quantile_level)]
 
 sum_scores <- range_example |>
   as_forecast_quantile() |>