BOT: Fix #780: Add verbose argument to as_forecast_*() constructors

R/class-forecast-binary.R

@@ -36,13 +36,15 @@ as_forecast_binary <- function(data, ...) {
 }
 
 #' @rdname as_forecast_binary
+#' @inheritParams assert_forecast
 #' @export
 #' @method as_forecast_binary default
 #' @importFrom cli cli_warn
 as_forecast_binary.default <- function(data,
                                        forecast_unit = NULL,
                                        observed = NULL,
                                        predicted = NULL,
+                                       verbose = TRUE,
                                        ...) {
   data <- as_forecast_generic(
     data,
@@ -51,7 +53,7 @@ as_forecast_binary.default <- function(data,
     predicted = predicted
   )
   data <- new_forecast(data, "forecast_binary")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

R/class-forecast-multivariate-sample.R

@@ -53,6 +53,7 @@ as_forecast_multivariate_sample <- function(data, ...) {
 #'   For example, if you have a column `country` and want to define
 #'   a multivariate forecast for several countries at once, you could set
 #'   `joint_across = "country"`.
+#' @inheritParams assert_forecast
 #' @export
 #' @importFrom cli cli_warn
 as_forecast_multivariate_sample.default <- function(data,
@@ -61,6 +62,7 @@ as_forecast_multivariate_sample.default <- function(data,
                                                     observed = NULL,
                                                     predicted = NULL,
                                                     sample_id = NULL,
+                                                    verbose = TRUE,
                                                     ...) {
   data <- as_forecast_generic(
     data,
@@ -72,7 +74,7 @@ as_forecast_multivariate_sample.default <- function(data,
   data <- set_grouping(data, joint_across)
 
   data <- new_forecast(data, "forecast_sample_multivariate")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

R/class-forecast-nominal.R

@@ -47,6 +47,7 @@ as_forecast_nominal <- function(data, ...) {
 #' @param predicted_label (optional) Name of the column in `data` that denotes
 #'   the outcome to which a predicted probability corresponds to.
 #'   This column will be renamed to "predicted_label".
+#' @inheritParams assert_forecast
 #' @export
 #' @method as_forecast_nominal default
 #' @importFrom cli cli_warn
@@ -55,6 +56,7 @@ as_forecast_nominal.default <- function(data,
                                         observed = NULL,
                                         predicted = NULL,
                                         predicted_label = NULL,
+                                        verbose = TRUE,
                                         ...) {
   data <- as_forecast_generic(
     data,
@@ -64,7 +66,7 @@ as_forecast_nominal.default <- function(data,
     predicted_label = predicted_label
   )
   data <- new_forecast(data, "forecast_nominal")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

R/class-forecast-ordinal.R

@@ -47,6 +47,7 @@ as_forecast_ordinal <- function(data, ...) {
 #' @param predicted_label (optional) Name of the column in `data` that denotes
 #'   the outcome to which a predicted probability corresponds to.
 #'   This column will be renamed to "predicted_label".
+#' @inheritParams assert_forecast
 #' @export
 #' @method as_forecast_ordinal default
 #' @importFrom cli cli_warn
@@ -55,6 +56,7 @@ as_forecast_ordinal.default <- function(data,
                                         observed = NULL,
                                         predicted = NULL,
                                         predicted_label = NULL,
+                                        verbose = TRUE,
                                         ...) {
   data <- as_forecast_generic(
     data,
@@ -64,7 +66,7 @@ as_forecast_ordinal.default <- function(data,
     predicted_label = predicted_label
   )
   data <- new_forecast(data, "forecast_ordinal")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

R/class-forecast-point.R

@@ -24,13 +24,15 @@ as_forecast_point <- function(data, ...) {
 
 
 #' @rdname as_forecast_point
+#' @inheritParams assert_forecast
 #' @export
 #' @method as_forecast_point default
 #' @importFrom cli cli_warn
 as_forecast_point.default <- function(data,
                                       forecast_unit = NULL,
                                       observed = NULL,
                                       predicted = NULL,
+                                      verbose = TRUE,
                                       ...) {
   data <- as_forecast_generic(
     data,
@@ -39,7 +41,7 @@ as_forecast_point.default <- function(data,
     predicted = predicted
   )
   data <- new_forecast(data, "forecast_point")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

R/class-forecast-quantile.R

@@ -39,6 +39,7 @@ as_forecast_quantile <- function(data, ...) {
 #' @param quantile_level (optional) Name of the column in `data` that contains
 #'   the quantile level of the predicted values. This column will be renamed to
 #'   "quantile_level". Only applicable to quantile-based forecasts.
+#' @inheritParams assert_forecast
 #' @export
 #' @method as_forecast_quantile default
 #' @importFrom cli cli_warn
@@ -47,6 +48,7 @@ as_forecast_quantile.default <- function(data,
                                          observed = NULL,
                                          predicted = NULL,
                                          quantile_level = NULL,
+                                         verbose = TRUE,
                                          ...) {
   data <- as_forecast_generic(
     data,
@@ -58,19 +60,21 @@ as_forecast_quantile.default <- function(data,
   unique_q_levels <- sort(unique(data$quantile_level))
   level_diffs <- diff(unique_q_levels)
   if (any(level_diffs <= 1e-10)) {
-    cli_warn(
-      "The {.code quantile_level} column in your data
-      seems to have a rounding issue
-      (run {.code diff(sort(unique(data$quantile_level)))} to see this.
-      As {.code scoringutils} does not support arbitrarily fine quantile level
-      increments, we're going to run {.code round(x, digits = 10)} on
-      the {.code quantile_level} column."
-    )
+    if (verbose) {
+      cli_warn(
+        "The {.code quantile_level} column in your data
+        seems to have a rounding issue
+        (run {.code diff(sort(unique(data$quantile_level)))} to see this.
+        As {.code scoringutils} does not support arbitrarily fine quantile level
+        increments, we're going to run {.code round(x, digits = 10)} on
+        the {.code quantile_level} column."
+      )
+    }
     data$quantile_level <- round(data$quantile_level, digits = 9)
   }
 
   data <- new_forecast(data, "forecast_quantile")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

R/class-forecast-sample.R

@@ -31,13 +31,15 @@ as_forecast_sample <- function(data, ...) {
 #' @rdname as_forecast_sample
 #' @param sample_id (optional) Name of the column in `data` that contains the
 #'   sample id. This column will be renamed to "sample_id".
+#' @inheritParams assert_forecast
 #' @export
 #' @importFrom cli cli_warn
 as_forecast_sample.default <- function(data,
                                        forecast_unit = NULL,
                                        observed = NULL,
                                        predicted = NULL,
                                        sample_id = NULL,
+                                       verbose = TRUE,
                                        ...) {
   data <- as_forecast_generic(
     data,
@@ -47,7 +49,7 @@ as_forecast_sample.default <- function(data,
     sample_id = sample_id
   )
   data <- new_forecast(data, "forecast_sample")
-  assert_forecast(data)
+  assert_forecast(data, verbose = verbose)
   return(data)
 }
 

tests/testthat/test-class-forecast-binary.R

@@ -7,6 +7,14 @@ test_that("output of as_forecast_binary() is accepted as input to score()", {
   expect_identical(score_check, suppressMessages(score(as_forecast_binary(example_binary))))
 })
 
+test_that("as_forecast_binary() accepts verbose argument and suppresses messages", {
+  expect_no_condition(
+    as_forecast_binary(example_binary, verbose = FALSE)
+  )
+  result <- as_forecast_binary(example_binary, verbose = FALSE)
+  expect_s3_class(result, "forecast_binary")
+})
+
 
 # ==============================================================================
 # is_forecast_binary() # nolint: commented_code_linter

tests/testthat/test-class-forecast-nominal.R

@@ -30,6 +30,14 @@ test_that("as_forecast.forecast_nominal() breaks when rows with zero probability
   )
 })
 
+test_that("as_forecast_nominal() accepts verbose argument", {
+  expect_no_condition(
+    as_forecast_nominal(na.omit(example_nominal), verbose = FALSE)
+  )
+  result <- as_forecast_nominal(na.omit(example_nominal), verbose = FALSE)
+  expect_s3_class(result, "forecast_nominal")
+})
+
 
 # ==============================================================================
 # is_forecast_nominal() # nolint: commented_code_linter

tests/testthat/test-class-forecast-point.R

@@ -8,6 +8,14 @@ test_that("as_forecast_point() works", {
   )
 })
 
+test_that("as_forecast_point() accepts verbose argument and suppresses messages", {
+  expect_no_condition(
+    as_forecast_point(example_point, verbose = FALSE)
+  )
+  result <- as_forecast_point(example_point, verbose = FALSE)
+  expect_s3_class(result, "forecast_point")
+})
+
 
 # ==============================================================================
 # is_forecast_point() # nolint: commented_code_linter