Merge branch 'main' into sb-eq

.github/workflows/R-CMD-check.yaml

@@ -37,7 +37,7 @@ jobs:
           # Use older ubuntu to maximise backward compatibility
           - {os: ubuntu-latest,  r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,  r: 'devel', http-user-agent: 'release', locale: 'en_US'}
-          - {os: ubuntu-latest,  r: 'devel', http-user-agent: 'release', locale: 'zh_CN'}
+          - {os: ubuntu-latest,  r: 'release', http-user-agent: 'release', locale: 'zh_CN'}
           - {os: ubuntu-latest,  r: 'release'}
           - {os: ubuntu-latest,  r: 'oldrel-1'}
           - {os: ubuntu-latest,  r: 'oldrel-2'}

DESCRIPTION

@@ -78,6 +78,7 @@ Collate:
     'comment_linters.R'
     'comments.R'
     'comparison_negation_linter.R'
+    'condition_call_linter.R'
     'condition_message_linter.R'
     'conjunct_test_linter.R'
     'consecutive_assertion_linter.R'

NAMESPACE

@@ -37,6 +37,7 @@ export(closed_curly_linter)
 export(commas_linter)
 export(commented_code_linter)
 export(comparison_negation_linter)
+export(condition_call_linter)
 export(condition_message_linter)
 export(conjunct_test_linter)
 export(consecutive_assertion_linter)

NEWS.md

@@ -15,6 +15,7 @@
 ## Bug fixes
 
 * `object_name_linter()` no longer errors when user-supplied `regexes=` have capture groups (#2188, @MichaelChirico).
+* `.lintr` config validation correctly accepts regular exressions which only compile under `perl = TRUE` (#2375, @MichaelChirico). These have always been valid (since `rex::re_matches()`, which powers the lint exclusion logic, also uses this setting), but the new up-front validation in v3.1.1 incorrectly used `perl = FALSE`.
 
 ## Changes to default linters
 
@@ -31,9 +32,12 @@
 * `backport_linter()` is slightly faster by moving expensive computations outside the linting function (#2339, #2348, @AshesITR and @MichaelChirico).
 * `Linter()` has a new argument `linter_level` (default `NA`). This is used by `lint()` to more efficiently check for expression levels than the idiom `if (!is_lint_level(...)) { return(list()) }` (#2351, @AshesITR).
 * `string_boundary_linter()` recognizes regular expression calls like `grepl("^abc$", x)` that can be replaced by using `==` instead (#1613, @MichaelChirico).
+* `unreachable_code_linter()` has an argument `allow_comment_regex` for customizing which "terminal" comments to exclude (#2327, @MichaelChirico). `# nolint end` comments are always excluded, as are {covr} exclusions (e.g. `# nocov end`) by default.
+* `format()` and `print()` methods for `lint` and `lints` classes get a new option `width` to control the printing width of lint messages (#1884, @MichaelChirico). The default is controlled by a new option `lintr.format_width`; if unset, no wrapping occurs (matching earlier behavior).
 
 ### New linters
 
+* `condition_call_linter()` for ensuring consistent use of `call.` in `warning()` and `stop()`. The default `call. = FALSE` follows the tidyverse guidance of not displaying the call (#2226, @Bisaloo)
 * `sample_int_linter()` for encouraging `sample.int(n, ...)` over equivalents like `sample(1:n, ...)` (part of #884, @MichaelChirico).
 * `stopifnot_all_linter()` discourages tests with `all()` like `stopifnot(all(x > 0))`; `stopifnot()` runs `all()` itself, and uses a better error message (part of #884, @MichaelChirico).
 * `comparison_negation_linter()` for discouraging negated comparisons when a direct negation is preferable, e.g. `!(x == y)` could be `x != y` (part of #884, @MichaelChirico).
@@ -58,6 +62,7 @@
 * `unnecessary_lambda_linter()`
   + ignores extractions with explicit returns like `lapply(l, function(x) foo(x)$bar)` (#2258, @MichaelChirico).
   + ignores calls on the RHS of operators like `lapply(l, function(x) "a" %in% names(x))` (#2310, @MichaelChirico).
+* `vector_logic_linter()` recognizes some cases where bitwise `&`/`|` are used correctly (#1453, @MichaelChirico).
 
 # lintr 3.1.1
 

R/addins.R

@@ -1,7 +1,7 @@
 # nocov start
 addin_lint <- function() {
   if (!requireNamespace("rstudioapi", quietly = TRUE)) {
-    stop("'rstudioapi' is required for add-ins.")
+    stop("'rstudioapi' is required for add-ins.", call. = FALSE)
   }
   filename <- rstudioapi::getSourceEditorContext()
   if (filename$path == "") {
@@ -27,7 +27,7 @@ addin_lint <- function() {
 
 addin_lint_package <- function() {
   if (!requireNamespace("rstudioapi", quietly = TRUE)) {
-    stop("'rstudioapi' is required for add-ins.")
+    stop("'rstudioapi' is required for add-ins.", call. = FALSE)
   }
   project <- rstudioapi::getActiveProject()
   project_path <- if (is.null(project)) getwd() else project

R/backport_linter.R

@@ -94,7 +94,7 @@ normalize_r_version <- function(r_version) {
     version_names <- c("devel", "release", paste0("oldrel-", seq_len(length(minor_versions) - 2L)))
     if (!r_version %in% version_names) {
       # This can only trip if e.g. oldrel-99 is requested
-      stop("`r_version` must be a version number or one of ", toString(sQuote(version_names)))
+      stop("`r_version` must be a version number or one of ", toString(sQuote(version_names)), call. = FALSE)
     }
     requested_version <- minor_versions[match(r_version, table = version_names)]
     available_patches <- all_versions[startsWith(all_versions, requested_version)]
@@ -106,10 +106,13 @@ normalize_r_version <- function(r_version) {
   } else if (is.character(r_version)) {
     r_version <- R_system_version(r_version, strict = TRUE)
   } else if (!inherits(r_version, "R_system_version")) {
-    stop("`r_version` must be a R version number, returned by R_system_version(), or a string.")
+    stop("`r_version` must be a R version number, returned by R_system_version(), or a string.", call. = FALSE)
   }
   if (r_version < "3.0.0") {
-    warning("It is not recommended to depend on an R version older than 3.0.0. Resetting 'r_version' to 3.0.0.")
+    warning(
+      "It is not recommended to depend on an R version older than 3.0.0. Resetting 'r_version' to 3.0.0.",
+      call. = FALSE
+    )
     r_version <- R_system_version("3.0.0")
   }
   r_version

R/cache.R

@@ -55,7 +55,8 @@ load_cache <- function(file, path = NULL) {
       error = function(e) {
         warning(
           "Could not load cache file '", file, "':\n",
-          conditionMessage(e)
+          conditionMessage(e),
+          call. = FALSE
         )
       }
     )

R/comments.R

@@ -84,10 +84,10 @@ wercker_build_info <- function() {
 # nocov start
 github_comment <- function(text, info = NULL, token = settings$comment_token) {
   if (!requireNamespace("httr", quietly = TRUE)) {
-    stop("Package 'httr' is required to post comments with github_comment().")
+    stop("Package 'httr' is required to post comments with github_comment().", call. = FALSE)
   }
   if (!requireNamespace("jsonlite", quietly = TRUE)) {
-    stop("Package 'jsonlite' is required to post comments with github_comment().")
+    stop("Package 'jsonlite' is required to post comments with github_comment().", call. = FALSE)
   }
 
   if (is.null(info)) {
@@ -99,7 +99,7 @@ github_comment <- function(text, info = NULL, token = settings$comment_token) {
   } else if (!is.null(info$commit)) {
     api_subdir <- file.path("commits", info$commit)
   } else {
-    stop("Expected a pull or a commit, but received ci_build_info() = ", format(info))
+    stop("Expected a pull or a commit, but received ci_build_info() = ", format(info), call. = FALSE)
   }
   response <- httr::POST(
     "https://api.github.com",

R/condition_call_linter.R

@@ -0,0 +1,116 @@
+#' Recommend usage of `call. = FALSE` in conditions
+#'
+#' This linter, with the default `display_call = FALSE`, enforces the
+#' recommendation of the tidyverse design guide regarding displaying error
+#' calls.
+#'
+#' @param display_call Logical specifying expected behaviour regarding `call.`
+#' argument in conditions.
+#'   - `NA` forces providing `call.=` but ignores its value (this can be used in
+#'     cases where you expect a mix of `call. = FALSE` and `call. = TRUE`)
+#'   - lints `call. = FALSE`
+#'   - forces `call. = FALSE` (lints `call. = TRUE` or missing `call.=` value)
+#'
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "stop('test')",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('test', call. = TRUE)",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('test', call. = FALSE)",
+#'   linters = condition_call_linter(display_call = TRUE)
+#' )
+#'
+#' lint(
+#'   text = "stop('this is a', 'test', call. = FALSE)",
+#'   linters = condition_call_linter(display_call = TRUE)
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "stop('test', call. = FALSE)",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('this is a', 'test', call. = FALSE)",
+#'   linters = condition_call_linter()
+#' )
+#'
+#' lint(
+#'   text = "stop('test', call. = TRUE)",
+#'   linters = condition_call_linter(display_call = TRUE)
+#' )
+#'
+#' @evalRd rd_tags("condition_call_linter")
+#' @seealso
+#'   - [linters] for a complete list of linters available in lintr.
+#'   - <https://design.tidyverse.org/err-call.html>>
+#' @export
+condition_call_linter <- function(display_call = FALSE) {
+  call_xpath <- glue::glue("
+    following-sibling::SYMBOL_SUB[text() = 'call.']
+    /following-sibling::expr[1]
+    /NUM_CONST[text() = '{!display_call}']
+  ")
+  no_call_xpath <- "
+    parent::expr[
+      count(SYMBOL_SUB[text() = 'call.']) = 0
+    ]
+  "
+
+  if (is.na(display_call)) {
+    frag <- no_call_xpath
+  } else if (display_call) {
+    frag <- call_xpath
+  } else {
+    # call. = TRUE can be expressed in two way:
+    #  - either explicitly with call. = TRUE
+    #  - or by implicitly relying on the default
+    frag <- xp_or(call_xpath, no_call_xpath)
+  }
+
+  xpath <- glue::glue("
+    //SYMBOL_FUNCTION_CALL[text() = 'stop' or text() = 'warning']
+    /parent::expr[{frag}]
+    /parent::expr
+  ")
+
+  Linter(linter_level = "expression", function(source_expression) {
+
+    xml <- source_expression$xml_parsed_content
+    if (is.null(xml)) return(list())
+
+    bad_expr <- xml_find_all(xml, xpath)
+
+    if (is.na(display_call)) {
+      msg <- glue::glue(
+        "Provide an explicit value for call. in {xp_call_name(bad_expr)}()."
+      )
+    } else if (display_call) {
+      msg <- glue::glue(
+        "Use {xp_call_name(bad_expr)}(.) to display call in error message."
+      )
+    } else {
+      msg <- glue::glue(
+        "Use {xp_call_name(bad_expr)}(., call. = FALSE)",
+        " to not display call in error message."
+      )
+    }
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = msg,
+      type = "warning"
+    )
+  })
+}

R/exclude.R

@@ -129,7 +129,7 @@ parse_exclusions <- function(file,
     if (length(starts) != length(ends)) {
       starts_msg <- line_info(starts, type = "start")
       ends_msg <- line_info(ends, type = "end")
-      stop(file, " has ", starts_msg, " but only ", ends_msg, " for exclusion from linting!")
+      stop(file, " has ", starts_msg, " but only ", ends_msg, " for exclusion from linting!", call. = FALSE)
     }
 
     for (i in seq_along(starts)) {
@@ -204,7 +204,8 @@ add_exclusions <- function(exclusions, lines, linters_string, exclude_linter_sep
         warning(
           "Could not find linter", if (length(bad) > 1L) "s" else "", " named ",
           glue_collapse(sQuote(bad), sep = ", ", last = " and "),
-          " in the list of active linters. Make sure the linter is uniquely identified by the given name or prefix."
+          " in the list of active linters. Make sure the linter is uniquely identified by the given name or prefix.",
+          call. = FALSE
         )
       }
       excluded_linters[matched] <- linter_names[idxs[matched]]

R/expect_lint.R

@@ -42,7 +42,8 @@
 expect_lint <- function(content, checks, ..., file = NULL, language = "en") {
   if (!requireNamespace("testthat", quietly = TRUE)) {
     stop( # nocov start
-      "'expect_lint' is designed to work within the 'testthat' testing framework, but 'testthat' is not installed."
+      "'expect_lint' is designed to work within the 'testthat' testing framework, but 'testthat' is not installed.",
+      call. = FALSE
     ) # nocov end
   }
   old_lang <- set_lang(language)
@@ -90,7 +91,7 @@ expect_lint <- function(content, checks, ..., file = NULL, language = "en") {
             stop(sprintf(
               "check #%d had an invalid field: \"%s\"\nValid fields are: %s\n",
               itr, field, toString(lint_fields)
-            ))
+            ), call. = FALSE)
           }
           check <- check[[field]]
           value <- lint[[field]]

R/extract.R

@@ -51,7 +51,7 @@ get_knitr_pattern <- function(filename, lines) {
     ("knitr" %:::% "detect_pattern")(lines, tolower(("knitr" %:::% "file_ext")(filename))),
     warning = function(cond) {
       if (!grepl("invalid UTF-8", conditionMessage(cond), fixed = TRUE)) {
-        warning(cond)
+        warning(cond, call. = FALSE)
       }
       invokeRestart("muffleWarning")
     }

R/lint.R

@@ -233,12 +233,15 @@ lint_package <- function(path = ".", ...,
                          parse_settings = TRUE,
                          show_progress = NULL) {
   if (length(path) > 1L) {
-    stop("Only linting one package at a time is supported.")
+    stop("Only linting one package at a time is supported.", call. = FALSE)
   }
   pkg_path <- find_package(path)
 
   if (is.null(pkg_path)) {
-    warning(sprintf("Didn't find any R package searching upwards from '%s'.", normalizePath(path)))
+    warning(
+      sprintf("Didn't find any R package searching upwards from '%s'.", normalizePath(path)),
+      call. = FALSE
+    )
     return(NULL)
   }
 
@@ -331,7 +334,7 @@ validate_linter_object <- function(linter, name) {
     stop(gettextf(
       "Expected '%s' to be a function of class 'linter', not a %s of class '%s'",
       name, typeof(linter), class(linter)[[1L]]
-    ))
+    ), call. = FALSE)
   }
   if (is_linter_factory(linter)) {
     what <- "Passing linters as variables"
@@ -394,17 +397,17 @@ Lint <- function(filename, line_number = 1L, column_number = 1L, # nolint: objec
   }
 
   if (length(line) != 1L || !is.character(line)) {
-    stop("`line` must be a string.")
+    stop("`line` must be a string.", call. = FALSE)
   }
   max_col <- max(nchar(line) + 1L, 1L, na.rm = TRUE)
   if (!is_number(column_number) || column_number < 0L || column_number > max_col) {
     stop(sprintf(
       "`column_number` must be an integer between 0 and nchar(line) + 1 (%d). It was %s.",
       max_col, column_number
-    ))
+    ), call. = FALSE)
   }
   if (!is_number(line_number) || line_number < 1L) {
-    stop(sprintf("`line_number` must be a positive integer. It was %s.", line_number))
+    stop(sprintf("`line_number` must be a positive integer. It was %s.", line_number), call. = FALSE)
   }
   check_ranges(ranges, max_col)
 
@@ -439,23 +442,23 @@ check_ranges <- function(ranges, max_col) {
     return()
   }
   if (!is.list(ranges)) {
-    stop("`ranges` must be NULL or a list.")
+    stop("`ranges` must be NULL or a list.", call. = FALSE)
   }
 
   for (range in ranges) {
     if (!is_number(range, 2L)) {
-      stop("`ranges` must only contain length 2 integer vectors without NAs.")
+      stop("`ranges` must only contain length 2 integer vectors without NAs.", call. = FALSE)
     } else if (!is_valid_range(range, max_col)) {
       stop(sprintf(
         "All entries in `ranges` must satisfy 0 <= range[1L] <= range[2L] <= nchar(line) + 1 (%d).", max_col
-      ))
+      ), call. = FALSE)
     }
   }
 }
 
 rstudio_source_markers <- function(lints) {
   if (!requireNamespace("rstudioapi", quietly = TRUE)) {
-    stop("'rstudioapi' is required for rstudio_source_markers().") # nocov
+    stop("'rstudioapi' is required for rstudio_source_markers().", call. = FALSE) # nocov
   }
 
   # package path will be NULL unless it is a relative path
@@ -548,7 +551,7 @@ checkstyle_output <- function(lints, filename = "lintr_results.xml") {
 #' @export
 sarif_output <- function(lints, filename = "lintr_results.sarif") {
   if (!requireNamespace("jsonlite", quietly = TRUE)) {
-    stop("'jsonlite' is required to produce SARIF reports, please install to continue.") # nocov
+    stop("'jsonlite' is required to produce SARIF reports, please install to continue.", call. = FALSE) # nocov
   }
 
   # package path will be `NULL` unless it is a relative path

R/linter_tag_docs.R

@@ -119,3 +119,13 @@ NULL
 #' @evalRd rd_linters("regex")
 #' @seealso [linters] for a complete list of linters available in lintr.
 NULL
+
+#' Tidyverse design linters
+#' @name tidy_design_linters
+#' @description
+#' Linters based on guidelines described in the 'Tidy design principles' book.
+#' @evalRd rd_linters("tidy_design")
+#' @seealso
+#'  - [linters] for a complete list of linters available in lintr.
+#'  - <https://design.tidyverse.org/>
+NULL