Extend unnecessary_lambda_linter to look for "inner comparisons"

NEWS.md

@@ -19,6 +19,7 @@
 
 * 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).
+* `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`.
 
 ### New linters
 

R/unnecessary_lambda_linter.R

@@ -8,13 +8,27 @@
 #'   the anonymous function _can_ be avoided, doing so is not always more
 #'   readable.
 #'
+#' @param allow_comparison Logical, default `FALSE`. If `TRUE`, lambdas like
+#'   `function(x) foo(x) == 2`, where `foo` can be extracted to the "mapping"
+#'   function and `==` vectorized instead of called repeatedly, are linted.
+#'
 #' @examples
 #' # will produce lints
 #' lint(
 #'   text = "lapply(list(1:3, 2:4), function(xi) sum(xi))",
 #'   linters = unnecessary_lambda_linter()
 #' )
 #'
+#' lint(
+#'   text = "sapply(x, function(xi) xi == 2)",
+#'   linters = unnecessary_lambda_linter()
+#' )
+#'
+#' lint(
+#'   text = "sapply(x, function(xi) sum(xi) > 0)",
+#'   linters = unnecessary_lambda_linter()
+#' )
+#'
 #' # okay
 #' lint(
 #'   text = "lapply(list(1:3, 2:4), sum)",
@@ -31,10 +45,30 @@
 #'   linters = unnecessary_lambda_linter()
 #' )
 #'
+#' lint(
+#'   text = "sapply(x, function(xi) xi == 2)",
+#'   linters = unnecessary_lambda_linter(allow_comparison = TRUE)
+#' )
+#'
+#' lint(
+#'   text = "sapply(x, function(xi) sum(xi) > 0)",
+#'   linters = unnecessary_lambda_linter(allow_comparison = TRUE)
+#' )
+#'
+#' lint(
+#'   text = "sapply(x, function(xi) sum(abs(xi)) > 10)",
+#'   linters = unnecessary_lambda_linter()
+#' )
+#'
+#' lint(
+#'   text = "sapply(x, sum) > 0",
+#'   linters = unnecessary_lambda_linter()
+#' )
+#'
 #' @evalRd rd_tags("unnecessary_lambda_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-unnecessary_lambda_linter <- function() {
+unnecessary_lambda_linter <- function(allow_comparison = FALSE) {
   # include any base function like those where FUN is an argument
   #   and ... follows positionally directly afterwards (with ...
   #   being passed on to FUN). That excludes functions like
@@ -55,6 +89,27 @@ unnecessary_lambda_linter <- function() {
     purrr_mappers
   ))
 
+  # OP-PLUS: condition for complex literal, e.g. 0+2i.
+  # NB: this includes 0+3 and TRUE+FALSE, which are also fine.
+  inner_comparison_xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[text() = 'sapply' or text() = 'vapply']
+    /parent::expr
+    /parent::expr
+    /expr[FUNCTION]
+    /expr[
+      ({ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) })
+      and expr[
+        expr/SYMBOL_FUNCTION_CALL
+        and expr/SYMBOL
+      ]
+      and expr[
+        NUM_CONST
+        or STR_CONST
+        or (OP-PLUS and count(expr/NUM_CONST) = 2)
+      ]
+    ]
+  ")
+
   # outline:
   #   1. match one of the identified mappers
   #   2. match an anonymous function that can be "symbol-ized"
@@ -131,6 +186,27 @@ unnecessary_lambda_linter <- function() {
       type = "warning"
     )
 
+    inner_comparison_lints <- NULL
+    if (!allow_comparison) {
+      inner_comparison_expr <- xml_find_all(xml, inner_comparison_xpath)
+
+      mapper <- xp_call_name(xml_find_first(inner_comparison_expr, "parent::expr/parent::expr"))
+      if (length(mapper) > 0L) fun_value <- if (mapper == "sapply") "" else ", FUN.VALUE = <intermediate>"
+
+      inner_comparison_lints <- xml_nodes_to_lints(
+        inner_comparison_expr,
+        source_expression = source_expression,
+        lint_message = sprintf(
+          paste(
+            "Compare to a constant after calling %1$s() to get the full benefits of vectorization.",
+            "Prefer %1$s(x, foo%2$s) == 2 over %1$s(x, function(xi) foo(xi) == 2, logical(1L))."
+          ),
+          mapper, fun_value
+        ),
+        type = "warning"
+      )
+    }
+
     purrr_fun_expr <- xml_find_all(xml, purrr_fun_xpath)
 
     purrr_call_fun <- xml_text(xml_find_first(purrr_fun_expr, fun_xpath))
@@ -146,6 +222,6 @@ unnecessary_lambda_linter <- function() {
       type = "warning"
     )
 
-    c(default_fun_lints, purrr_fun_lints)
+    c(default_fun_lints, inner_comparison_lints, purrr_fun_lints)
   })
 }

inst/lintr/linters.csv

@@ -107,7 +107,7 @@ trailing_whitespace_linter,style default configurable
 undesirable_function_linter,style efficiency configurable robustness best_practices
 undesirable_operator_linter,style efficiency configurable robustness best_practices
 unnecessary_concatenation_linter,style readability efficiency configurable
-unnecessary_lambda_linter,best_practices efficiency readability
+unnecessary_lambda_linter,best_practices efficiency readability configurable
 unnecessary_nested_if_linter,readability best_practices
 unnecessary_placeholder_linter,readability best_practices
 unneeded_concatenation_linter,style readability efficiency configurable deprecated

tests/testthat/test-unnecessary_lambda_linter.R

@@ -77,6 +77,20 @@ test_that("unnecessary_lambda_linter skips allowed usages", {
   expect_lint("lapply(l, function(x = 1) 'a' %in% names(x))", NULL, linter)
 })
 
+test_that("unnecessary_lambda_linter skips allowed inner comparisons", {
+  linter <- unnecessary_lambda_linter()
+
+  # lapply returns a list, so not the same, though as.list is probably
+  #   a better choice
+  expect_lint("lapply(x, function(xi) foo(xi) == 2)", NULL, linter)
+
+  # this _may_ return a matrix, though outer is probably a better choice if so
+  expect_lint("sapply(x, function(xi) foo(xi) == y)", NULL, linter)
+
+  # only lint "plain" calls that can be replaced by eliminating the lambda
+  expect_lint("sapply(x, function(xi) sum(abs(xi)) == 0)", NULL, linter)
+})
+
 test_that("unnecessary_lambda_linter blocks simple disallowed usage", {
   linter <- unnecessary_lambda_linter()
 
@@ -109,6 +123,42 @@ test_that("unnecessary_lambda_linter blocks simple disallowed usage", {
   )
 })
 
+test_that("unnecessary_lambda_linter blocks simple disallowed usages", {
+  linter <- unnecessary_lambda_linter()
+  linter_allow <- unnecessary_lambda_linter(allow_comparison = TRUE)
+  lint_msg <- rex::rex("Compare to a constant after calling sapply() to get", anything, "sapply(x, foo)")
+
+  expect_lint("sapply(x, function(xi) foo(xi) == 2)", lint_msg, linter)
+  expect_lint("sapply(x, function(xi) foo(xi) == 'a')", lint_msg, linter)
+  expect_lint("sapply(x, function(xi) foo(xi) == 1 + 2i)", lint_msg, linter)
+
+  expect_lint("sapply(x, function(xi) foo(xi) == 2)", NULL, linter_allow)
+  expect_lint("sapply(x, function(xi) foo(xi) == 'a')", NULL, linter_allow)
+  expect_lint("sapply(x, function(xi) foo(xi) == 1 + 2i)", NULL, linter_allow)
+
+  # vapply counts as well
+  # NB: we ignore the FUN.VALUE argument, for now
+  expect_lint(
+    "vapply(x, function(xi) foo(xi) == 2, logical(1L))",
+    rex::rex("Compare to a constant after calling vapply()", anything, "vapply(x, foo, FUN.VALUE = <intermediate>)"),
+    linter
+  )
+})
+
+test_that("unnecessary_lambda_linter blocks other comparators as well", {
+  linter <- unnecessary_lambda_linter()
+  linter_allow <- unnecessary_lambda_linter(allow_comparison = TRUE)
+  lint_msg <- rex::rex("Compare to a constant after calling sapply() to get")
+
+  expect_lint("sapply(x, function(xi) foo(xi) >= 2)", lint_msg, linter)
+  expect_lint("sapply(x, function(xi) foo(xi) != 'a')", lint_msg, linter)
+  expect_lint("sapply(x, function(xi) foo(xi) < 1 + 2i)", lint_msg, linter)
+
+  expect_lint("sapply(x, function(xi) foo(xi) >= 2)", NULL, linter_allow)
+  expect_lint("sapply(x, function(xi) foo(xi) != 'a')", NULL, linter_allow)
+  expect_lint("sapply(x, function(xi) foo(xi) < 1 + 2i)", NULL, linter_allow)
+})
+
 test_that("unnecessary_lambda_linter doesn't apply to keyword args", {
   expect_lint("lapply(x, function(xi) data.frame(nm = xi))", NULL, unnecessary_lambda_linter())
   expect_lint("lapply(x, function(xi) return(data.frame(nm = xi)))", NULL, unnecessary_lambda_linter())