New is_numeric_linter (#1635)

* New is_numeric_linter

* add tags

* lint in main man page too

* NEWS item

* use get_r_string for test on string value

* usage examples

* tag follow-up issue in TODO

* whitespace

* hanging indent

* document

* note class(x)== case, add TODOs

* full sentence to avoid comment linter

Co-authored-by: Indrajeet Patil <patilindrajeet.science@gmail.com>

DESCRIPTION

@@ -106,6 +106,7 @@ Collate:
     'infix_spaces_linter.R'
     'inner_combine_linter.R'
     'is_lint_level.R'
+    'is_numeric_linter.R'
     'lengths_linter.R'
     'line_length_linter.R'
     'lint.R'

NAMESPACE

@@ -70,6 +70,7 @@ export(implicit_integer_linter)
 export(infix_spaces_linter)
 export(inner_combine_linter)
 export(is_lint_level)
+export(is_numeric_linter)
 export(lengths_linter)
 export(line_length_linter)
 export(lint)

NEWS.md

@@ -53,6 +53,9 @@
 
 * `for_loop_index_linter()` to prevent overwriting local variables in a `for` loop declared like `for (x in x) { ... }` (@MichaelChirico)
 
+* `is_numeric_linter()` for redundant checks equivalent to `is.numeric(x)` such as `is.numeric(x) || is.integer(x)` or
+  `class(x) %in% c("numeric", "integer")` (@MichaelChirico)
+
 * `empty_assignment_linter()` for identifying empty assignments like `x = {}` that are more clearly written as `x = NULL` (@MichaelChirico)
 
 ## Notes

R/is_numeric_linter.R

@@ -0,0 +1,111 @@
+#' Redirect `is.numeric(x) || is.integer(x)` to just use `is.numeric(x)`
+#'
+#' [is.numeric()] returns `TRUE` when `typeof(x)` is `double` or `integer` --
+#'   testing `is.numeric(x) || is.integer(x)` is thus redundant.
+#'
+#' NB: This linter plays well with [class_equals_linter()], which can help
+#'   avoid further `is.numeric()` equivalents like
+#'   any(class(x) == c("numeric", "integer"))`.
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "is.numeric(y) || is.integer(y)",
+#'   linters = is_numeric_linter()
+#' )
+#'
+#' lint(
+#'   text = "class(z) %in% c('numeric', 'integer')",
+#'   linters = is_numeric_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "is.numeric(y) || is.factor(y)",
+#'   linters = is_numeric_linter()
+#' )
+#'
+#' lint(
+#'   text = "class(z) %in% c('numeric', 'integer', 'factor')",
+#'   linters = is_numeric_linter()
+#' )
+#'
+#' @evalRd rd_tags("is_numeric_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+is_numeric_linter <- function() {
+  # TODO(michaelchirico): this should also cover is.double(x) || is.integer(x)
+  # TODO(#1636): is.numeric(x) || is.integer(x) || is.factor(x) is also redundant
+  # TODO(michaelchirico): consdier capturing any(class(x) == "numeric/integer")
+  #   here directly; currently we rely on class_equals_linter() also active
+  # TODO(michaelchirico): also catch inherits(x, c("numeric", "integer"))
+  is_numeric_expr <- "expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.numeric']]"
+  is_integer_expr <- "expr[1][SYMBOL_FUNCTION_CALL[text() = 'is.integer']]"
+
+  # testing things like is.numeric(x) || is.integer(x)
+  or_xpath <- glue::glue("
+  //OR2
+    /parent::expr[
+      expr/{is_numeric_expr}
+      and expr/{is_integer_expr}
+      and
+        expr/{is_numeric_expr}/following-sibling::expr[1]
+        = expr/{is_integer_expr}/following-sibling::expr[1]
+    ]
+  ")
+
+  # testing class(x) %in% c("numeric", "integer")
+  # TODO(michaelchirico): include typeof(x) %in% c("integer", "double")
+  class_xpath <- "
+  //SPECIAL[
+    text() = '%in%'
+    and following-sibling::expr[
+      expr/SYMBOL_FUNCTION_CALL[text() = 'c']
+      and count(expr/STR_CONST) = 2
+      and count(expr) = 3
+    ]
+    and preceding-sibling::expr/expr/SYMBOL_FUNCTION_CALL[text() = 'class']
+  ]
+    /parent::expr
+  "
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    or_expr <- xml2::xml_find_all(xml, or_xpath)
+    or_lints <- xml_nodes_to_lints(
+      or_expr,
+      source_expression = source_expression,
+      lint_message = paste(
+        "is.numeric(x) is the same as is.numeric(x) || is.integer(x).",
+        "Use is.double(x) to test for objects stored as 64-bit floating point."
+      ),
+      type = "warning"
+    )
+
+    class_expr <- xml2::xml_find_all(xml, class_xpath)
+    if (length(class_expr) > 0L) {
+      class_strings <- c(
+        get_r_string(class_expr, "expr[2]/expr[2]/STR_CONST"),
+        get_r_string(class_expr, "expr[2]/expr[3]/STR_CONST")
+      )
+      is_lintable <- "integer" %in% class_strings && "numeric" %in% class_strings
+      class_expr <- class_expr[is_lintable]
+    }
+    class_lints <- xml_nodes_to_lints(
+      class_expr,
+      source_expression = source_expression,
+      lint_message = paste(
+        'is.numeric(x) is the same as class(x) %in% c("integer", "numeric").',
+        "Use is.double(x) to test for objects stored as 64-bit floating point."
+      ),
+      type = "warning"
+    )
+
+    c(or_lints, class_lints)
+  })
+}

inst/lintr/linters.csv

@@ -37,6 +37,7 @@ ifelse_censor_linter,best_practices efficiency
 implicit_integer_linter,style consistency best_practices
 infix_spaces_linter,style readability default
 inner_combine_linter,efficiency consistency readability
+is_numeric_linter,readability best_practices consistency
 lengths_linter,efficiency readability best_practices
 line_length_linter,style readability default configurable
 literal_coercion_linter,best_practices consistency efficiency

tests/testthat/test-is_numeric_linter.R

@@ -0,0 +1,64 @@
+test_that("is_numeric_linter skips allowed usages involving ||", {
+  expect_lint("is.numeric(x) || is.integer(y)", NULL, is_numeric_linter())
+  # x is used, but not identically
+  expect_lint("is.numeric(x) || is.integer(foo(x))", NULL, is_numeric_linter())
+  # not totally crazy, e.g. if input accepts a vector or a list
+  expect_lint("is.numeric(x) || is.integer(x[[1]])", NULL, is_numeric_linter())
+})
+
+test_that("is_numeric_linter skips allowed usages involving %in%", {
+  # false positives for class(x) %in% c('integer', 'numeric') style
+  expect_lint("class(x) %in% 1:10", NULL, is_numeric_linter())
+  expect_lint("class(x) %in% 'numeric'", NULL, is_numeric_linter())
+  expect_lint("class(x) %in% c('numeric', 'integer', 'factor')", NULL, is_numeric_linter())
+  expect_lint("class(x) %in% c('numeric', 'integer', y)", NULL, is_numeric_linter())
+})
+
+test_that("is_numeric_linter blocks disallowed usages involving ||", {
+  linter <- is_numeric_linter()
+  lint_msg <- rex::rex("same as is.numeric(x) || is.integer(x)")
+
+  expect_lint("is.numeric(x) || is.integer(x)", lint_msg, linter)
+
+  # order doesn't matter
+  expect_lint("is.integer(x) || is.numeric(x)", lint_msg, linter)
+
+  # identical expressions match too
+  expect_lint("is.integer(DT$x) || is.numeric(DT$x)", lint_msg, linter)
+
+  # line breaks don't matter
+  lines <- trim_some("
+    if (
+      is.integer(x)
+      || is.numeric(x)
+    ) TRUE
+  ")
+  expect_lint(lines, lint_msg, linter)
+
+  # caught when nesting
+  expect_lint("all(y > 5) && (is.integer(x) || is.numeric(x))", lint_msg, linter)
+
+  # implicit nesting
+  expect_lint("is.integer(x) || is.numeric(x) || is.logical(x)", lint_msg, linter)
+})
+
+test_that("is_numeric_linter blocks disallowed usages involving %in%", {
+  linter <- is_numeric_linter()
+  lint_msg <- rex::rex('same as class(x) %in% c("integer", "numeric")')
+
+  expect_lint("class(x) %in% c('integer', 'numeric')", lint_msg, linter)
+  expect_lint('class(x) %in% c("numeric", "integer")', lint_msg, linter)
+})
+
+test_that("raw strings are handled properly when testing in class", {
+  skip_if_not_r_version("4.0.0")
+
+  linter <- is_numeric_linter()
+  lint_msg <- rex::rex('same as class(x) %in% c("integer", "numeric")')
+
+  expect_lint("class(x) %in% c(R'(numeric)', 'integer', 'factor')", NULL, linter)
+  expect_lint("class(x) %in% c('numeric', R'--(integer)--', y)", NULL, linter)
+
+  expect_lint("class(x) %in% c(R'(integer)', 'numeric')", lint_msg, linter)
+  expect_lint('class(x) %in% c("numeric", R"--[integer]--")', lint_msg, linter)
+})