Create S3 generic return_()

R/absolute_error.R

@@ -31,7 +31,7 @@ ae_median_sample <- function(true_values, predictions) {
 
   ae_median <- abs(true_values - median_predictions)
 
-  return(ae_median)
+  return_(ae_median)
 }
 
 
@@ -66,7 +66,7 @@ ae_median_quantile <- function(true_values, predictions, quantiles = NULL,
                                verbose = TRUE) {
   if (!is.null(quantiles)) {
     if (!any(quantiles == 0.5) && !any(is.na(quantiles))) {
-      return(NA_real_)
+      return_(NA_real_)
       if (verbose) {
         warning("in order to compute the absolute error of the median, `0.5` must be among the quantiles given. Maybe you want to use `abs_error()`?")
       }
@@ -75,7 +75,7 @@ ae_median_quantile <- function(true_values, predictions, quantiles = NULL,
     predictions <- predictions[quantiles == 0.5]
   }
   abs_error_median <- abs(true_values - predictions)
-  return(abs_error_median)
+  return_(abs_error_median)
 }
 
 
@@ -101,5 +101,5 @@ ae_median_quantile <- function(true_values, predictions, quantiles = NULL,
 
 
 abs_error <- function(true_values, predictions) {
-  return(abs(true_values - predictions))
+  return_(abs(true_values - predictions))
 }

R/bias.R

@@ -100,7 +100,7 @@ bias <- function(true_values, predictions) {
 
   if (continuous_predictions) {
     res <- 1 - 2 * P_x
-    return(res)
+    return_(res)
   } else {
     # for integer case also calculate empirical cdf for (y-1)
     P_xm1 <- vapply(seq_along(true_values),
@@ -110,7 +110,7 @@ bias <- function(true_values, predictions) {
                     .0)
 
     res <- 1 - (P_x + P_xm1)
-    return(res)
+    return_(res)
   }
 }
 
@@ -195,7 +195,7 @@ quantile_bias <- function(range, lower, upper,
 
     # deal with the point forecast case where inputs may be NA
     if (length(range) == 0 | length(lower_predictions) == 0 | length(upper_predictions) == 0) {
-      return(NA_real_)
+      return_(NA_real_)
     }
 
   }
@@ -217,23 +217,20 @@ quantile_bias <- function(range, lower, upper,
 
   if (true_value == median_prediction) {
     bias <- 0
-    return(bias)
   } else if (true_value < min(lower_predictions)) {
     lower <- 0
     bias <- 1 - 2 * lower
-    return(bias)
   } else if (true_value > max(upper_predictions)) {
     upper <- 1
     bias <- 1 - 2 * upper
-    return(bias)
   } else if (any(lower_predictions >= true_value)) {
     lower <- max(lower_quantiles[lower_predictions <= true_value])
     bias <- 1 - 2 * lower
-    return(bias)
   } else if (any(upper_predictions <= true_value)){
     upper <- min(upper_quantiles[upper_predictions >= true_value])
     bias <- 1 - 2 * upper
-    return(bias)
   }
+
+  return_(bias)
 }
 

R/brier_score.R

@@ -56,7 +56,7 @@ brier_score <- function (true_values, predictions) {
   # ============================================
 
   brierscore <- (sum((true_values - predictions)^2) ) / n
-  return(brierscore)
+  return_(brierscore)
 }
 
 

R/eval_forecasts.R

@@ -228,7 +228,7 @@ eval_forecasts <- function(data = NULL,
       if (verbose) {
         warning("After attempting to merge, only an empty data.table was left")
       }
-      return(data)
+      return_(data)
     }
   }
 
@@ -346,7 +346,7 @@ eval_forecasts <- function(data = NULL,
     if (verbose) {
       message("After removing all NA true values and predictions, there were no observations left")
     }
-    return(data)
+    return_(data)
   }
 
 
@@ -360,7 +360,7 @@ eval_forecasts <- function(data = NULL,
                                  sd = sd,
                                  summarised = summarised,
                                  verbose = verbose)
-    return(res)
+    return_(res)
   }
 
   # Score quantile predictions -------------------------------------------------
@@ -378,7 +378,7 @@ eval_forecasts <- function(data = NULL,
                                    compute_relative_skill = compute_relative_skill,
                                    rel_skill_metric = rel_skill_metric,
                                    baseline = baseline)
-    return(res)
+    return_(res)
   }
 
 
@@ -396,7 +396,7 @@ eval_forecasts <- function(data = NULL,
                                  pit_plots = pit_plots,
                                  summarised = summarised,
                                  verbose = verbose)
-    return(res)
+    return_(res)
   }
 }
 

R/eval_forecasts_binary.R

@@ -45,6 +45,7 @@ eval_forecasts_binary <- function(data,
                by = summarise_by]
 
   }
+  return_(res)
 }
 
 

R/eval_forecasts_continuous_integer.R

@@ -169,5 +169,5 @@ eval_forecasts_sample <- function(data,
                 pit_plots = pit_histograms)
   }
 
-  return(res)
+  return_(res)
 }

R/eval_forecasts_helper.R

@@ -20,7 +20,7 @@ add_quantiles <- function(dt, varnames, quantiles, by) {
                                                              na.rm = TRUE)),
        by = c(by)]
   }
-  return(dt)
+  return_(dt)
 }
 
 
@@ -41,5 +41,5 @@ add_sd <- function(dt, varnames, by) {
   for (varname in varnames) {
     dt[, paste0(varname, "_sd") := sd(get(varname), na.rm = TRUE), by = by]
   }
-  return(dt)
+  return_(dt)
 }

R/eval_forecasts_quantile.R

@@ -190,5 +190,5 @@ eval_forecasts_quantile <- function(data,
     res[, c("quantile_coverage") := NULL]
   }
 
-  return(res)
+  return_(res)
 }

R/interval_score.R

@@ -106,12 +106,12 @@ interval_score <- function(true_values,
   score <- sharpness + underprediction + overprediction
 
   if (separate_results) {
-    return(list(interval_score = score,
-                sharpness = sharpness,
-                underprediction = underprediction,
-                overprediction = overprediction))
+    return_(list(interval_score = score,
+                 sharpness = sharpness,
+                 underprediction = underprediction,
+                 overprediction = overprediction))
   } else {
-    return(score)
+    return_(score)
   }
 }
 

R/metrics_point_forecasts.R

@@ -19,7 +19,7 @@
 
 mse <- function(true_values, predictions) {
   mse <- mean((true_values - predictions)^2)
-  return(mse)
+  return_(mse)
 }
 
 

R/pairwise-comparisons.R

@@ -96,7 +96,7 @@ pairwise_comparison <- function(scores,
                                                            summarise_by = summarise_by)
                     })
 
-  out <- data.table::rbindlist(results)
+  return_(data.table::rbindlist(results))
 }
 
 
@@ -172,7 +172,7 @@ add_rel_skill_to_eval_forecasts <- function(unsummarised_scores,
   # also delete skill metric from output
   out[, eval(rel_skill_metric) := NULL]
 
-  return(out)
+  return_(out)
 }
 
 
@@ -210,7 +210,7 @@ pairwise_comparison_one_group <- function(scores,
 
   # if there aren't enough models to do any comparison, return NULL
   if (length(models) < 2) {
-    return(NULL)
+    return_(NULL)
   }
 
   # the overlap is obtained by merging the available data for one model with
@@ -303,7 +303,7 @@ pairwise_comparison_one_group <- function(scores,
   data.table::setnames(out, old = c("ratio", "theta", "rel_to_baseline"),
                        new = c("mean_scores_ratio", "relative_skill", "scaled_rel_skill"))
 
-  return(out)
+  return_(out)
 }
 
 
@@ -355,7 +355,7 @@ compare_two_models <- function(scores,
 unique(overlap)
 
   if (nrow(overlap) == 0) {
-    return(list(ratio = NA_real_, pval = NA_real_))
+    return_(list(ratio = NA_real_, pval = NA_real_))
   }
 
   values_x <- overlap[[paste0(metric, ".x")]]
@@ -381,8 +381,8 @@ unique(overlap)
     # alternative: do a paired t-test on ranks?
     pval <- wilcox.test(values_x, values_y, paired = TRUE)$p.value
   }
-  return(list(mean_scores_ratio = ratio,
-              pval = pval))
+  return_(list(mean_scores_ratio = ratio,
+               pval = pval))
 }
 
 
@@ -471,7 +471,7 @@ plot_pairwise_comparison <- function(comparison_result,
                  right = FALSE,
                  labels = plot_scales)
     # scale[is.na(scale)] <- 0
-    return(as.numeric(as.character(scale)))
+    return_(as.numeric(as.character(scale)))
   }
 
   if (type[1] == "together") {
@@ -646,7 +646,7 @@ plot_pairwise_comparison <- function(comparison_result,
     }
   }
 
-  return(plot)
+  return_(plot)
 }
 
 

R/pit.R

@@ -220,7 +220,7 @@ pit <- function(true_values,
     }
   }
 
-  return(out)
+  return_(out)
 }
 
 
@@ -308,7 +308,7 @@ pit_df <- function(data,
     out$u <- res$u
   }
 
-  return(out)
+  return_(out)
 }
 
 
@@ -377,7 +377,7 @@ pit_df_fast <- function(data,
                    value.name = "prediction")
 
 
-  return(data)
+  return_(data)
 }
 
 
@@ -421,7 +421,7 @@ hist_PIT <- function(PIT_samples,
     ggplot2::labs(caption = paste0("p-value of Andersen-Darling test for uniformity: ",
                                    round(caption, 3)))
 
-  return(hist_PIT)
+  return_(hist_PIT)
 }
 
 
@@ -458,6 +458,6 @@ hist_PIT_quantile <- function(PIT_samples,
     ggplot2::ylab("Frequency") +
     ggplot2::labs()
 
-  return(hist_PIT)
+  return_(hist_PIT)
 }