New expect_setequal_linter

DESCRIPTION

@@ -68,6 +68,7 @@ Collate:
     'expect_not_linter.R'
     'expect_null_linter.R'
     'expect_s3_class_linter.R'
+    'expect_setequal_linter.R'
     'expect_true_false_linter.R'
     'expect_type_linter.R'
     'extract.R'

NAMESPACE

@@ -36,6 +36,7 @@ export(expect_not_linter)
 export(expect_null_linter)
 export(expect_s3_class_linter)
 export(expect_s4_class_linter)
+export(expect_setequal_linter)
 export(expect_true_false_linter)
 export(expect_type_linter)
 export(extraction_operator_linter)

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_setequal_lintr()` Require usage of `expect_setequal(x, y)` over `expect_equal(sort(x), sort(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_setequal_linter.R

@@ -0,0 +1,39 @@
+#' Require usage of expect_setequal() over expect_identical(sort(...), ...)
+#'
+#' `expect_setequal()` is designed for testing an output, regardless of order;
+#'   for example, this is particularly useful for SQL, which is typically
+#'   row-order-agnostic.
+#'
+#' Note that, in the presence of possible duplicates,
+#'   `expect_identical(sort(x), y)` won't be the same as
+#'   `expect_setequal(x, y)`. This linter encourages a separate test for
+#'   duplicates rather than integrating two tests into one.
+#'
+#' @evalRd rd_tags("expect_setequal_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+expect_setequal_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    xpath <- glue::glue("//expr[
+      expr[SYMBOL_FUNCTION_CALL[text() = 'expect_identical' or text() = 'expect_equal']]
+      and expr[expr[SYMBOL_FUNCTION_CALL[text() = 'sort']]]
+      and not(SYMBOL_SUB[text() = 'tolerance'])
+    ]")
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+    return(lapply(bad_expr, gen_expect_setequal_lint, source_file))
+  })
+}
+
+gen_expect_setequal_lint <- function(expr, source_file) {
+  matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL"))
+  lint_msg <- sprintf("Use expect_setequal(actual, expected) instead of %s(sort(actual), expected).", matched_function)
+  lint_msg <- paste(lint_msg, "If you need to check equality of duplicates, do so as a separate test.")
+  xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning")
+}

R/expect_type_linter.R

@@ -45,7 +45,6 @@ gen_expect_type_lint <- function(expr, source_file) {
   xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning")
 }
 
-
 # NB: the full list of values that can arise from `typeof(x)` is available
 #   in ?typeof (or, slightly more robustly, in the R source: src/main/util.c.
 #   Not all of them are available in is.<type> form, e.g. 'any' or

inst/lintr/linters.csv

@@ -14,6 +14,7 @@ expect_not_linter,package_development best_practices readability
 expect_null_linter,package_development best_practices
 expect_s3_class_linter,package_development best_practices
 expect_s4_class_linter,package_development best_practices
+expect_setequal_linter,package_development best_practices readability
 expect_true_false_linter,package_development best_practices readability
 expect_type_linter,package_development best_practices
 extraction_operator_linter,style best_practices

tests/testthat/test-expect_setequal_linter.R

@@ -0,0 +1,29 @@
+test_that("expect_setequal_linter skips allowed usages", {
+  # tolerance= blocks applicability
+  expect_lint("expect_equal(sort(x), sort(y), tolerance = 1e-12)", NULL, expect_setequal_linter())
+})
+
+test_that("expect_setequal_linter blocks simple disallowed usages", {
+  expect_lint(
+    "expect_identical(sort(x), sort(y))",
+    rex::rex("Use expect_setequal(actual, expected) instead of expect_identical(sort(actual), expected)"),
+    expect_setequal_linter()
+  )
+  expect_lint(
+    "expect_equal(sort(x), sort(y))",
+    rex::rex("Use expect_setequal(actual, expected) instead of expect_equal(sort(actual), expected)"),
+    expect_setequal_linter()
+  )
+
+  # usage in either argument alone is matched
+  expect_lint(
+    "expect_identical(x, sort(y))",
+    rex::rex("Use expect_setequal(actual, expected) instead of expect_identical(sort(actual), expected)"),
+    expect_setequal_linter()
+  )
+  expect_lint(
+    "expect_identical(sort(x), y)",
+    rex::rex("Use expect_setequal(actual, expected) instead of expect_identical(sort(actual), expected)"),
+    expect_setequal_linter()
+  )
+})