new allow_named_stopifnot argument for conjunct_test_linter

NEWS.md

@@ -106,6 +106,7 @@ function calls. (#850, #851, @renkun-ken)
    + `expect_s3_class_linter()` Require usage of `expect_s3_class(x, k)` over `expect_equal(class(x), k)` and similar
    + `expect_s4_class_linter()` Require usage of `expect_s4_class(x, k)` over `expect_true(methods::is(x, k))`
    + `conjunct_test_linter()` Require usage of `expect_true(x); expect_true(y)` over `expect_true(x && y)` and similar (extended in #1016)
+     + Extended for #1011 to allow forcing R>=4-style named `stopifnot()` tests to be separate as well
    + `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

R/conjunct_test_linter.R

@@ -7,10 +7,12 @@
 #'
 #' Similar reasoning applies to `&&` usage inside [stopifnot()] and `assertthat::assert_that()` calls.
 #'
+#' @param allow_named_stopifnot Logical, `TRUE` by default. If `FALSE`, "named" calls to `stopifnot()`,
+#'   available since R 4.0.0 to provide helpful messages for test failures, are also linted.
 #' @evalRd rd_tags("conjunct_test_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-conjunct_test_linter <- function() {
+conjunct_test_linter <- function(allow_named_stopifnot = TRUE) {
   Linter(function(source_file) {
     # need the full file to also catch usages at the top level
     if (length(source_file$full_parsed_content) == 0L) {
@@ -19,16 +21,19 @@ conjunct_test_linter <- function() {
 
     xml <- source_file$full_xml_parsed_content
 
-    # TODO(#1017): address keyword arguments in R>=4.0 for stopifnot(). lint optionally (on by default)?
-    xpath <- "//expr[
+    named_stopifnot_condition <- if (allow_named_stopifnot) "and not(preceding-sibling::*[1][self::EQ_SUB])" else ""
+    xpath <- glue::glue("//expr[
       (
-        expr[SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'stopifnot' or text() = 'assert_that']]
+        expr[SYMBOL_FUNCTION_CALL[text() = 'expect_true' or text() = 'assert_that']]
         and expr[2][AND2]
+      ) or (
+        expr[SYMBOL_FUNCTION_CALL[text() = 'stopifnot']]
+        and expr[2][AND2 {named_stopifnot_condition}]
       ) or (
         expr[SYMBOL_FUNCTION_CALL[text() = 'expect_false']]
         and expr[2][OR2]
       )
-    ]"
+    ]")
 
     bad_expr <- xml2::xml_find_all(xml, xpath)
 

tests/testthat/test-conjunct_test_linter.R

@@ -95,3 +95,17 @@ test_that("conjunct_test_linter blocks simple disallowed usages of stopifnot() a
     conjunct_test_linter()
   )
 })
+
+test_that("conjunct_test_linter's allow_named_stopifnot argument works", {
+  # allowed by default
+  expect_lint(
+    "stopifnot('x must be a logical scalar' = length(x) == 1 && is.logical(x) && !is.na(x))",
+    NULL,
+    conjunct_test_linter()
+  )
+  expect_lint(
+    "stopifnot('x is a logical scalar' = length(x) == 1 && is.logical(x) && !is.na(x))",
+    rex::rex("Instead of stopifnot(A && B), write multiple conditions"),
+    conjunct_test_linter(allow_named_stopifnot = FALSE)
+  )
+})