Merge remote-tracking branch 'origin/main' into consecutive_mutate

DESCRIPTION

@@ -139,6 +139,7 @@ Collate:
     'namespace.R'
     'namespace_linter.R'
     'nested_ifelse_linter.R'
+    'nested_pipe_linter.R'
     'nonportable_path_linter.R'
     'nrow_subset_linter.R'
     'numeric_leading_zero_linter.R'

NAMESPACE

@@ -100,6 +100,7 @@ export(missing_package_linter)
 export(modify_defaults)
 export(namespace_linter)
 export(nested_ifelse_linter)
+export(nested_pipe_linter)
 export(no_tab_linter)
 export(nonportable_path_linter)
 export(nrow_subset_linter)

NEWS.md

@@ -18,7 +18,9 @@
 ## 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).
+* `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).
 
 ### New linters
 
@@ -32,13 +34,16 @@
 * `list_comparison_linter()` for discouraging comparisons on the output of `lapply()`, e.g. `lapply(x, sum) > 10` (part of #884, @MichaelChirico).
 * `print_linter()` for discouraging usage of `print()` on string literals like `print("Reached here")` or `print(paste("Found", nrow(DF), "rows."))` (#1894, @MichaelChirico).
 * `consecutive_mutate_linter()` for encouraging consecutive calls to `dplyr::mutate()` to be combined (part of #884, @MichaelChirico).
+* `nested_pipe_linter()` for discouraging pipes within pipes, e.g. `df1 %>% inner_join(df2 %>% select(a, b))` (part of #884, @MichaelChirico).
 * `nrow_subset_linter()` for discouraging usage like `nrow(subset(x, conditions))` in favor of something like `with(x, sum(conditions))` which doesn't require a full subset of `x` (part of #884, @MichaelChirico).
 * `pipe_return_linter()` for discouraging usage of `return()` inside a {magrittr} pipeline (part of #884, @MichaelChirico).
 
 ### Lint accuracy fixes: removing false positives
 
 * `unreachable_code_linter()` ignores reachable code in inline functions like `function(x) if (x > 2) stop() else x` (#2259, @MEO265).
-* `unnecessary_lambda_linter()` ignores extractions with explicit returns like `lapply(l, function(x) foo(x)$bar)` (#2258, @MichaelChirico).
+* `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).
 
 # lintr 3.1.1
 

R/library_call_linter.R

@@ -5,6 +5,9 @@
 #'  - Enforce such calls to all be at the top of the script.
 #'  - Block usage of argument `character.only`, in particular
 #'    for loading packages in a loop.
+#'  - Block consecutive calls to `suppressMessages(library(.))`
+#'    in favor of using [suppressMessages()] only once to suppress
+#'    messages from all `library()` calls. Ditto [suppressPackageStartupMessages()].
 #'
 #' @param allow_preamble Logical, default `TRUE`. If `FALSE`,
 #'   no code is allowed to precede the first `library()` call,
@@ -36,6 +39,13 @@
 #'   linters = library_call_linter()
 #' )
 #'
+#' code <- "suppressMessages(library(dplyr))\nsuppressMessages(library(tidyr))"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = library_call_linter()
+#' )
+#'
 #' # okay
 #' code <- "library(dplyr)\nprint('test')"
 #' writeLines(code)
@@ -62,30 +72,40 @@
 #'   linters = library_call_linter()
 #' )
 #'
+#' code <- "suppressMessages({\n  library(dplyr)\n  library(tidyr)\n})"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = library_call_linter()
+#' )
+#'
 #' @evalRd rd_tags("library_call_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 library_call_linter <- function(allow_preamble = TRUE) {
-  attach_call <- "text() = 'library' or text() = 'require'"
-  unsuppressed_call <- glue("not( {attach_call} or starts-with(text(), 'suppress'))")
+  attach_calls <- c("library", "require")
+  attach_call_cond <- xp_text_in_table(attach_calls)
+  suppress_call_cond <- xp_text_in_table(c("suppressMessages", "suppressPackageStartupMessages"))
+
+  unsuppressed_call_cond <- glue("not( {xp_or(attach_call_cond, suppress_call_cond)} )")
   if (allow_preamble) {
-    unsuppressed_call <- xp_and(
-      unsuppressed_call,
-      glue("@line1 > //SYMBOL_FUNCTION_CALL[{ attach_call }][1]/@line1")
+    unsuppressed_call_cond <- xp_and(
+      unsuppressed_call_cond,
+      glue("@line1 > //SYMBOL_FUNCTION_CALL[{ attach_call_cond }][1]/@line1")
     )
   }
   upfront_call_xpath <- glue("
-    //SYMBOL_FUNCTION_CALL[{ attach_call }][last()]
+    //SYMBOL_FUNCTION_CALL[{ attach_call_cond }][last()]
       /preceding::expr
-      /SYMBOL_FUNCTION_CALL[{ unsuppressed_call }][last()]
-      /following::expr[SYMBOL_FUNCTION_CALL[{ attach_call }]]
+      /SYMBOL_FUNCTION_CALL[{ unsuppressed_call_cond }][last()]
+      /following::expr[SYMBOL_FUNCTION_CALL[{ attach_call_cond }]]
       /parent::expr
   ")
 
   # STR_CONST: block library|require("..."), i.e., supplying a string literal
   # ancestor::expr[FUNCTION]: Skip usages inside functions a la {knitr}
-  char_only_direct_xpath <- "
-  //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require']
+  char_only_direct_xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[{attach_call_cond}]
     /parent::expr
     /parent::expr[
       expr[2][STR_CONST]
@@ -94,13 +114,13 @@ library_call_linter <- function(allow_preamble = TRUE) {
         and not(ancestor::expr[FUNCTION])
       )
     ]
-  "
+  ")
 
   bad_indirect_funs <- c("do.call", "lapply", "sapply", "map", "walk")
-  call_symbol_cond <- "
-  SYMBOL[text() = 'library' or text() = 'require']
-    or STR_CONST[text() = '\"library\"' or text() = '\"require\"']
-  "
+  call_symbol_cond <- glue("
+    SYMBOL[{attach_call_cond}]
+    or STR_CONST[{ xp_text_in_table(dQuote(attach_calls, '\"')) }]
+  ")
   char_only_indirect_xpath <- glue("
   //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(bad_indirect_funs) }]
     /parent::expr
@@ -111,6 +131,23 @@ 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}]]]")
+
+  # 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].
+  #   That is, ensure that calls[i] only matches a following call to calls[i].
+  # match on the expr, not the SYMBOL_FUNCTION_CALL, to ensure
+  #   namespace-qualified calls only match if the namespaces do.
+  consecutive_suppress_xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[{ suppress_call_cond }]
+    /parent::expr
+    /parent::expr[
+      expr[SYMBOL_FUNCTION_CALL[{ suppress_call_cond }]] =
+        following-sibling::expr[1][{attach_expr_cond}]/expr
+      and {attach_expr_cond}
+    ]
+  ")
+
   Linter(function(source_expression) {
     if (!is_lint_level(source_expression, "file")) {
       return(list())
@@ -120,12 +157,12 @@ library_call_linter <- function(allow_preamble = TRUE) {
 
     upfront_call_expr <- xml_find_all(xml, upfront_call_xpath)
 
-    call_name <- xp_call_name(upfront_call_expr)
+    upfront_call_name <- xp_call_name(upfront_call_expr)
 
     upfront_call_lints <- xml_nodes_to_lints(
       upfront_call_expr,
       source_expression = source_expression,
-      lint_message = sprintf("Move all %s calls to the top of the script.", call_name),
+      lint_message = sprintf("Move all %s calls to the top of the script.", upfront_call_name),
       type = "warning"
     )
 
@@ -161,6 +198,20 @@ library_call_linter <- function(allow_preamble = TRUE) {
       type = "warning"
     )
 
-    c(upfront_call_lints, char_only_direct_lints, char_only_indirect_lints)
+    consecutive_suppress_expr <- xml_find_all(xml, consecutive_suppress_xpath)
+    consecutive_suppress_call_text <- xp_call_name(consecutive_suppress_expr)
+    consecutive_suppress_message <- glue(
+      "Unify consecutive calls to {consecutive_suppress_call_text}(). ",
+      "You can do so by writing all of the calls in one braced expression ",
+      "like {consecutive_suppress_call_text}({{...}})."
+    )
+    consecutive_suppress_lints <- xml_nodes_to_lints(
+      consecutive_suppress_expr,
+      source_expression = source_expression,
+      lint_message = consecutive_suppress_message,
+      type = "warning"
+    )
+
+    c(upfront_call_lints, char_only_direct_lints, char_only_indirect_lints, consecutive_suppress_lints)
   })
 }

R/nested_pipe_linter.R

@@ -0,0 +1,86 @@
+#' Block usage of pipes nested inside other calls
+#'
+#' Nesting pipes harms readability; extract sub-steps to separate variables,
+#'   append further pipeline steps, or otherwise refactor such usage away.
+#'
+#' @param allow_inline Logical, default `TRUE`, in which case only "inner"
+#'   pipelines which span more than one line are linted. If `FALSE`, even
+#'   "inner" pipelines that fit in one line are linted.
+#' @param allow_outer_calls Character vector dictating which "outer"
+#'   calls to exempt from the requirement to unnest (see examples). Defaults
+#'   to [try()], [tryCatch()], and [withCallingHandlers()].
+#'
+#' @examples
+#' # will produce lints
+#' code <- "df1 %>%\n  inner_join(df2 %>%\n    select(a, b)\n  )"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = nested_pipe_linter()
+#' )
+#'
+#' lint(
+#'   text = "df1 %>% inner_join(df2 %>% select(a, b))",
+#'   linters = nested_pipe_linter(allow_inline = FALSE)
+#' )
+#'
+#' lint(
+#'   text = "tryCatch(x %>% filter(grp == 'a'), error = identity)",
+#'   linters = nested_pipe_linter(allow_outer_calls = character())
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "df1 %>% inner_join(df2 %>% select(a, b))",
+#'   linters = nested_pipe_linter()
+#' )
+#'
+#' code <- "df1 %>%\n  inner_join(df2 %>%\n    select(a, b)\n  )"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = nested_pipe_linter(allow_outer_calls = "inner_join")
+#' )
+#'
+#' lint(
+#'   text = "tryCatch(x %>% filter(grp == 'a'), error = identity)",
+#'   linters = nested_pipe_linter()
+#' )
+#'
+#' @evalRd rd_tags("nested_pipe_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+nested_pipe_linter <- function(
+    allow_inline = TRUE,
+    allow_outer_calls = c("try", "tryCatch", "withCallingHandlers")) {
+  multiline_and <- if (allow_inline) "@line1 != @line2 and" else ""
+  xpath <- glue("
+  (//PIPE | //SPECIAL[{ xp_text_in_table(magrittr_pipes) }])
+    /parent::expr[{multiline_and} preceding-sibling::expr/SYMBOL_FUNCTION_CALL[
+      not({ xp_text_in_table(allow_outer_calls) })
+      and (
+        text() != 'switch'
+        or parent::expr
+          /following-sibling::expr[1]
+          /*[self::PIPE or self::SPECIAL[{ xp_text_in_table(magrittr_pipes) }]]
+      )
+    ]]
+  ")
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    bad_expr <- xml_find_all(xml, xpath)
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = "Don't nest pipes inside other calls.",
+      type = "warning"
+    )
+  })
+}

R/unnecessary_lambda_linter.R

@@ -75,7 +75,10 @@ unnecessary_lambda_linter <- function() {
           position() = 2
           and preceding-sibling::expr/SYMBOL_FUNCTION_CALL
           and not(preceding-sibling::*[1][self::EQ_SUB])
-          and not(parent::expr/following-sibling::*[not(self::OP-RIGHT-PAREN or self::OP-RIGHT-BRACE)])
+          and not(parent::expr[
+            preceding-sibling::expr[not(SYMBOL_FUNCTION_CALL)]
+            or following-sibling::*[not(self::OP-RIGHT-PAREN or self::OP-RIGHT-BRACE)]
+          ])
         ]/SYMBOL
     ]
     /parent::expr

inst/lintr/linters.csv

@@ -57,6 +57,7 @@ missing_argument_linter,correctness common_mistakes configurable
 missing_package_linter,robustness common_mistakes
 namespace_linter,correctness robustness configurable executing
 nested_ifelse_linter,efficiency readability
+nested_pipe_linter,readability consistency configurable
 no_tab_linter,style consistency deprecated
 nonportable_path_linter,robustness best_practices configurable
 nrow_subset_linter,efficiency consistency best_practices