New expect_named_linter (#949)

* New expect_named_linter

* NEWS

* fix lints in lintr

DESCRIPTION

@@ -64,6 +64,7 @@ Collate:
     'exclude.R'
     'expect_length_linter.R'
     'expect_lint.R'
+    'expect_named_linter.R'
     'expect_not_linter.R'
     'expect_null_linter.R'
     'expect_s3_class_linter.R'

NAMESPACE

@@ -31,6 +31,7 @@ export(equals_na_linter)
 export(expect_length_linter)
 export(expect_lint)
 export(expect_lint_free)
+export(expect_named_linter)
 export(expect_not_linter)
 export(expect_null_linter)
 export(expect_s3_class_linter)

NEWS.md

@@ -92,6 +92,7 @@ function calls. (#850, #851, @renkun-ken)
    + `expect_s4_class_linter()` Require usage of `expect_s4_class(x, k)` over `expect_true(methods::is(x, k))`
    + `expect_not_linter()` Require usage of `expect_false(x)` over `expect_true(!x)`, and _vice versa_.
    + `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
 * `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)

R/expect_named_linter.R

@@ -0,0 +1,35 @@
+#' Require usage of expect_named(x, n) over expect_equal(names(x), n)
+#'
+#' [testthat::expect_named()] exists specifically for testing the [names()] of
+#'   an object. [testthat::expect_equal()] can also be used for such tests,
+#'   but it is better to use the tailored function instead.
+#'
+#' @evalRd rd_tags("expect_named_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+expect_named_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    xpath <- "//expr[
+      SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical']
+      and following-sibling::expr[
+        expr[SYMBOL_FUNCTION_CALL[text() = 'names']]
+        and (position() = 1 or preceding-sibling::expr[STR_CONST])
+      ]
+    ]"
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+    return(lapply(bad_expr, gen_expect_named_lint, source_file))
+  })
+}
+
+gen_expect_named_lint <- function(expr, source_file) {
+  matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL"))
+  lint_msg <- sprintf("expect_named(x, n) is better than %s(names(x), n)", matched_function)
+  xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning")
+}

inst/lintr/linters.csv

@@ -9,6 +9,7 @@ cyclocomp_linter,style readability best_practices default configurable
 duplicate_argument_linter,correctness common_mistakes configurable
 equals_na_linter,robustness correctness common_mistakes default
 expect_length_linter,package_development best_practices readability
+expect_named_linter,package_development best_practices readability
 expect_not_linter,package_development best_practices readability
 expect_null_linter,package_development best_practices
 expect_s3_class_linter,package_development best_practices

tests/testthat/test-expect_named_linter.R

@@ -0,0 +1,44 @@
+test_that("expect_named_linter doesn't raise false positive lints", {
+  expect_lint("expect_equal(nrow(x), 4L)", NULL, expect_named_linter())
+  # NB: also applies to tinytest, but it's sufficient to test testthat
+  expect_lint("testthat::expect_equal(nrow(x), 4L)", NULL, expect_named_linter())
+})
+
+test_that("expect_named_linter skips allowed usages", {
+  # colnames(), rownames(), and dimnames() tests are not equivalent
+  expect_lint("expect_equal(colnames(x), 'a')", NULL, expect_named_linter())
+  expect_lint("expect_equal(rownames(x), 'a')", NULL, expect_named_linter())
+  expect_lint("expect_equal(dimnames(x), 'a')", NULL, expect_named_linter())
+
+  # only check the first argument. yoda tests in the second argument will be
+  #   missed, but there are legitimate uses of names() in argument 2
+  expect_lint("expect_equal(colnames(x), names(y))", NULL, expect_named_linter())
+})
+
+test_that("expect_named_linter blocks simple disallowed usages", {
+  expect_lint(
+    "expect_equal(names(x), 'a')",
+    rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)"),
+    expect_named_linter()
+  )
+
+  expect_lint(
+    "testthat::expect_equal(names(DF), names(old))",
+    rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)"),
+    expect_named_linter()
+  )
+
+  expect_lint(
+    "expect_equal('a', names(x))",
+    rex::rex("expect_named(x, n) is better than expect_equal(names(x), n)"),
+    expect_named_linter()
+  )
+})
+
+test_that("expect_named_linter blocks expect_identical usage as well", {
+  expect_lint(
+    "expect_identical(names(x), 'a')",
+    rex::rex("expect_named(x, n) is better than expect_identical(names(x), n)"),
+    expect_named_linter()
+  )
+})

tests/testthat/test-settings.R

@@ -74,11 +74,9 @@ test_that("it errors if the config file does not end in a newline", {
   expect_error(read_settings("foo"), "Malformed config file")
 })
 
-test_that("with_defaults works as expected", {
-  # test capturing unnamed args
-  defaults <- with_defaults(assignment_linter)
+test_that("with_defaults works as expected with unnamed args", {
   # assignment_linter is in defaults, so output doesn't change
-  expect_equal(names(defaults), names(with_defaults()))
+  expect_named(with_defaults(assignment_linter), names(with_defaults()))
 })
 
 test_that("rot utility works as intended", {
@@ -106,8 +104,8 @@ test_that("logical_env utility works as intended", {
 
 # fixing #774
 test_that("with_defaults doesn't break on very long input", {
-  expect_equal(
-    names(with_defaults(
+  expect_named(
+    with_defaults(
       default = list(),
       lintr::undesirable_function_linter(c(
         detach = paste(
@@ -120,7 +118,7 @@ test_that("with_defaults doesn't break on very long input", {
           "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
         )
       ))
-    )),
+    ),
     "lintr::undesirable_function_linter"
   )
 })