Extend boolean_arithmetic_linter() to other known-logical sum(<lgl>) cases

NEWS.md

@@ -29,6 +29,7 @@
 * `get_source_expression()` captures warnings emitted by the R parser (currently always for mis-specified literal integers like `1.1L`) and `lint()` returns them as lints (#2065, @MichaelChirico).
 * `object_name_linter()` and `object_length_linter()` apply to objects assigned with `assign()` or generics created with `setGeneric()` (#1665, @MichaelChirico).
 * `object_usage_linter()` gains argument `interpret_extensions` to govern which false positive-prone common syntaxes should be checked for used objects (#1472, @MichaelChirico). Currently `"glue"` (renamed from earlier argument `interpret_glue`) and `"rlang"` are supported. The latter newly covers usage of the `.env` pronoun like `.env$key`, where `key` was previously missed as being a used variable.
+* `boolean_arithmetic_linter()` finds many more cases like `sum(x | y) == 0` where the total of a known-logical vector is compared to 0 (#1580, @MichaelChirico).
 
 ### New linters
 

R/boolean_arithmetic_linter.R

@@ -30,22 +30,28 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 boolean_arithmetic_linter <- function() {
-  # TODO(#1580): sum() cases x %in% y, A [&|] B, !A, is.na/is.nan/is.finite/is.infinite/is.element
   # TODO(#1581): extend to include all()-alike expressions
-  zero_expr <- "(EQ or NE or GT or LE) and expr[NUM_CONST[text() = '0' or text() = '0L']]"
-  one_expr <- "(LT or GE) and expr[NUM_CONST[text() = '1' or text() = '1L']]"
+  zero_expr <- "(EQ or NE or GT or LE) and expr/NUM_CONST[text() = '0' or text() = '0L']"
+  one_expr <- "(LT or GE) and expr/NUM_CONST[text() = '1' or text() = '1L']"
   length_xpath <- glue("
   parent::expr
     /parent::expr[
-      expr[SYMBOL_FUNCTION_CALL[text() = 'length']]
+      expr/SYMBOL_FUNCTION_CALL[text() = 'length']
       and parent::expr[ ({zero_expr}) or ({one_expr})]
     ]
   ")
+  known_logical_calls <- c(
+    "grepl", "str_detect", "nzchar", "startsWith", "endsWith",
+    "xor", "is.element", "duplicated",
+    "is.na", "is.nan", "is.finite", "is.infinite",
+    NULL
+  )
   sum_xpath <- glue("
   parent::expr[
     expr[
-      expr[SYMBOL_FUNCTION_CALL[text() = 'grepl']]
-      or (EQ or NE or GT or LT or GE or LE)
+      expr/SYMBOL_FUNCTION_CALL[{xp_text_in_table(known_logical_calls)}]
+      or (EQ or NE or GT or LT or GE or LE or AND or OR or OP-EXCLAMATION)
+      or SPECIAL[text() = '%in%' or text() = '%chin%']
     ]
     and parent::expr[ ({zero_expr}) or ({one_expr})]
   ]")

tests/testthat/test-boolean_arithmetic_linter.R

@@ -1,11 +1,11 @@
 test_that("boolean_arithmetic_linter doesn't block allowed usages", {
   linter <- boolean_arithmetic_linter()
 
-  expect_lint("!any(x == y)", NULL, linter)
-  expect_lint("!any(grepl(pattern, x))", NULL, linter)
+  expect_no_lint("!any(x == y)", linter)
+  expect_no_lint("!any(grepl(pattern, x))", linter)
 })
 
-test_that("boolean_arithmetic_linter requires use of any() or !any()", {
+test_that("boolean_arithmetic_linter requires use of any() or !any() over length(.(<logical>))", {
   linter <- boolean_arithmetic_linter()
   lint_msg <- rex::rex("Use any() to express logical aggregations.")
 
@@ -14,16 +14,40 @@ test_that("boolean_arithmetic_linter requires use of any() or !any()", {
   expect_lint("length(which(is_treatment)) == 0L", lint_msg, linter)
   # regex version
   expect_lint("length(grep(pattern, x)) == 0", lint_msg, linter)
-  # sum version
-  expect_lint("sum(x == y) == 0L", lint_msg, linter)
-  expect_lint("sum(grepl(pattern, x)) == 0", lint_msg, linter)
 
   # non-== comparisons
   expect_lint("length(which(x == y)) > 0L", lint_msg, linter)
   expect_lint("length(which(is_treatment)) < 1", lint_msg, linter)
   expect_lint("length(grep(pattern, x)) >= 1L", lint_msg, linter)
-  expect_lint("sum(x == y) != 0", lint_msg, linter)
-  expect_lint("sum(grepl(pattern, x)) > 0L", lint_msg, linter)
+})
+
+local({
+  linter <- boolean_arithmetic_linter()
+  lint_msg <- rex::rex("Use any() to express logical aggregations.")
+
+  outer_comparisons <- c("== 0", "== 0L", "> 0L", "> 0L", ">= 1", ">= 1L")
+
+  patrick::with_parameters_test_that(
+    "sum(x {op} y) {outer} lints",
+    expect_lint(sprintf("sum(x %s y) %s", op, outer), lint_msg, linter),
+    .cases = expand.grid(
+      op = c("==", "!=", ">", "<", ">=", "<=", "&", "|", "%in%", "%chin%"),
+      outer = outer_comparisons
+    )
+  )
+
+  patrick::with_parameters_test_that(
+    "sum({op}(x)) == 0 lints",
+    expect_lint(sprintf("sum(%s(x)) == 0", op), lint_msg, linter),
+    .cases = expand.grid(
+      op = c(
+        "!", "xor", "grepl", "str_detect", "is.element",
+        "is.na", "is.finite", "is.infinite", "is.nan",
+        "duplicated", "nzchar", "startsWith", "endsWith"
+      ),
+      outer = outer_comparisons
+    )
+  )
 })
 
 test_that("lints vectorize", {