Expect comparison

DESCRIPTION

@@ -62,6 +62,7 @@ Collate:
     'duplicate_argument_linter.R'
     'equals_na_linter.R'
     'exclude.R'
+    'expect_comparison_linter.R'
     'expect_length_linter.R'
     'expect_lint.R'
     'expect_named_linter.R'

NAMESPACE

@@ -28,6 +28,7 @@ export(default_undesirable_functions)
 export(default_undesirable_operators)
 export(duplicate_argument_linter)
 export(equals_na_linter)
+export(expect_comparison_linter)
 export(expect_length_linter)
 export(expect_lint)
 export(expect_lint_free)

NEWS.md

@@ -94,6 +94,7 @@ function calls. (#850, #851, @renkun-ken)
    + `expect_true_false_linter()` Require usage of `expect_true(x)` over `expect_equal(x, TRUE)` and similar
    + `expect_named_linter()` Require usage of `expect_named(x, n)` over `expect_equal(names(x), n)` and similar
    * `expect_length_linter()` Require usage of `expect_length(x, n)` over `expect_equal(length(x), n)` and similar
+   * `expect_comparison_linter()` Require usage of `expect_gt(x, y)` over `expect_true(x > y)` and similar
 * `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/expect_comparison_linter.R

@@ -0,0 +1,48 @@
+#' Require usage of expect_gt(x, y) over expect_true(x > y) (and similar)
+#'
+#' [testthat::expect_gt()], [testthat::expect_gte()], [testthat::expect_lt()],
+#'   [testthat::expect_lte()], and [testthat::expect_equal()] exist specifically
+#'   for testing comparisons between two objects. [testthat::expect_true()] can
+#'   also be used for such tests, but it is better to use the tailored function
+#'   instead.
+#'
+#' @evalRd rd_tags("expect_comparison_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+expect_comparison_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    # != doesn't have a clean replacement
+    comparator_nodes <- # nolint: object_usage_linter. TODO(#942): remove this.
+      setdiff(as.list(infix_metadata$xml_tag[infix_metadata$comparator]), "NE")
+    xpath <- glue::glue("//expr[
+      expr[SYMBOL_FUNCTION_CALL[text() = 'expect_true']]
+      and expr[2][ {xp_or(comparator_nodes)} ]
+    ]")
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    comparator_expectation_map <- c(
+      `>` = "expect_gt", `>=` = "expect_gte",
+      `<` = "expect_lt", `<=` = "expect_lte",
+      `==` = "expect_identical"
+    )
+
+    return(lapply(
+      bad_expr,
+      xml_nodes_to_lint,
+      source_file,
+      lint_message = function(expr) {
+        comparator <- xml2::xml_text(xml2::xml_find_first(expr, "expr[2]/*[2]"))
+        expectation <- comparator_expectation_map[[comparator]]
+        sprintf("%s(x, y) is better than expect_true(x %s y).", expectation, comparator)
+      },
+      type = "warning"
+    ))
+  })
+}

R/infix_spaces_linter.R

@@ -55,6 +55,8 @@ infix_metadata$unary <- infix_metadata$xml_tag %in% c("OP-PLUS", "OP-MINUS", "OP
 infix_metadata$low_precedence <- infix_metadata$string_value %in% c(
   "+", "-", "~", ">", ">=", "<", "<=", "==", "!=", "&", "&&", "|", "||", "<-", "->", "=", "%%", "/", "*"
 )
+# comparators come up in several lints
+infix_metadata$comparator <- infix_metadata$string_value %in% c("<", "<=", ">", ">=", "==", "!=")
 
 #' Infix spaces linter
 #'

inst/lintr/linters.csv

@@ -8,6 +8,7 @@ commented_code_linter,style readability best_practices default
 cyclocomp_linter,style readability best_practices default configurable
 duplicate_argument_linter,correctness common_mistakes configurable
 equals_na_linter,robustness correctness common_mistakes default
+expect_comparison_linter,package_development best_practices
 expect_length_linter,package_development best_practices readability
 expect_named_linter,package_development best_practices readability
 expect_not_linter,package_development best_practices readability

tests/testthat/test-expect_comparison_linter.R

@@ -0,0 +1,42 @@
+test_that("expect_comparison_linter skips allowed usages", {
+  # there's no expect_ne() for this operator
+  expect_lint("expect_true(x != y)", NULL, expect_comparison_linter())
+  # NB: also applies to tinytest, but it's sufficient to test testthat
+  expect_lint("testthat::expect_true(x != y)", NULL, expect_comparison_linter())
+
+  # multiple comparisons are OK
+  expect_lint("expect_true(x > y || x > z)", NULL, expect_comparison_linter())
+})
+
+test_that("expect_comparison_linter blocks simple disallowed usages", {
+  expect_lint(
+    "expect_true(x > y)",
+    rex::rex("expect_gt(x, y) is better than expect_true(x > y)."),
+    expect_comparison_linter()
+  )
+
+  # namespace qualification is irrelevant
+  expect_lint(
+    "testthat::expect_true(x < y)",
+    rex::rex("expect_lt(x, y) is better than expect_true(x < y)."),
+    expect_comparison_linter()
+  )
+
+  expect_lint(
+    "expect_true(foo(x) >= y[[2]])",
+    rex::rex("expect_gte(x, y) is better than expect_true(x >= y)."),
+    expect_comparison_linter()
+  )
+
+  expect_lint(
+    "expect_true(x <= y)",
+    rex::rex("expect_lte(x, y) is better than expect_true(x <= y)."),
+    expect_comparison_linter()
+  )
+
+  expect_lint(
+    "expect_true(x == (y == 2))",
+    rex::rex("expect_identical(x, y) is better than expect_true(x == y)."),
+    expect_comparison_linter()
+  )
+})