New nested_pipe_linter

DESCRIPTION

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

NAMESPACE

@@ -99,6 +99,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(numeric_leading_zero_linter)

NEWS.md

@@ -30,6 +30,7 @@
 * `which_grepl_linter()` for discouraging `which(grepl(ptn, x))` in favor of directly using `grep(ptn, x)` (part of #884, @MichaelChirico).
 * `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).
+* `nested_pipe_linter()` for discouraging pipes within pipes, e.g. `df1 %>% inner_join(df2 %>% select(a, b))` (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

R/nested_pipe_linter.R

@@ -0,0 +1,73 @@
+#' 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.
+#'
+#' When [try()] or [tryCatch()] are the "outer" call, no lint is thrown,
+#'   since the "unnested" version of such usage may not work as intended
+#'   due to how evaluation happens in such cases.
+#'
+#' @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.
+#'
+#' @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)
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "df1 %>% inner_join(df2 %>% select(a, b))",
+#'   linters = nested_pipe_linter()
+#' )
+#'
+#' 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) {
+  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(text() = 'try' or text() = 'tryCatch')
+      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"
+    )
+  })
+}

inst/lintr/linters.csv

@@ -56,6 +56,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
 numeric_leading_zero_linter,style consistency readability

tests/testthat/test-nested_pipe_linter.R

@@ -0,0 +1,156 @@
+test_that("nested_pipe_linter skips allowed usages", {
+  linter <- nested_pipe_linter()
+
+  expect_lint("a %>% b() %>% c()", NULL, linter)
+
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        out <- a %>% b()
+        return(out)
+      }
+    "),
+    NULL,
+    linter
+  )
+
+  # pipes fitting on one line can be ignored
+  expect_lint(
+    "bind_rows(a %>% select(b), c %>% select(b))",
+    NULL,
+    linter
+  )
+
+  # switch outputs are OK
+  expect_lint("switch(x, a = x %>% foo())", NULL, linter)
+  # final position is an output position
+  expect_lint("switch(x, a = x, x %>% foo())", NULL, linter)
+
+  # inline switch inputs are not linted
+  expect_lint(
+    trim_some("
+      switch(
+        x %>% foo(),
+        a = x
+      )
+    "),
+    NULL,
+    linter
+  )
+
+  # try/tryCatch must be evaluated inside the call
+  expect_lint("try(x %>% foo())", NULL, linter)
+  expect_lint("tryCatch(x %>% foo(), error = identity)", NULL, linter)
+})
+
+test_that("nested_pipe_linter blocks simple disallowed usages", {
+  linter <- nested_pipe_linter()
+  linter_inline <- nested_pipe_linter(allow_inline = FALSE)
+  lint_msg <- rex::rex("Don't nest pipes inside other calls.")
+
+  expect_lint(
+    "bind_rows(a %>% select(b), c %>% select(b))",
+    list(lint_msg, lint_msg),
+    linter_inline
+  )
+
+  expect_lint(
+    trim_some("
+      print(
+        a %>%
+          filter(b > c)
+      )
+    "),
+    lint_msg,
+    linter
+  )
+
+  # switch inputs are linted
+  expect_lint(
+    trim_some("
+      switch(
+        x %>%
+          foo(),
+        a = x
+      )
+    "),
+    lint_msg,
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+      switch(
+        x %>% foo(),
+        a = x
+      )
+    "),
+    lint_msg,
+    linter_inline
+  )
+})
+
+test_that("Native pipes are handled as well", {
+  skip_if_not_r_version("4.1.0")
+
+  linter <- nested_pipe_linter()
+  linter_inline <- nested_pipe_linter(allow_inline = FALSE)
+  lint_msg <- rex::rex("Don't nest pipes inside other calls.")
+
+  expect_lint(
+    "bind_rows(a |> select(b), c |> select(b))",
+    NULL,
+    linter
+  )
+  expect_lint(
+    "bind_rows(a |> select(b), c |> select(b))",
+    list(lint_msg, lint_msg),
+    linter_inline
+  )
+
+  expect_lint(
+    trim_some("
+      print(
+        a |>
+          filter(b > c)
+      )
+    "),
+    lint_msg,
+    linter
+  )
+})
+
+test_that("lints vectorize", {
+  lint_msg <- rex::rex("Don't nest pipes inside other calls.")
+
+  lines <- trim_some("{
+    bind_rows(
+      a %>% select(b),
+      c %>%
+        select(d),
+      e %>%
+        select(f) %>%
+        filter(g > 0),
+      h %>% filter(i < 0)
+    )
+  }")
+  expect_lint(
+    lines,
+    list(
+      list(lint_msg, line_number = 4L),
+      list(lint_msg, line_number = 6L)
+    ),
+    nested_pipe_linter()
+  )
+
+  expect_lint(
+    lines,
+    list(
+      list(lint_msg, line_number = 3L),
+      list(lint_msg, line_number = 4L),
+      list(lint_msg, line_number = 6L),
+      list(lint_msg, line_number = 9L)
+    ),
+    nested_pipe_linter(allow_inline = FALSE)
+  )
+})