Merge pull request #706 from epiforecasts/remove-available_metrics

Issue #383 - Remove `available_metrics()`

NAMESPACE

@@ -27,7 +27,6 @@ export(add_pairwise_comparison)
 export(ae_median_quantile)
 export(ae_median_sample)
 export(as_forecast)
-export(available_metrics)
 export(bias_quantile)
 export(bias_sample)
 export(brier_score)

NEWS.md

@@ -50,8 +50,9 @@ The update introduces breaking changes. If you want to keep using the older vers
 - "range" was consistently renamed to "interval_range" in the code. The "range"-format (which was mostly used internally) was renamed to "interval"-format
 - Added a method for `print()` that prints out additional information for `forecast` objects. 
 - Added a subsetting `[` operator for scores, so that the score name attribute gets preserved when subsetting.
-- Deleted the function `plot_ranges()`. If you want to continue using the functionality, you can find the function code [here](https://github.com/epiforecasts/scoringutils/issues/462).
+- Deleted the function `plot_ranges()`. If you want to continue using the functionality, you can find the function code [here](https://github.com/epiforecasts/scoringutils/issues/462) or in the visualisation Vignette.
 - Removed the function `plot_predictions()`, as well as its helper function `make_NA()`, in favour of a dedicated Vignette that shows different ways of visualising predictions. For future reference, the function code can be found [here](https://github.com/epiforecasts/scoringutils/issues/659) (Issue #659).
+- Added a first versino of a dedicated Vignette that displays some possible ways of visualising forecasts. 
 
 # scoringutils 1.2.2
 

R/correlations.R

@@ -10,7 +10,9 @@
 #' @param digits A number indicating how many decimal places the result should
 #' be rounded to. By default (`digits = NULL`) no rounding takes place.
 #' @inheritParams pairwise_comparison
-#' @return A data.table with correlations for the different metrics
+#' @return An object of class `scores` (a data.table with an additional
+#' attribute `metrics` holding the names of the scores) with correlations
+#' between different metrics
 #' @importFrom data.table setDT
 #' @importFrom stats cor na.omit
 #' @importFrom cli cli_warn
@@ -22,7 +24,7 @@
 correlation <- function(scores,
                         metrics = NULL,
                         digits = NULL) {
-  metrics <- get_metrics(scores)
+  metrics <- get_metrics(scores, error = TRUE)
 
   # remove all non metrics and non-numeric columns
   df <- scores[, .SD, .SDcols = sapply(
@@ -40,9 +42,12 @@ correlation <- function(scores,
     cor_mat <- round(cor_mat, digits)
   }
 
-  correlations <- setDT(as.data.frame((cor_mat)),
+  correlations <- new_scores(
+    as.data.frame((cor_mat)),
+    metrics = metrics,
     keep.rownames = TRUE
-  )[, metric := rn][, rn := NULL]
+  )
+  correlations <- copy(correlations)[, metric := rn][, rn := NULL]
 
   return(correlations[])
 }

R/get_-functions.R

@@ -229,7 +229,6 @@ get_protected_columns <- function(data = NULL) {
     "pit_value", "interval_range", "boundary",
     "interval_coverage", "interval_coverage_deviation",
     "quantile_coverage", "quantile_coverage_deviation",
-    available_metrics(),
     grep("_relative_skill$", names(data), value = TRUE),
     grep("coverage_", names(data), fixed = TRUE, value = TRUE)
   )

R/plot.R

@@ -751,7 +751,7 @@ plot_forecast_counts <- function(forecast_counts,
 
 plot_correlation <- function(correlations) {
 
-  metrics <- names(correlations)[names(correlations) %in% available_metrics()]
+  metrics <- get_metrics(correlations, error = TRUE)
 
   lower_triangle <- get_lower_tri(correlations[, .SD, .SDcols = metrics])
   rownames(lower_triangle) <- colnames(lower_triangle)

R/score.R

@@ -233,7 +233,9 @@ apply_rules <- function(data, metrics, ...) {
 #' @param scores A data.table or similar with scores as produced by [score()]
 #' @param metrics A character vector with the names of the scores
 #' (i.e. the names of the scoring rules used for scoring)
+#' @param ... Additional arguments to [as.data.table()]
 #' @keywords internal
+#' @importFrom data.table as.data.table setattr
 #' @return An object of class `scores`
 #' @examples
 #' \dontrun{
@@ -243,8 +245,8 @@ apply_rules <- function(data, metrics, ...) {
 #' )
 #' new_scores(df, "wis")
 #' }
-new_scores <- function(scores, metrics) {
-  scores <- as.data.table(scores)
+new_scores <- function(scores, metrics, ...) {
+  scores <- as.data.table(scores, ...)
   class(scores) <- c("scores", class(scores))
   setattr(scores, "metrics", metrics)
   return(scores[])

R/utils.R

@@ -1,15 +1,3 @@
-#' @title Available metrics in scoringutils
-#'
-#' @return A vector with the name of all available metrics
-#' @export
-#' @keywords info
-available_metrics <- function() {
-  return(unique(c(scoringutils::metrics$Name,
-                  "wis", "interval_coverage_50", "interval_coverage_90",
-                  "interval_coverage_deviation")))
-}
-
-
 #' @title Run a function safely
 #' @description This is a wrapper function designed to run a function safely
 #' when it is not completely clear what arguments could be passed to the

tests/testthat/test-utils.R

@@ -4,7 +4,7 @@ test_that("get_protected_columns() returns the correct result", {
   manual <- protected_columns <- c(
     "predicted", "observed", "sample_id", "quantile_level", "upper", "lower",
     "pit_value",
-    "range", "boundary", available_metrics(),
+    "range", "boundary",
     grep("coverage_", names(data), fixed = TRUE, value = TRUE)
   )
   manual <- intersect(manual, colnames(example_quantile))
@@ -16,7 +16,7 @@ test_that("get_protected_columns() returns the correct result", {
   manual <- protected_columns <- c(
     "predicted", "observed", "sample_id", "quantile_level", "upper", "lower",
     "pit_value",
-    "range", "boundary", available_metrics(),
+    "range", "boundary",
     grep("coverage_", names(data), fixed = TRUE, value = TRUE)
   )
   manual <- intersect(manual, colnames(example_binary))
@@ -27,7 +27,7 @@ test_that("get_protected_columns() returns the correct result", {
   manual <- protected_columns <- c(
     "predicted", "observed", "sample_id", "quantile_level", "upper", "lower",
     "pit_value",
-    "range", "boundary", available_metrics(),
+    "range", "boundary",
     grep("coverage_", names(data), fixed = TRUE, value = TRUE)
   )
   manual <- intersect(manual, colnames(example_continuous))