Create all_equal_linter() (#2885)

* Create all_equal_linter()

* Add all_equal_linter() in NEWS

* Add lint message and vectorize test

* Fix typo

* Merge XPaths and cover while() case

* Add tests with tolerance arg

* Lint  isFALSE(all.equal())

* Customize error message when tolerance is present

* Fix long line lint

* Add test for false positive

* Ensure only all.equal() in if/while calls is linted

* avoid paste()

---------

Co-authored-by: Michael Chirico <[email protected]>

Author: Bisaloo

DESCRIPTION

@@ -68,6 +68,7 @@ Collate:
     'absolute_path_linter.R'
     'actions.R'
     'addins.R'
+    'all_equal_linter.R'
     'any_duplicated_linter.R'
     'any_is_na_linter.R'
     'assignment_linter.R'

NAMESPACE

@@ -15,6 +15,7 @@ export(Lint)
 export(Linter)
 export(T_and_F_symbol_linter)
 export(absolute_path_linter)
+export(all_equal_linter)
 export(all_linters)
 export(all_undesirable_functions)
 export(all_undesirable_operators)

NEWS.md

@@ -51,6 +51,7 @@
 
 ### New linters
 
+* `all_equal_linter()` warns about incorrect use of `all.equal()` in `if` clauses or preceded by `!` (#2885, @Bisaloo).
 * `download_file_linter()` encourages the use of `mode = "wb"` (or `mode = "ab"`) when using `download.file()`, rather than `mode = "w"` or `mode = "a"`, as the latter can produce broken
 files in Windows (#2882, @Bisaloo).
 * `lint2df_linter()` encourages the use of the `list2DF()` function, or the `data.frame()` function when recycling is required, over the slower and less readable `do.call(cbind.data.frame, )` alternative (#2834, @Bisaloo).

R/all_equal_linter.R

@@ -0,0 +1,90 @@
+#' Warn about invalid usage of `all.equal()`
+#'
+#' [all.equal()] returns `TRUE` in the absence of differences but return a
+#' character string (not `FALSE`) in the presence of differences.
+#' Usage of `all.equal()` without wrapping it in `isTRUE()` in `if` clauses, or
+#' preceded by the negation operator `!`, are thus likely to generate unexpected
+#' errors if the compared objects have differences.
+#' An alternative is to use `identical()` to compare vector of strings or when
+#' exact equality is expected.
+#'
+#' @examples
+#' # lints
+#' lint(
+#'   text = 'if (all.equal(a, b)) message("equal")',
+#'   linters = all_equal_linter()
+#' )
+#'
+#' lint(
+#'   text = '!all.equal(a, b)',
+#'   linters = all_equal_linter()
+#' )
+#'
+#' lint(
+#'   text = 'isFALSE(all.equal(a, b))',
+#'   linters = all_equal_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = 'if (isTRUE(all.equal(a, b))) message("equal")',
+#'   linters = all_equal_linter()
+#' )
+#'
+#' lint(
+#'   text = '!identical(a, b)',
+#'   linters = all_equal_linter()
+#' )
+#'
+#' lint(
+#'   text = "!isTRUE(all.equal(a, b))",
+#'   linters = all_equal_linter()
+#' )
+#'
+#' @evalRd rd_tags("all_equal_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+all_equal_linter <- function() {
+
+  Linter(linter_level = "expression", function(source_expression) {
+    all_equal_calls <- source_expression$xml_find_function_calls("all.equal")
+
+    dangerous_unwrapped_all_equal <- xml_find_all(
+      all_equal_calls,
+      "parent::expr[
+        preceding-sibling::*[not(self::COMMENT)][2][self::IF or self::WHILE]
+        or preceding-sibling::*[not(self::COMMENT)][1][self::OP-EXCLAMATION]
+      ]"
+    )
+
+    has_tolerance_arg <- !is.na(
+      xml_find_first(dangerous_unwrapped_all_equal, "SYMBOL_SUB[text() = 'tolerance']")
+    )
+
+    unwrapped_all_equal_lints <- xml_nodes_to_lints(
+      dangerous_unwrapped_all_equal,
+      source_expression = source_expression,
+      lint_message = ifelse(
+        has_tolerance_arg,
+        "Wrap all.equal() in isTRUE().",
+        "Wrap all.equal() in isTRUE(), or replace it by identical() if no tolerance is required."
+      ),
+      type = "warning"
+    )
+
+    is_false_all_equal <- xml_find_all(
+      all_equal_calls,
+      "parent::expr[preceding-sibling::expr[1]/SYMBOL_FUNCTION_CALL/text() = 'isFALSE']"
+    )
+
+    is_false_all_equal_lints <- xml_nodes_to_lints(
+      is_false_all_equal,
+      source_expression = source_expression,
+      lint_message =
+        "Use !isTRUE() to check for differences in all.equal(). isFALSE(all.equal()) always returns FALSE.",
+      type = "warning"
+    )
+
+    c(unwrapped_all_equal_lints, is_false_all_equal_lints)
+  })
+}

inst/lintr/linters.csv

@@ -1,5 +1,6 @@
 linter,tags
 absolute_path_linter,robustness best_practices configurable
+all_equal_linter,common_mistakes robustness
 any_duplicated_linter,efficiency best_practices
 any_is_na_linter,efficiency best_practices
 assignment_linter,style consistency default configurable

man/all_equal_linter.Rd

@@ -0,0 +1,45 @@
+test_that("all_equal_linter() skips allowed usages", {
+  linter <- all_equal_linter()
+
+  # Only when used in if
+  expect_no_lint("all.equal(a, b)", linter)
+  expect_no_lint("all.equal(a, b, tolerance = 1e-3)", linter)
+
+  expect_no_lint("if (isTRUE(all.equal(a, b))) message('equal')", linter)
+  expect_no_lint("if (!isTRUE(all.equal(a, b))) message('different')", linter)
+
+  expect_no_lint("if (A) all.equal(x, y)", linter)
+})
+
+test_that("all_equal_linter() blocks simple disallowed usages", {
+  linter <- all_equal_linter()
+  lint_message <- rex::rex("Wrap all.equal() in isTRUE().")
+  expect_lint("if (all.equal(a, b, tolerance = 1e-3)) message('equal')", lint_message, linter)
+
+  lint_message <- rex::rex("Wrap all.equal() in isTRUE(), or replace it by identical()")
+  expect_lint("if (all.equal(a, b)) message('equal')", lint_message, linter)
+  expect_lint("!all.equal(a, b)", lint_message, linter)
+  expect_lint("while (all.equal(a, b)) message('equal')", lint_message, linter)
+
+  lint_message <- rex::rex("!isTRUE()")
+  expect_lint("isFALSE(all.equal(a, b))", lint_message, linter)
+})
+
+test_that("lints vectorize", {
+  lint_message <- rex::rex("Wrap all.equal() in isTRUE()")
+
+  expect_lint(
+    trim_some("{
+      all.equal(a, b)
+      !all.equal(a, b)
+      !isTRUE(all.equal(a, b))
+      if ( # test
+        all.equal(a, b)) message('equal')
+    }"),
+    list(
+      list(lint_message, line_number = 3L),
+      list(lint_message, line_number = 6L)
+    ),
+    all_equal_linter()
+  )
+})