Issue #405: expose get_forecast_type() to users

NAMESPACE

@@ -31,6 +31,7 @@ export(crps_sample)
 export(dispersion)
 export(dss_sample)
 export(get_duplicate_forecasts)
+export(get_forecast_type)
 export(interval_coverage_deviation_quantile)
 export(interval_coverage_quantile)
 export(interval_coverage_sample)

R/correlations.R

@@ -21,8 +21,6 @@
 correlation <- function(scores,
                         metrics = NULL,
                         digits = NULL) {
-  metrics <- check_metrics(metrics)
-
   metrics <- get_metrics(scores)
 
   # if quantile column is present, throw a warning

R/get_-functions.R

@@ -1,19 +1,27 @@
 # Functions that help to obtain information about the data
 
-#' @title Infer the type of a forecast based on a data.frame
+#' @title Infer Forecast Type
+#' @description Helper function to infer the forecast type based on a
+#' data.frame or similar with predictions. Please check the vignettes to
+#' learn more about forecast types.
 #'
-#' @description Internal helper function to get the type of the forecast.
-#' Options are "sample-based", "quantile-based", "binary" or "point" forecast.
-#' The function runs additional checks to make sure the data satisfies
-#' requirements and throws an informative error if any issues are found.
-#'
-#' @inheritParams validate
+#' Possible forecast types are
+#' - "sample-based"
+#' - "quantile-based"
+#' - "binary"
+#' - "point" forecast.
 #'
+#' The function runs additional checks to make sure the data satisfies the
+#' requirements of the respective forecast type and throws an
+#' informative error if any issues are found.
+#' @inheritParams score
 #' @return Character vector of length one with either "binary", "quantile",
 #' "sample" or "point".
-#'
-#' @keywords internal
+#' @export
+#' @keywords check-forceasts
 get_forecast_type <- function(data) {
+  assert_data_frame(data)
+  assert(check_columns_present(data, c("observed", "predicted")))
   if (test_forecast_type_is_binary(data)) {
     forecast_type <- "binary"
   } else if (test_forecast_type_is_quantile(data)) {
@@ -24,8 +32,8 @@ get_forecast_type <- function(data) {
     forecast_type <- "point"
   } else {
     stop(
-      "Checking `data`: input doesn't satisfy criteria for any forecast type.",
-      "Are you missing a column `quantile` or `sample_id`?",
+      "Checking `data`: input doesn't satisfy criteria for any forecast type. ",
+      "Are you missing a column `quantile` or `sample_id`? ",
       "Please check the vignette for additional info."
     )
   }

tests/testthat/test-get_-functions.R

@@ -109,3 +109,39 @@ test_that("get_duplicate_forecasts() works as expected for point", {
     22
   )
 })
+
+
+# ==============================================================================
+# `get_forecast_type`
+# ==============================================================================
+test_that("get_forecast_type() works as expected", {
+  expect_equal(get_forecast_type(as.data.frame(example_quantile)), "quantile")
+  expect_equal(get_forecast_type(example_continuous), "sample")
+  expect_equal(get_forecast_type(example_integer), "sample")
+  expect_equal(get_forecast_type(example_binary), "binary")
+  expect_equal(get_forecast_type(example_point), "point")
+
+  expect_error(
+    get_forecast_type(data.frame(x = 1:10)),
+    "Assertion on 'data' failed: Columns 'observed', 'predicted' not found in data.",
+    fixed = TRUE
+  )
+
+  df <- data.frame(observed = 1:10, predicted = factor(1:10))
+  expect_error(
+    get_forecast_type(df),
+    "Checking `data`: input doesn't satisfy criteria for any forecast type. Are you missing a column `quantile` or `sample_id`? Please check the vignette for additional info.",
+    fixed = TRUE
+  )
+
+  data <- validate(example_integer)
+  attr(data, "forecast_type") <- "binary"
+  expect_warning(
+    get_forecast_type(data),
+    "Object has an attribute `forecast_type`, but it looks different from what's expected based on the data.
+Existing: binary
+Expected: sample
+Running `validate()` again might solve the problem",
+    fixed = TRUE
+  )
+})

tests/testthat/test-plot_correlation.R

@@ -1,5 +1,5 @@
 test_that("plot_correlation() works as expected", {
-  correlations <- correlation(summarise_scores(scores), digits = 2)
+  correlations <- correlation(summarise_scores(scores_quantile), digits = 2)
   p <- plot_correlation(correlations)
   expect_s3_class(p, "ggplot")
   skip_on_cran()