New outer_negation_linter (#988)

DESCRIPTION

@@ -95,6 +95,7 @@ Collate:
     'object_name_linters.R'
     'object_usage_linter.R'
     'open_curly_linter.R'
+    'outer_negation_linter.R'
     'package_hooks_linter.R'
     'paren_body_linter.R'
     'paren_brace_linter.R'

NAMESPACE

@@ -61,6 +61,7 @@ export(object_length_linter)
 export(object_name_linter)
 export(object_usage_linter)
 export(open_curly_linter)
+export(outer_negation_linter)
 export(package_hooks_linter)
 export(paren_body_linter)
 export(paren_brace_linter)

NEWS.md

@@ -99,6 +99,7 @@ function calls. (#850, #851, @renkun-ken)
    * `expect_comparison_linter()` Require usage of `expect_gt(x, y)` over `expect_true(x > y)` and similar
    * `vector_logic_linter()` Require use of scalar logical operators (`&&` and `||`) inside `if()` conditions and similar
    * `any_is_na_linter()` Require usage of `anyNA(x)` over `any(is.na(x))`
+   * `outer_negation_linter()` Require usage of `!any(x)` over `all(!x)` and `!all(x)` over `any(!x)`
 * `assignment_linter()` now lints right assignment (`->` and `->>`) and gains two arguments. `allow_cascading_assign` (`TRUE` by default) toggles whether to lint `<<-` and `->>`; `allow_right_assign` toggles whether to lint `->` and `->>` (#915, @michaelchirico)
 * `infix_spaces_linter()` gains argument `exclude_operators` to disable lints on selected infix operators. By default, all "low-precedence" operators throw lints; see `?infix_spaces_linter` for an enumeration of these. (#914 @michaelchirico)
 * `infix_spaces_linter()` now throws a lint on `a~b` and `function(a=1) {}` (#930, @michaelchirico)

R/object_name_linters.R

@@ -90,12 +90,12 @@ check_style <- function(nms, style, generics = character()) {
   # mark empty names and NA names as conforming
   conforming[!nzchar(nms) | is.na(conforming)] <- TRUE
 
-  if (any(!conforming)) {
+  if (!all(conforming)) {
     possible_s3 <- re_matches(
       nms[!conforming],
       rex(start, capture(name = "generic", or(generics)), ".", capture(name = "method", something), end)
     )
-    if (any(!is.na(possible_s3))) {
+    if (!all(is.na(possible_s3))) {
       has_generic <- possible_s3$generic %in% generics
 
       # If they are not conforming, but are S3 methods then ignore them

R/outer_negation_linter.R

@@ -0,0 +1,53 @@
+#' Require usage of !any(.) over all(!.), !all(.) over any(!.)
+#'
+#' `any(!x)` is logically equivalent to `!any(x)`; ditto for the equivalence of
+#'   `all(!x)` and `!any(x)`. Negating after aggregation only requires inverting
+#'   one logical value, and is typically more readable.
+#'
+#' @evalRd rd_tags("outer_negation_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+outer_negation_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$xml_parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    # NB: the double negation is a bity hairy, but it's what we need to check if
+    #   _all_ of the inputs to any(..., na.rm=na.rm) are negated, i.e., there are
+    #   _not_ any entries that are _not_ negated. IINM that's what we're stuck
+    #   with in xpath if we want to guarantee a condition on _all_ <expr>
+    #   coming after any( and before na.rm= .
+    # NB: requirement that count(expr)>1 is to prevent any() from linting
+    #   e.g. in magrittr pipelines.
+    xpath <- "//expr[
+      expr[SYMBOL_FUNCTION_CALL[text() = 'any' or text() = 'all']]
+      and count(expr) > 1
+      and not(expr[
+        position() > 1
+        and not(OP-EXCLAMATION)
+        and not(preceding-sibling::*[2][self::SYMBOL_SUB])
+      ])
+    ]"
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    return(lapply(
+      bad_expr,
+      xml_nodes_to_lint,
+      source_file = source_file,
+      lint_message = function(expr) {
+        matched_call <- xml2::xml_text(xml2::xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL"))
+        inverse_call <- if (matched_call == "any") "all" else "any"
+        message <- sprintf("!%s(x) is better than %s(!x).", inverse_call, matched_call)
+        paste(
+          message,
+          "The former applies negation only once after aggregation instead of many times for each element of x."
+        )
+      },
+      type = "warning"
+    ))
+  })
+}

R/utils.R

@@ -76,7 +76,7 @@ linter_auto_name <- function(which = -3L) {
 auto_names <- function(x) {
   nms <- names2(x)
   missing <- nms == ""
-  if (all(!missing)) return(nms)
+  if (!any(missing)) return(nms)
 
   default_name <- function(x) {
     if (inherits(x, "linter")) {

inst/lintr/linters.csv

@@ -34,6 +34,7 @@ object_length_linter,style readability default configurable
 object_name_linter,style consistency default configurable
 object_usage_linter,style readability correctness default
 open_curly_linter,style readability default configurable
+outer_negation_linter,readability efficiency best_practices
 package_hooks_linter,style correctness package_development
 paren_body_linter,style readability default
 paren_brace_linter,style readability default

tests/testthat/test-outer_negation_linter.R

@@ -0,0 +1,62 @@
+test_that("outer_negation_linter skips allowed usages", {
+  expect_lint("x <- any(y)", NULL, outer_negation_linter())
+  expect_lint("y <- all(z)", NULL, outer_negation_linter())
+
+  # extended usage of any is not covered
+  expect_lint("any(!a & b)", NULL, outer_negation_linter())
+  expect_lint("all(a | !b)", NULL, outer_negation_linter())
+
+  expect_lint("any(a, b)", NULL, outer_negation_linter())
+  expect_lint("all(b, c)", NULL, outer_negation_linter())
+  expect_lint("any(!a, b)", NULL, outer_negation_linter())
+  expect_lint("all(a, !b)", NULL, outer_negation_linter())
+  expect_lint("any(a, !b, na.rm = TRUE)", NULL, outer_negation_linter())
+})
+
+test_that("outer_negation_linter blocks simple disallowed usages", {
+  expect_lint(
+    "any(!x)",
+    rex::rex("!all(x) is better than any(!x)"),
+    outer_negation_linter()
+  )
+
+  expect_lint(
+    "all(!foo(x))",
+    rex::rex("!any(x) is better than all(!x)"),
+    outer_negation_linter()
+  )
+
+  # na.rm doesn't change the recommendation
+  expect_lint(
+    "any(!x, na.rm = TRUE)",
+    rex::rex("!all(x) is better than any(!x)"),
+    outer_negation_linter()
+  )
+
+  # also catch nested usage
+  expect_lint(
+    "all(!(x + y))",
+    rex::rex("!any(x) is better than all(!x)"),
+    outer_negation_linter()
+  )
+
+  # catch when all inputs are negated
+  expect_lint(
+    "any(!x, !y)",
+    rex::rex("!all(x) is better than any(!x)"),
+    outer_negation_linter()
+  )
+
+  expect_lint(
+    "all(!x, !y, na.rm = TRUE)",
+    rex::rex("!any(x) is better than all(!x)"),
+    outer_negation_linter()
+  )
+})
+
+test_that("outer_negation_linter doesn't trigger on empty calls", {
+  # minimal version of issue
+  expect_lint("any()", NULL, outer_negation_linter())
+  # closer to what was is practically relevant, as another regression test
+  expect_lint("x %>% any()", NULL, outer_negation_linter())
+})