Linting overhaul

.github/workflows/lint.yaml

@@ -1,30 +1,49 @@
 # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
 on:
-  push:
-    branches: [main, master, develop]
   pull_request:
-    branches: [main, master, develop]
+    branches:
+      - main
+      - master
+      - develop
+  workflow_dispatch:
 
-name: lint
+name: lint-changed-files
 
 jobs:
-  lint:
+  lint-changed-files:
     runs-on: ubuntu-latest
+    if: "! contains(github.event.head_commit.message, '[ci skip]')"
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v3
 
       - uses: r-lib/actions/setup-r@v2
-        with:
-          use-public-rspm: true
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: any::lintr
-          needs: lint
+          extra-packages: |
+            any::gh
+            any::lintr
+            any::purrr
+          needs: check
+
+      - name: Add lintr options
+        run: |
+          cat('\noptions(lintr.linter_file = ".lintr")\n', file = "~/.Rprofile", append = TRUE)
+        shell: Rscript {0}
+
+      - name: Install package
+        run: R CMD INSTALL .
 
-      - name: Lint
-        run: lintr::lint_package()
+      - name: Extract and lint files changed by this PR
+        run: |
+          files <- gh::gh("GET https://api.github.com/repos/${{ github.repository }}/pulls/${{ github.event.pull_request.number }}/files")
+          changed_files <- purrr::map_chr(files, "filename")
+          all_files <- list.files(recursive = TRUE)
+          exclusions_list <- as.list(setdiff(all_files, changed_files))
+          lintr::lint_package(exclusions = exclusions_list)
         shell: Rscript {0}
+        env:
+          LINTR_ERROR_ON_LINT: true

.lintr

@@ -1,7 +1,16 @@
-linters: with_defaults(
-    line_length_linter = line_length_linter(120),
-    cyclocomp_linter = cyclocomp_linter(complexity_limit = 20L),
-    object_usage_linter = NULL)
-exclusions: c(list.files(path = "tests/", recursive = T, full.names = T),
- list.files(path = "inst/", recursive = T, full.names = T))
+linters: linters_with_tags(
+    tags = NULL, # include all linters
+    implicit_integer_linter = NULL,
+    extraction_operator_linter = NULL,
+    undesirable_function_linter = NULL,
+    function_argument_linter = NULL,
+    object_name_linter = NULL,
+    line_length_linter(120),
+    cyclocomp_linter(20L)
+  )
+exclusions: c(
+    list.files("tests", recursive = TRUE, full.names = TRUE),
+    list.files("inst", recursive = TRUE, full.names = TRUE),
+    "vignettes/metric-details.Rmd"
+  )
 exclude: "# nolint"

NEWS.md

@@ -1,7 +1,14 @@
 # scoringutils 1.1.3
 
 ## Package updates
-- added a warning to `interval_score()` if the interval range is between 0 and 1. Thanks to @adrian-lison (see #277) 
+
+- Added a warning to `interval_score()` if the interval range is between 0 and 1. Thanks to @adrian-lison (see #277) for the suggestion.
+
+## Package updates
+
+- Switched to a linting GitHub Action that only triggers on changes. Inspired by @bisaloo recent contribution to the [`epinowcast` package](https://github.com/epinowcast/epinowcast/pull/220).
+- Updated package linters to be more extensive. Inspired by @bisaloo recent contribution to the [`epinowcast` package](https://github.com/epinowcast/epinowcast/pull/220).
+- Resolved all flagged linting issues across the package.
 
 # scoringutils 1.1.2
 

R/bias.R

@@ -160,14 +160,14 @@ bias_range <- function(range, lower, upper,
   lower_predictions <- lower
   upper_predictions <- upper
 
-  if (anyNA(upper) | anyNA(lower)) {
+  if (anyNA(upper) || anyNA(lower)) {
     range <- range[!is.na(upper) & !is.na(lower)]
     lower_predictions <- lower[!is.na(lower) & !is.na(upper)]
     upper_predictions <- upper[!is.na(lower) & !is.na(upper)]
 
     # deal with the point forecast case where inputs may be NA
-    if (length(range) == 0 |
-        length(lower_predictions) == 0 |
+    if (length(range) == 0 ||
+        length(lower_predictions) == 0 ||
         length(upper_predictions) == 0
       ) {
       return(NA_real_)
@@ -282,7 +282,7 @@ bias_quantile <- function(predictions, quantiles, true_value) {
     predictions <- predictions[!is.na(predictions)]
   }
   # if there is no input, return NA
-  if (length(quantiles) == 0 | length(predictions) == 0) {
+  if (length(quantiles) == 0 || length(predictions) == 0) {
     return(NA_real_)
   }
 

R/check_forecasts.R

@@ -77,7 +77,7 @@ check_forecasts <- function(data) {
       warnings,
       paste0(
         "At least one column in the data ",
-        "(", paste(clashing_colnames, collapse = ", "), ") ",
+        "(", toString(clashing_colnames), ") ",
         "corresponds to the name of a metric that will be computed by ",
         "scoringutils. Please check `available_metrics()`"
       )
@@ -151,8 +151,11 @@ check_forecasts <- function(data) {
   if (nrow(check_duplicates) > 0) {
     errors <- c(
       errors,
-      paste(
-        "There are instances with more than one forecast for the same target. This can't be right and needs to be resolved. Maybe you need to check the unit of a single forecast and add missing columns? Use the function find_duplicates() to identify duplicate rows."
+      paste0(
+        "There are instances with more than one forecast for the same target. ",
+         "This can't be right and needs to be resolved. Maybe you need to ",
+         "check the unit of a single forecast and add missing columns? Use ",
+         "the  function find_duplicates() to identify duplicate rows."
       )
     )
   }
@@ -165,7 +168,7 @@ check_forecasts <- function(data) {
       warnings,
       paste0(
         "Some forecasts have different numbers of rows (e.g. quantiles or samples). ", # nolint
-        "scoringutils found: ", paste(n, collapse = ", "),
+        "scoringutils found: ", toString(n),
         ". This is not necessarily a problem, but make sure this is intended."
       )
     )
@@ -177,7 +180,6 @@ check_forecasts <- function(data) {
   out[["cleaned_data"]] <- data
 
   # available unique values per model for the different columns
-  cols <- forecast_unit[forecast_unit != "model"]
   out[["unique_values"]] <-
     data[, lapply(.SD, FUN = function(x) length(unique(x))), by = "model"]
 

R/convenience-functions.R

@@ -58,7 +58,7 @@
 #' Sebastian Funk
 #' medRxiv 2023.01.23.23284722
 #' \doi{https://doi.org/10.1101/2023.01.23.23284722}
-#' <https://www.medrxiv.org/content/10.1101/2023.01.23.23284722v1> 
+#' <https://www.medrxiv.org/content/10.1101/2023.01.23.23284722v1>
 #' @keywords check-forecasts
 #' @examples
 #'
@@ -197,7 +197,7 @@ log_shift <- function(x,
                       offset = 0,
                       base = exp(1)) {
 
-  if (any (x < 0, na.rm = TRUE)) {
+  if (any(x < 0, na.rm = TRUE)) {
     w <- paste("Detected input values < 0.")
     stop(w)
   }

R/correlations.R

@@ -25,7 +25,12 @@ correlation <- function(scores,
 
   # if quantile column is present, throw a warning
   if ("quantile" %in% names(scores)) {
-    warning("There is a column called 'quantile' in the scores. Usually, you should call 'summarise_scores()' to summarise over quantiles and obtain one score per forecast before calculating correlations. You can ignore this warning if you know what you're doing.")
+    warning(
+      "There is a column called 'quantile' in the scores. Usually, you ",
+      "should call 'summarise_scores()' to summarise over quantiles and ",
+      "obtain one score per forecast before calculating correlations. You ",
+      "can ignore this warning if you know what you're doing."
+    )
   }
 
   # remove all non metrics and non-numeric columns

R/data.R

@@ -19,7 +19,7 @@
 #'   \item{model}{name of the model that generated the forecasts}
 #'   \item{horizon}{forecast horizon in weeks}
 #' }
-#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint
 "example_quantile"
 
 
@@ -45,7 +45,7 @@
 #'   \item{model}{name of the model that generated the forecasts}
 #'   \item{horizon}{forecast horizon in weeks}
 #' }
-#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint
 "example_point"
 
 
@@ -70,7 +70,7 @@
 #'   \item{prediction}{predicted value}
 #'   \item{sample}{id for the corresponding sample}
 #' }
-#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint
 "example_continuous"
 
 
@@ -125,7 +125,7 @@
 #'   \item{horizon}{forecast horizon in weeks}
 #'   \item{prediction}{predicted value}
 #' }
-#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint
 "example_binary"
 
 
@@ -148,7 +148,7 @@
 #'   \item{model}{name of the model that generated the forecasts}
 #'   \item{horizon}{forecast horizon in weeks}
 #' }
-#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint
 "example_quantile_forecasts_only"
 
 
@@ -168,7 +168,7 @@
 #'   \item{true_value}{true observed values}
 #'   \item{location_name}{name of the country for which a prediction was made}
 #' }
-#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/}
+#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint
 "example_truth_only"
 
 #' Summary information for selected metrics

R/input-check-helpers.R

@@ -166,12 +166,12 @@ check_equal_length <- function(...,
 
   if (length(unique(lengths)) != 1) {
     calling_function <- deparse(sys.calls()[[sys.nframe() - 1]])
-    stop(paste0(
+    stop(
       "Arguments passed to the following function call: '",
       calling_function,
       "' should have the same length (or length one). Arguments have the following lengths: ",
-      paste0(lengths, collapse = ", ")
-    ))
+      toString(lengths)
+    )
   }
   return(invisible(NULL))
 }
@@ -201,7 +201,7 @@ check_metrics <- function(metrics) {
   if (!all(metrics %in% available_metrics)) {
     msg <- paste(
       "The following metrics are not available:",
-      paste(setdiff(metrics, available_metrics), collapse = ", ")
+      toString(setdiff(metrics, available_metrics))
     )
     warning(msg)
   }

R/pairwise-comparisons.R

@@ -62,7 +62,7 @@
 #'   facet_wrap(~target_type)
 
 pairwise_comparison <- function(scores,
-                                by = c("model"),
+                               by = "model",
                                 metric = "auto",
                                 baseline = NULL,
                                 ...) {
@@ -107,7 +107,10 @@ pairwise_comparison <- function(scores,
   # if by is equal to forecast_unit, then pairwise comparisons don't make sense
   if (setequal(by, forecast_unit)) {
     by <- "model"
-    message("relative skill can only be computed if `by` is different from the unit of a single forecast. `by` was set to 'model'")
+    message(
+      "relative skill can only be computed if `by` is different from the ",
+      "unit of a single forecast. `by` was set to 'model'"
+    )
   }
 
   # summarise scores over everything (e.g. quantiles, ranges or samples) in
@@ -124,7 +127,7 @@ pairwise_comparison <- function(scores,
 
   results <- lapply(split_scores,
     FUN = function(scores) {
-      out <- pairwise_comparison_one_group(
+      pairwise_comparison_one_group(
         scores = scores,
         metric = metric,
         baseline = baseline,

R/pit.R

@@ -90,7 +90,7 @@ pit_sample <- function(true_values,
   # error handling--------------------------------------------------------------
   # check al arguments are provided
   # this could be integrated into check_not_null
-  if (missing("true_values") | missing("predictions")) {
+  if (missing("true_values") || missing("predictions")) {
     stop("`true_values` or `predictions` missing in function 'pit_sample()'")
   }
   check_not_null(true_values = true_values, predictions = predictions)
@@ -213,7 +213,7 @@ pit <- function(data,
 
   # if prediction type is not quantile, calculate PIT values based on samples
   data_wide <- data.table::dcast(data,
-    ... ~ paste("InternalSampl_", sample, sep = ""),
+    ... ~ paste0("InternalSampl_", sample),
     value.var = "prediction"
   )
 
@@ -222,7 +222,7 @@ pit <- function(data,
     predictions = as.matrix(.SD)
   )),
   by = by,
-  .SDcols = grepl("InternalSampl_", names(data_wide))
+  .SDcols = grepl("InternalSampl_", names(data_wide), fixed = TRUE)
   ]
 
   return(pit[])