New class_equals_linter

DESCRIPTION

@@ -53,6 +53,7 @@ Collate:
     'assignment_linter.R'
     'backport_linter.R'
     'cache.R'
+    'class_equals_linter.R'
     'closed_curly_linter.R'
     'commas_linter.R'
     'comment_linters.R'

NAMESPACE

@@ -18,6 +18,7 @@ export(assignment_linter)
 export(available_linters)
 export(backport_linter)
 export(checkstyle_output)
+export(class_equals_linter)
 export(clear_cache)
 export(closed_curly_linter)
 export(commas_linter)

NEWS.md

@@ -100,6 +100,7 @@ function calls. (#850, #851, @renkun-ken)
    * `if_else_match_braces_linter()` Require balanced usage of `{}` in `if`/`else` conditions
    * `vector_logic_linter()` Require use of scalar logical operators (`&&` and `||`) inside `if()` conditions and similar
    * `any_is_na_linter()` Require usage of `anyNA(x)` over `any(is.na(x))`
+   * `class_equals_linter()` Prevent comparing `class(x)` with `==`, `!=`, or `%in%`, where `inherits()` is typically preferred
    * `outer_negation_linter()` Require usage of `!any(x)` over `all(!x)` and `!all(x)` over `any(!x)`
    * `numeric_leading_zero_linter()` Require a leading `0` in fractional numeric constants, e.g. `0.1` instead of `.1`
    * `paste_sep_linter()` Require usage of `paste0()` over `paste(sep = "")`

R/class_equals_linter.R

@@ -0,0 +1,41 @@
+#' Block comparison of class with ==
+#'
+#' Usage like `class(x) == "character"` is prone to error since class in R
+#'   is in general a vector. The correct version for S3 classes is [inherits()]:
+#'   `inherits(x, "character")`. Often, class `k` will have an `is.` equivalent,
+#'   for example [is.character()] or [is.data.frame()].
+#'
+#' Similar reasoning applies for `class(x) %in% "character"`
+#'
+#' @evalRd rd_tags("class_equals_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+class_equals_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$xml_parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    xpath <- "//expr[
+      not(preceding-sibling::OP-LEFT-BRACKET)
+      and expr[expr[SYMBOL_FUNCTION_CALL[text() = 'class']]]
+      and (EQ or NE or SPECIAL[text() = '%in%'])
+    ]"
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    return(lapply(
+      bad_expr,
+      xml_nodes_to_lint,
+      source_file = source_file,
+      lint_message = function(expr) {
+        op <- xml2::xml_text(xml2::xml_find_first(expr, "*[2]"))
+        message <- sprintf("Instead of comparing class(x) with %s,", op)
+        paste(message, "use inherits(x, 'class-name') or is.<class> or is(x, 'class')")
+      },
+      type = "warning"
+    ))
+  })
+}

inst/lintr/linters.csv

@@ -3,6 +3,7 @@ absolute_path_linter,robustness best_practices configurable
 any_is_na_linter,efficiency best_practices
 assignment_linter,style consistency default
 backport_linter,robustness configurable package_development
+class_equals_linter,best_practices robustness consistency
 closed_curly_linter,style readability default configurable
 commas_linter,style readability default
 commented_code_linter,style readability best_practices default

tests/testthat/test-class_equals_linter.R

@@ -0,0 +1,61 @@
+test_that("class_equals_linter skips allowed usages", {
+  expect_lint("class(x) <- 'character'", NULL, class_equals_linter())
+  expect_lint("class(x) = 'character'", NULL, class_equals_linter())
+
+  # proper way to test exact class
+  expect_lint("identical(class(x), c('glue', 'character'))", NULL, class_equals_linter())
+})
+
+test_that("class_equals_linter blocks simple disallowed usages", {
+  expect_lint(
+    "if (class(x) == 'character') stop('no')",
+    rex::rex("Instead of comparing class(x) with =="),
+    class_equals_linter()
+  )
+
+  expect_lint(
+    "is_regression <- class(x) == 'lm'",
+    rex::rex("Instead of comparing class(x) with =="),
+    class_equals_linter()
+  )
+
+  expect_lint(
+    "is_regression <- 'lm' == class(x)",
+    rex::rex("Instead of comparing class(x) with =="),
+    class_equals_linter()
+  )
+})
+
+test_that("class_equals_linter blocks usage of %in% for checking class", {
+  expect_lint(
+    "if ('character' %in% class(x)) stop('no')",
+    rex::rex("Instead of comparing class(x) with %in%"),
+    class_equals_linter()
+  )
+
+  expect_lint(
+    "if (class(x) %in% 'character') stop('no')",
+    rex::rex("Instead of comparing class(x) with %in%"),
+    class_equals_linter()
+  )
+})
+
+test_that("class_equals_linter blocks class(x) != 'klass'", {
+  expect_lint(
+    "if (class(x) != 'character') TRUE",
+    rex::rex("Instead of comparing class(x) with !="),
+    class_equals_linter()
+  )
+})
+
+# as seen, e.g. in base R
+test_that("class_equals_linter skips usage for subsetting", {
+  expect_lint("class(x)[class(x) == 'foo']", NULL, class_equals_linter())
+
+  # but not further nesting
+  expect_lint(
+    "x[if (class(x) == 'foo') 1 else 2]",
+    rex::rex("Instead of comparing class(x) with =="),
+    class_equals_linter()
+  )
+})