Issue #485: Fix linting

.lintr

@@ -11,6 +11,6 @@ linters: linters_with_tags(
 exclusions: c(
     list.files("tests", recursive = TRUE, full.names = TRUE),
     list.files("inst", recursive = TRUE, full.names = TRUE),
-    "vignettes/metric-details.Rmd"
+    list.files("vignettes", pattern = ".R$", full.names = TRUE)
   )
 exclude: "# nolint"

NAMESPACE

@@ -33,7 +33,7 @@ export(dss_sample)
 export(get_duplicate_forecasts)
 export(get_forecast_type)
 export(get_forecast_unit)
-export(interval_coverage_deviation_quantile)
+export(interval_coverage_dev_quantile)
 export(interval_coverage_quantile)
 export(interval_coverage_sample)
 export(interval_score)

R/add_coverage.R

@@ -51,13 +51,9 @@ add_coverage <- function(data) {
   forecast_unit <- get_forecast_unit(data)
   data_cols <- colnames(data) # store so we can reset column order later
 
-  # what happens if quantiles are not symmetric around the median?
-  # should things error? Also write tests for that.
   interval_data <- quantile_to_interval(data, format = "wide")
-  interval_data[, interval_coverage := ifelse(
-    observed <= upper & observed >= lower,
-    TRUE,
-    FALSE)
+  interval_data[,
+    interval_coverage := (observed <= upper) & (observed >= lower)
   ][, c("lower", "upper", "observed") := NULL]
 
   data[, range := get_range_from_quantile(quantile)]

R/available_forecasts.R

@@ -58,7 +58,7 @@ available_forecasts <- function(data,
   data <- data[data[, .I[1], by = collapse_by]$V1]
 
   # count number of rows = number of forecasts
-  out <- data[, .(`count` = .N), by = by]
+  out <- data[, .(count = .N), by = by]
 
   # make sure that all combinations in "by" are included in the output (with
   # count = 0). To achieve that, take the unique values in data and expand grid

R/data.R

@@ -19,7 +19,9 @@
 #'   \item{model}{name of the model that generated the forecasts}
 #'   \item{horizon}{forecast horizon in weeks}
 #' }
+# nolint start
 #' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_quantile"
 
 
@@ -44,7 +46,9 @@
 #'   \item{model}{name of the model that generated the forecasts}
 #'   \item{horizon}{forecast horizon in weeks}
 #' }
+# nolint start
 #' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_point"
 
 
@@ -69,7 +73,9 @@
 #'   \item{predicted}{predicted value}
 #'   \item{sample_id}{id for the corresponding sample}
 #' }
+# nolint start
 #' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_continuous"
 
 
@@ -94,6 +100,9 @@
 #'   \item{predicted}{predicted value}
 #'   \item{sample_id}{id for the corresponding sample}
 #' }
+# nolint start
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_integer"
 
 
@@ -124,7 +133,9 @@
 #'   \item{horizon}{forecast horizon in weeks}
 #'   \item{predicted}{predicted value}
 #' }
+# nolint start
 #' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_binary"
 
 
@@ -147,7 +158,9 @@
 #'   \item{model}{name of the model that generated the forecasts}
 #'   \item{horizon}{forecast horizon in weeks}
 #' }
+# nolint start
 #' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_quantile_forecasts_only"
 
 
@@ -167,7 +180,9 @@
 #'   \item{observed}{observed values}
 #'   \item{location_name}{name of the country for which a prediction was made}
 #' }
+# nolint start
 #' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+# nolint end
 "example_truth_only"
 
 #' Summary information for selected metrics
@@ -215,14 +230,16 @@
 #' Default metrics for quantile-based forecasts.
 #'
 #' A named list with functions:
-#' - "wis" = [wis()]
+#' - "wis" = [wis]
 #' - "overprediction" = [overprediction()]
 #' - "underprediction" = [underprediction()]
 #' - "dispersion" = [dispersion()]
 #' - "bias" = [bias_quantile()]
-#' - "coverage_50" = \(...) {run_safely(..., range = 50, fun = [interval_coverage_quantile][interval_coverage_quantile()])}
-#' - "coverage_90" = \(...) {run_safely(..., range = 90, fun = [interval_coverage_quantile][interval_coverage_quantile()])}
-#' - "coverage_deviation" = [interval_coverage_deviation_quantile()],
+#' - "coverage_50" = [interval_coverage_quantile()]
+#' - "coverage_90" = \(...) \{
+#'      run_safely(..., range = 90, fun = [interval_coverage_quantile])
+#'   \}
+#' - "coverage_deviation" = [interval_coverage_dev_quantile()],
 #' - "ae_median" = [ae_median_quantile()]
 #' @keywords info
 "metrics_quantile"

R/metrics-quantile.R

@@ -120,25 +120,26 @@ wis <- function(observed,
 
   reformatted[, eval(cols) := do.call(
     interval_score,
-    list(observed = observed,
-         lower = lower,
-         upper = upper,
-         interval_range = range,
-         weigh = weigh,
-         separate_results = separate_results
+    list(
+      observed = observed,
+      lower = lower,
+      upper = upper,
+      interval_range = range,
+      weigh = weigh,
+      separate_results = separate_results
     )
   )]
 
-  if (!count_median_twice) {
-    reformatted[, weight := ifelse(range == 0, 0.5, 1)]
-  } else {
+  if (count_median_twice) {
     reformatted[, weight := 1]
+  } else {
+    reformatted[, weight := ifelse(range == 0, 0.5, 1)]
   }
 
   # summarise results by forecast_id
   reformatted <- reformatted[
     , lapply(.SD, weighted.mean, na.rm = na.rm, w = weight),
-    by = c("forecast_id"),
+    by = "forecast_id",
     .SDcols = colnames(reformatted) %like% paste(cols, collapse = "|")
   ]
 
@@ -230,15 +231,14 @@ interval_coverage_quantile <- function(observed, predicted, quantile, range = 50
   if (!all(necessary_quantiles %in% quantile)) {
     warning(
       "To compute the coverage for a range of ", range, "%, the quantiles ",
-      necessary_quantiles, " are required. Returning `NA`.")
+      necessary_quantiles, " are required. Returning `NA`."
+    )
     return(NA)
   }
   r <- range
   reformatted <- quantile_to_interval(observed, predicted, quantile)
   reformatted <- reformatted[range %in% r]
-  reformatted[, coverage := ifelse(
-    observed >= lower & observed <= upper, TRUE, FALSE
-  )]
+  reformatted[, coverage := (observed >= lower) & (observed <= upper)]
   return(reformatted$coverage)
 }
 
@@ -296,34 +296,32 @@ interval_coverage_quantile <- function(observed, predicted, quantile, range = 50
 #'    c(-2, 0, 3, 3, 4)
 #' )
 #' quantile <- c(0.1, 0.25, 0.5, 0.75, 0.9)
-#' interval_coverage_deviation_quantile(observed, predicted, quantile)
-interval_coverage_deviation_quantile <- function(observed, predicted, quantile) {
+#' interval_coverage_dev_quantile(observed, predicted, quantile)
+interval_coverage_dev_quantile <- function(observed, predicted, quantile) {
   assert_input_quantile(observed, predicted, quantile)
 
   # transform available quantiles into central interval ranges
   available_ranges <- unique(get_range_from_quantile(quantile))
 
   # check if all necessary quantiles are available
-  necessary_quantiles <- unique(c(
-    (100 - available_ranges) / 2,
-    100 - (100 - available_ranges) / 2) / 100
+  necessary_quantiles <- unique(
+    c((100 - available_ranges) / 2, 100 - (100 - available_ranges) / 2) / 100
   )
   if (!all(necessary_quantiles %in% quantile)) {
     missing <- necessary_quantiles[!necessary_quantiles %in% quantile]
     warning(
       "To compute coverage deviation, all quantiles must form central ",
       "symmetric prediction intervals. Missing quantiles: ",
-      toString(missing), ". Returning `NA`.")
+      toString(missing), ". Returning `NA`."
+    )
     return(NA)
   }
 
   reformatted <- quantile_to_interval(observed, predicted, quantile)[range != 0]
-  reformatted[, coverage := ifelse(
-    observed >= lower & observed <= upper, TRUE, FALSE
-  )]
+  reformatted[, coverage := (observed >= lower) & (observed <= upper)]
   reformatted[, coverage_deviation := coverage - range / 100]
   out <- reformatted[, .(coverage_deviation = mean(coverage_deviation)),
-                     by = c("forecast_id")]
+                     by = "forecast_id"]
   return(out$coverage_deviation)
 }
 
@@ -427,14 +425,14 @@ bias_quantile_single_vector <- function(observed, predicted, quantile, na.rm) {
   predicted_has_NAs <- anyNA(predicted)
   quantile_has_NAs <- anyNA(quantile)
 
-  if(any(predicted_has_NAs, quantile_has_NAs)) {
-    if (!na.rm) {
-      return(NA_real_)
-    } else {
+  if (any(predicted_has_NAs, quantile_has_NAs)) {
+    if (na.rm) {
       quantile <- quantile[!is.na(predicted)]
       predicted <- predicted[!is.na(predicted)]
       predicted <- predicted[!is.na(quantile)]
       quantile <- quantile[!is.na(quantile)]
+    } else {
+      return(NA_real_)
     }
   }
 
@@ -623,12 +621,13 @@ wis_one_to_one <- function(observed,
   reformatted <- quantile_to_interval(observed, predicted, quantile)
   reformatted[, eval(cols) := do.call(
     interval_score,
-    list(observed = observed,
-         lower = lower,
-         upper = upper,
-         interval_range = range,
-         weigh = weigh,
-         separate_results = separate_results
+    list(
+      observed = observed,
+      lower = lower,
+      upper = upper,
+      interval_range = range,
+      weigh = weigh,
+      separate_results = separate_results
     )
   )]
 
@@ -672,7 +671,7 @@ wis_one_to_one <- function(observed,
   if (output == "matrix") {
     wis <- matrix(wis, nrow = n, ncol = N)
     if (separate_results) {
-      components <- lapply(components, function(x) matrix(x, nrow = n, ncol = N))
+      components <- lapply(components, matrix, nrow = n, ncol = N)
       return(c(wis, components))
     } else {
       return(wis)

R/metrics-sample.R

@@ -313,9 +313,7 @@ interval_coverage_sample <- function(observed, predicted, range = 50) {
   # this could call interval_coverage_quantile instead
   # ==========================================================
   interval_dt <- quantile_to_interval(quantile_dt, format = "wide")
-  interval_dt[, coverage := ifelse(
-    observed >= lower & observed <= upper, TRUE, FALSE
-  )]
+  interval_dt[, coverage := (observed >= lower) & (observed <= upper)]
   # ==========================================================
   return(interval_dt$coverage)
 }

R/pairwise-comparisons.R

@@ -66,10 +66,10 @@ pairwise_comparison <- function(scores,
                                 baseline = NULL,
                                 ...) {
   metric <- match.arg(metric, c("auto", available_metrics()))
-  if (!is.data.table(scores)) {
-    scores <- as.data.table(scores)
-  } else {
+  if (is.data.table(scores)) {
     scores <- copy(scores)
+  } else {
+    scores <- as.data.table(scores)
   }
 
   # determine metric automatically
@@ -228,8 +228,8 @@ pairwise_comparison_one_group <- function(scores,
 
   # make result character instead of factor
   result[, `:=`(
-    "model" = as.character(model),
-    "compare_against" = as.character(compare_against)
+    model = as.character(model),
+    compare_against = as.character(compare_against)
   )]
 
   # calculate relative skill as geometric mean

R/pit.R

@@ -125,10 +125,10 @@ pit_sample <- function(observed,
 
   # check data type ------------------------------------------------------------
   # check whether continuous or integer
-  if (!isTRUE(all.equal(as.vector(predicted), as.integer(predicted)))) {
-    continuous_predictions <- TRUE
-  } else {
+  if (isTRUE(all.equal(as.vector(predicted), as.integer(predicted)))) {
     continuous_predictions <- FALSE
+  } else {
+    continuous_predictions <- TRUE
   }
 
   # calculate PIT-values -------------------------------------------------------
@@ -209,7 +209,7 @@ pit <- function(data,
     value.var = "predicted"
   )
 
-  pit <- data_wide[, .("pit_value" = pit_sample(
+  pit <- data_wide[, .(pit_value = pit_sample(
     observed = observed,
     predicted = as.matrix(.SD)
   )),

R/plot.R

@@ -470,7 +470,7 @@
   # it separately here to deal with the case when only the median is provided
   # (in which case ggdist::geom_lineribbon() will fail)
   if (0 %in% range) {
-    select_median <- (forecasts$range %in% 0 & forecasts$boundary == "lower")
+    select_median <- (forecasts$range == 0 & forecasts$boundary == "lower")
     median <- forecasts[select_median]
 
     if (nrow(median) > 0) {
@@ -968,7 +968,7 @@
 #' ) +
 #'  facet_wrap("target_type")
 
 plot.scoringutils_available_forecasts <- function(x,
                                                   yvar = "model",
                                                   xvar = "forecast_date",
                                                   make_xvar_factor = TRUE,

R/score.R

@@ -229,11 +229,13 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) {
 
   # transpose the forecasts that belong to the same forecast unit
   # make sure the quantiles and predictions are ordered in the same way
-  d_transposed <- data[, .(predicted = list(predicted[order(quantile)]),
-                           observed = unique(observed),
-                           quantile = list(quantile[order(quantile)]),
-                           scoringutils_quantile = toString(quantile[order(quantile)])),
-                       by = forecast_unit]
+  d_transposed <- data[, .(
+    predicted = list(predicted[order(quantile)]),
+    observed = unique(observed),
+    quantile = list(sort(quantile, na.last = TRUE)),
+    scoringutils_quantile = toString(sort(quantile, na.last = TRUE))
+  ),
+  by = forecast_unit]
 
   # split according to quantile lengths and do calculations for different
   # quantile lengths separately. The function `wis()` assumes that all
@@ -265,12 +267,9 @@ apply_metrics <- function(data, metrics, ...) {
     data[, (metric_name) := do.call(run_safely, list(..., fun = fun))]
   )
   lapply(seq_along(metrics), function(i, data, ...) {
-    metric_name <- names(metrics[i])
-    fun <- metrics[[i]]
+    metric_name <- names(metrics[i]) # nolint
+    fun <- metrics[[i]] # nolint
     eval(expr)
   }, data, ...)
   return(data)
 }
-
-
-

R/summarise_scores.R

@@ -114,8 +114,8 @@ summarise_scores <- function(scores,
   stored_attributes <- c(
     get_scoringutils_attributes(scores),
     list(
-      "scoringutils_by" = by,
-      "unsummarised_scores" =  scores
+      scoringutils_by = by,
+      unsummarised_scores =  scores
     )
   )