Merge branch 'main' into autodoc-undesirable

DESCRIPTION

@@ -39,12 +39,11 @@ Suggests:
     cli,
     httr (>= 1.2.1),
     jsonlite,
-    mockery,
     patrick,
     rlang,
     rmarkdown,
     rstudioapi (>= 0.2),
-    testthat (>= 3.1.5),
+    testthat (>= 3.2.1),
     tibble,
     tufte,
     withr (>= 2.5.0)

NEWS.md

@@ -19,18 +19,23 @@
 
 ## Changes to default linters
 
-* New default linter `return_linter()` for the style guide rule that terminal returns should be left implicit (#1100, @MEO265).
+* New default linter `return_linter()` for the style guide rule that terminal returns should be left implicit (#1100, #2354, and #2356, @MEO265 and @MichaelChirico).
 
 ## New and improved features
 
 * More helpful errors for invalid configs (#2253, @MichaelChirico).
 * `library_call_linter()` is extended
   + to encourage all packages to be attached with `library(symbol)`, not `library("symbol", character.only = TRUE)` or "vectorized" approaches looping over package names (part of #884, @MichaelChirico).
   + to discourage many consecutive calls to `suppressMessages()` or `suppressPackageStartupMessages()` (part of #884, @MichaelChirico).
-* `return_linter()` also has an argument `return_style` (`"implicit"` by default) which checks that all functions confirm to the specified return style of `"implicit"` or `"explicit"` (part of #884, @MichaelChirico, @AshesITR and @MEO265).
+* `return_linter()` also has arguments for fine-tuning which functions get linted:
+  + `return_style` (`"implicit"` by default) which checks that all functions confirm to the specified return style of `"implicit"` or `"explicit"` (#2271 and part of #884, @MichaelChirico, @AshesITR and @MEO265).
+  + `allow_implicit_else` (default `TRUE`) which, when `FALSE`, checks that all terminal `if` statements are paired with a corresponding `else` statement (part of #884, @MichaelChirico).
+  + `return_functions` to customize which functions are equivalent to `return()` as "exit" clauses, e.g. `rlang::abort()` can be considered in addition to the default functions like `stop()` and `q()` from base (#2271 and part of #884, @MichaelChirico and @MEO265).
+  + `except` to customize which functions are ignored entirely (i.e., whether they have a return of the specified style is not checked; #2271 and part of #884, @MichaelChirico and @MEO265). Namespace hooks like `.onAttach()` and `.onLoad()` are always ignored.
 * `unnecessary_lambda_linter` is extended to encourage vectorized comparisons where possible, e.g. `sapply(x, sum) > 0` instead of `sapply(x, function(x) sum(x) > 0)` (part of #884, @MichaelChirico). Toggle this behavior with argument `allow_comparison`.
 * `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).
 

R/library_call_linter.R

@@ -117,10 +117,7 @@ library_call_linter <- function(allow_preamble = TRUE) {
   ")
 
   bad_indirect_funs <- c("do.call", "lapply", "sapply", "map", "walk")
-  call_symbol_cond <- glue("
-    SYMBOL[{attach_call_cond}]
-    or STR_CONST[{ xp_text_in_table(dQuote(attach_calls, '\"')) }]
-  ")
+  call_symbol_cond <- glue("SYMBOL[{attach_call_cond}] or STR_CONST")
   char_only_indirect_xpath <- glue("
   //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(bad_indirect_funs) }]
     /parent::expr
@@ -131,7 +128,7 @@ library_call_linter <- function(allow_preamble = TRUE) {
   ")
   call_symbol_path <- glue("./expr[{call_symbol_cond}]")
 
-  attach_expr_cond <- glue("expr[expr[SYMBOL_FUNCTION_CALL[{attach_call_cond}]]]")
+  attach_expr_cond <- glue("expr[expr/SYMBOL_FUNCTION_CALL[{attach_call_cond}]]")
 
   # Use `calls` in the first condition, not in the second, to prevent, e.g.,
   #   the first call matching calls[1] but the second matching calls[2].
@@ -182,7 +179,22 @@ library_call_linter <- function(allow_preamble = TRUE) {
     )
 
     char_only_indirect_expr <- xml_find_all(xml, char_only_indirect_xpath)
-    char_only_indirect_lib_calls <- get_r_string(char_only_indirect_expr, call_symbol_path)
+    char_only_indirect_lib_calls <- vapply(
+      char_only_indirect_expr,
+      function(expr) {
+        calls <- get_r_string(xml_find_all(expr, call_symbol_path))
+        calls <- calls[calls %in% attach_calls]
+        if (length(calls) == 1L) calls else NA_character_
+      },
+      character(1L)
+    )
+
+    # For STR_CONST entries, the XPath doesn't check the string value -- we use
+    #   get_r_string() here to do that filter more robustly.
+    is_attach_call <- !is.na(char_only_indirect_lib_calls)
+    char_only_indirect_expr <- char_only_indirect_expr[is_attach_call]
+    char_only_indirect_lib_calls <- char_only_indirect_lib_calls[is_attach_call]
+
     char_only_indirect_loop_calls <- xp_call_name(char_only_indirect_expr)
     char_only_indirect_msg <- sprintf(
       "Call %s() directly, not vectorized with %s().",

R/lintr-package.R

@@ -24,3 +24,8 @@
 #' }
 ## lintr namespace: end
 NULL
+
+# make binding available for mock testing
+# ref: https://testthat.r-lib.org/dev/reference/local_mocked_bindings.html#base-functions
+unlink <- NULL
+quit <- NULL

R/return_linter.R

@@ -6,6 +6,9 @@
 #'   the default, enforeces the Tidyverse guide recommendation to leave terminal
 #'   returns implicit. `"explicit"` style requires that `return()` always be
 #'   explicitly supplied.
+#' @param allow_implicit_else Logical, default `TRUE`. If `FALSE`, functions with a terminal
+#'   `if` clause must always have an `else` clause, making the `NULL` alternative explicit
+#'   if necessary.
 #' @param return_functions Character vector of functions that are accepted as terminal calls
 #'   when `return_style = "explicit"`. These are in addition to exit functions
 #'   from base that are always allowed: [stop()], [q()], [quit()], [invokeRestart()],
@@ -32,6 +35,13 @@
 #'   linters = return_linter(return_style = "explicit")
 #' )
 #'
+#' code <- "function(x) {\n  if (x > 0) 2\n}"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = return_linter(allow_implicit_else = FALSE)
+#' )
+#'
 #' # okay
 #' code <- "function(x) {\n  x + 1\n}"
 #' writeLines(code)
@@ -47,6 +57,12 @@
 #'   linters = return_linter(return_style = "explicit")
 #' )
 #'
+#' code <- "function(x) {\n  if (x > 0) 2 else NULL\n}"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = return_linter(allow_implicit_else = FALSE)
+#' )
 #'
 #' @evalRd rd_tags("return_linter")
 #' @seealso
@@ -55,13 +71,19 @@
 #' @export
 return_linter <- function(
     return_style = c("implicit", "explicit"),
+    allow_implicit_else = TRUE,
     return_functions = NULL,
     except = NULL) {
   return_style <- match.arg(return_style)
 
+  if (!allow_implicit_else || return_style == "explicit") {
+    except_xpath <- glue("parent::expr[not(
+      preceding-sibling::expr/SYMBOL[{ xp_text_in_table(union(special_funs, except)) }]
+    )]")
+  }
+
   if (return_style == "implicit") {
     body_xpath <- "(//FUNCTION | //OP-LAMBDA)/following-sibling::expr[1]"
-    # nolint next: object_usage. False positive from {codetools} says 'params' isn't used.
     params <- list(
       implicit = TRUE,
       type = "style",
@@ -89,9 +111,7 @@ return_linter <- function(
     return_functions <- union(base_return_functions, return_functions)
 
     body_xpath <- glue("
-    (//FUNCTION | //OP-LAMBDA)[parent::expr[not(
-      preceding-sibling::expr[SYMBOL[{ xp_text_in_table(except) }]]
-    )]]
+    (//FUNCTION | //OP-LAMBDA)[{ except_xpath }]
       /following-sibling::expr[OP-LEFT-BRACE and expr[last()]/@line1 != @line1]
       /expr[last()]
     ")
@@ -106,15 +126,31 @@ return_linter <- function(
     )
   }
 
+  params$allow_implicit_else <- allow_implicit_else
+
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
     if (is.null(xml)) return(list())
 
     body_expr <- xml_find_all(xml, body_xpath)
 
     params$source_expression <- source_expression
+
+    if (params$implicit && !params$allow_implicit_else) {
+      # can't incorporate this into the body_xpath for implicit return style,
+      #   since we still lint explicit returns for except= functions.
+      allow_implicit_else <- is.na(xml_find_first(body_expr, except_xpath))
+    } else {
+      allow_implicit_else <- rep(params$allow_implicit_else, length(body_expr))
+    }
     # nested_return_lints not "vectorized" due to xml_children()
-    lapply(body_expr, nested_return_lints, params)
+    Map(
+      function(expr, allow_implicit_else) {
+        params$allow_implicit_else <- allow_implicit_else
+        nested_return_lints(expr, params)
+      },
+      body_expr, allow_implicit_else
+    )
   })
 }
 
@@ -142,7 +178,17 @@ nested_return_lints <- function(expr, params) {
     nested_return_lints(child_expr[[tail(expr_idx, 1L)]], params)
   } else if (child_node[1L] == "IF") {
     expr_idx <- which(child_node %in% c("expr", "equal_assign", "expr_or_assign_or_help"))
-    lapply(child_expr[expr_idx[-1L]], nested_return_lints, params)
+    return_lints <- lapply(child_expr[expr_idx[-1L]], nested_return_lints, params)
+    if (params$allow_implicit_else || length(expr_idx) == 3L) {
+      return(return_lints)
+    }
+    implicit_else_lints <- list(xml_nodes_to_lints(
+      expr,
+      source_expression = params$source_expression,
+      lint_message = "All functions with terminal if statements must have a corresponding terminal else clause",
+      type = "warning"
+    ))
+    c(return_lints, implicit_else_lints)
   } else {
     xml_nodes_to_lints(
       xml_find_first(child_expr[[1L]], params$lint_xpath),

R/string_boundary_linter.R

@@ -66,6 +66,11 @@ string_boundary_linter <- function(allow_grepl = FALSE) {
     /following-sibling::expr[2]
     /STR_CONST[ {str_cond} ]
   ")
+  str_detect_message_map <- c(
+    both = "Use == to check for an exact string match.",
+    initial = "Use startsWith() to detect a fixed initial substring.",
+    terminal = "Use endsWith() to detect a fixed terminal substring."
+  )
 
   if (!allow_grepl) {
     grepl_xpath <- glue("
@@ -84,16 +89,34 @@ string_boundary_linter <- function(allow_grepl = FALSE) {
       /expr[2]
       /STR_CONST[ {str_cond} ]
     ")
+    grepl_lint_fmt <- paste(
+      "Use !is.na(x) & %1$s(x, string) to detect a fixed %2$s substring, or,",
+      "if missingness is not a concern, just %1$s()."
+    )
+    grepl_message_map <- c(
+      both = "Use == to check for an exact string match.",
+      initial = sprintf(grepl_lint_fmt, "startsWith", "initial"),
+      terminal = sprintf(grepl_lint_fmt, "endsWith", "terminal")
+    )
   }
 
   get_regex_lint_data <- function(xml, xpath) {
     expr <- xml_find_all(xml, xpath)
     patterns <- get_r_string(expr)
     initial_anchor <- startsWith(patterns, "^")
+    terminal_anchor <- endsWith(patterns, "$")
     search_start <- 1L + initial_anchor
-    search_end <- nchar(patterns) - 1L + initial_anchor
+    search_end <- nchar(patterns) - terminal_anchor
     can_replace <- is_not_regex(substr(patterns, search_start, search_end))
-    list(lint_expr = expr[can_replace], initial_anchor = initial_anchor[can_replace])
+    initial_anchor <- initial_anchor[can_replace]
+    terminal_anchor <- terminal_anchor[can_replace]
+
+    lint_type <- character(length(initial_anchor))
+
+    lint_type[initial_anchor & terminal_anchor] <- "both"
+    lint_type[initial_anchor & !terminal_anchor] <- "initial"
+    lint_type[!initial_anchor & terminal_anchor] <- "terminal"
+    list(lint_expr = expr[can_replace], lint_type = lint_type)
   }
 
   substr_xpath_parts <- glue("
@@ -125,38 +148,23 @@ string_boundary_linter <- function(allow_grepl = FALSE) {
     lints <- list()
 
     str_detect_lint_data <- get_regex_lint_data(xml, str_detect_xpath)
-    str_detect_lint_message <- paste(
-      ifelse(
-        str_detect_lint_data$initial_anchor,
-        "Use startsWith() to detect a fixed initial substring.",
-        "Use endsWith() to detect a fixed terminal substring."
-      ),
-      "Doing so is more readable and more efficient."
-    )
+    str_detect_lint_message <- str_detect_message_map[str_detect_lint_data$lint_type]
 
     lints <- c(lints, xml_nodes_to_lints(
       str_detect_lint_data$lint_expr,
       source_expression = source_expression,
-      lint_message = str_detect_lint_message,
+      lint_message =  paste(str_detect_lint_message, "Doing so is more readable and more efficient."),
       type = "warning"
     ))
 
     if (!allow_grepl) {
       grepl_lint_data <- get_regex_lint_data(xml, grepl_xpath)
-      grepl_replacement <- ifelse(grepl_lint_data$initial_anchor, "startsWith", "endsWith")
-      grepl_type <- ifelse(grepl_lint_data$initial_anchor, "initial", "terminal")
-      grepl_lint_message <- paste(
-        sprintf(
-          "Use !is.na(x) & %s(x, string) to detect a fixed %s substring, or, if missingness is not a concern, just %s.",
-          grepl_replacement, grepl_type, grepl_replacement
-        ),
-        "Doing so is more readable and more efficient."
-      )
+      grepl_lint_message <- grepl_message_map[grepl_lint_data$lint_type]
 
       lints <- c(lints, xml_nodes_to_lints(
         grepl_lint_data$lint_expr,
         source_expression = source_expression,
-        lint_message = grepl_lint_message,
+        lint_message =  paste(grepl_lint_message, "Doing so is more readable and more efficient."),
         type = "warning"
       ))
     }

R/unreachable_code_linter.R

@@ -105,9 +105,8 @@ unreachable_code_linter <- function(allow_comment_regex = getOption("covr.exclud
   ")
 
   xpath_if_while <- "
-  (//WHILE | //IF)
-    /following-sibling::expr[1][NUM_CONST[text() = 'FALSE']]
-    /following-sibling::expr[1]
+    (//WHILE | //IF)[following-sibling::expr[1]/NUM_CONST[text() = 'FALSE']]
+      /parent::expr
   "
 
   xpath_else <- "