New ifelse_censor_linter

DESCRIPTION

@@ -86,6 +86,7 @@ Collate:
     'get_source_expressions.R'
     'ids_with_token.R'
     'if_else_match_braces_linter.R'
+    'ifelse_censor_linter.R'
     'implicit_integer_linter.R'
     'infix_spaces_linter.R'
     'line_length_linter.R'

NAMESPACE

@@ -52,6 +52,7 @@ export(function_left_parentheses_linter)
 export(get_source_expressions)
 export(ids_with_token)
 export(if_else_match_braces_linter)
+export(ifelse_censor_linter)
 export(implicit_integer_linter)
 export(infix_spaces_linter)
 export(line_length_linter)

NEWS.md

@@ -120,6 +120,7 @@ function calls. (#850, #851, @renkun-ken)
    * `unreachable_code_linter()` Prevent code after `return()` and `stop()` statements that will never be reached
    * `regex_subset_linter()` Require usage of `grep(ptn, x, value = TRUE)` over `x[grep(ptn, x)]` and similar
    * `consecutive_stopifnot_linter()` Require consecutive calls to `stopifnot()` to be unified into one
+   * `ifelse_censor_linter()` Require usage of `pmax()` / `pmin()` where appropriate, e.g. `ifelse(x > y, x, y)` is `pmax(x, y)`
    * `system_file_linter()` Require file paths to be constructed by `system.file()` instead of calling `file.path()` directly
 * `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/ifelse_censor_linter.R

@@ -0,0 +1,57 @@
+#' Block usage of ifelse where pmin or pmax is more appropriate
+#'
+#' `ifelse(x > M, M, x)` is the same as `pmin(x, M)`, but harder
+#'   to read and requires several passes over the vector.
+#'
+#' The same goes for other similar ways to censor a vector, e.g.
+#'   `ifelse(x <= M, x, M)` is `pmin(x, M)`,
+#'   `ifelse(x < m, m, x)` is `pmax(x, m)`, and
+#'   `ifelse(x >= m, x, m)` is `pmax(x, m)`.
+#'
+#' @evalRd rd_tags("ifelse_censor_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+ifelse_censor_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$xml_parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    xpath <- glue::glue("//expr[
+      expr[SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ]]
+      and expr[2][
+        (LT or GT or LE or GE)
+        and expr[1] = following-sibling::expr
+        and expr[2] = following-sibling::expr
+      ]
+    ]")
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    return(lapply(
+      bad_expr,
+      xml_nodes_to_lint,
+      source_file = source_file,
+      lint_message = function(expr) {
+        matched_call <- xml2::xml_text(xml2::xml_find_first(expr, "expr/SYMBOL_FUNCTION_CALL"))
+        op <- xml2::xml_text(xml2::xml_find_first(expr, "expr[2]/*[2]"))
+        match_first <- !is.na(xml2::xml_find_first(expr, "expr[2][expr[1] = following-sibling::expr[1]]"))
+        if (op %in% c("<", "<=")) {
+          if (match_first) {
+            sprintf("pmin(x, y) is preferable to %s(x %s y, x, y).", matched_call, op)
+          } else {
+            sprintf("pmax(x, y) is preferable to %s(x %s y, y, x).", matched_call, op)
+          }
+        } else {
+          if (match_first) {
+            sprintf("pmax(x, y) is preferable to %s(x %s y, x, y).", matched_call, op)
+          } else {
+            sprintf("pmin(x, y) is preferable to %s(x %s y, y, x).", matched_call, op)
+          }
+        }
+      },
+      type = "warning"
+    ))
+  })
+}

R/nested_ifelse_linter.R

@@ -46,4 +46,5 @@ nested_ifelse_linter <- function() {
 }
 
 # functions equivalent to base::ifelse() for linting purposes
+# NB: this is re-used elsewhere, e.g. in ifelse_censor_linter
 ifelse_funs <- c("ifelse", "if_else", "fifelse")

inst/lintr/linters.csv

@@ -28,6 +28,7 @@ extraction_operator_linter,style best_practices
 function_brace_linter,default style readability
 function_left_parentheses_linter,style readability default
 if_else_match_braces_linter,default style readability
+ifelse_censor_linter,best_practices efficiency
 implicit_integer_linter,style consistency best_practices
 infix_spaces_linter,style readability default
 line_length_linter,style readability default configurable

tests/testthat/test-ifelse_censor_linter.R

@@ -0,0 +1,67 @@
+test_that("ifelse_censor_linter skips allowed usages", {
+  expect_lint("ifelse(x > 2, x, y)", NULL, ifelse_censor_linter())
+  expect_lint("ifelse(x > 2, x, y)", NULL, ifelse_censor_linter())
+})
+
+test_that("ifelse_censor_linter blocks simple disallowed usages", {
+  expect_lint(
+    "ifelse(x < 0, 0, x)",
+    rex::rex("pmax(x, y) is preferable to ifelse(x < y, y, x)"),
+    ifelse_censor_linter()
+  )
+  # other equivalents to base::ifelse()
+  expect_lint(
+    "if_else(x < 0, 0, x)",
+    rex::rex("pmax(x, y) is preferable to if_else(x < y, y, x)"),
+    ifelse_censor_linter()
+  )
+  expect_lint(
+    "fifelse(x < 0, 0, x)",
+    rex::rex("pmax(x, y) is preferable to fifelse(x < y, y, x)"),
+    ifelse_censor_linter()
+  )
+
+  # other equivalents for censoring
+  expect_lint(
+    "ifelse(x <= 0, 0, x)",
+    rex::rex("pmax(x, y) is preferable to ifelse(x <= y, y, x)"),
+    ifelse_censor_linter()
+  )
+  expect_lint(
+    "ifelse(x > 0, x, 0)",
+    rex::rex("pmax(x, y) is preferable to ifelse(x > y, x, y)"),
+    ifelse_censor_linter()
+  )
+  expect_lint(
+    "ifelse(x >= 0, x, 0)",
+    rex::rex("pmax(x, y) is preferable to ifelse(x >= y, x, y)"),
+    ifelse_censor_linter()
+  )
+
+  # pairwise min/max (similar to censoring)
+  expect_lint(
+    "ifelse(x < y, x, y)",
+    rex::rex("pmin(x, y) is preferable to ifelse(x < y, x, y)"),
+    ifelse_censor_linter()
+  )
+  expect_lint(
+    "ifelse(x >= y, y, x)",
+    rex::rex("pmin(x, y) is preferable to ifelse(x >= y, y, x)"),
+    ifelse_censor_linter()
+  )
+
+  # more complicated expression still matches
+  lines <- trim_some("
+    ifelse(2 + p + 104 + 1 > ncols,
+           ncols, 2 + p + 104 + 1
+           )
+  ")
+  expect_lint(
+    lines,
+    rex::rex("pmin(x, y) is preferable to ifelse(x > y, y, x)"),
+    ifelse_censor_linter()
+  )
+})
+
+# TODO(michaelchirico): how easy would it be to strip parens when considering lint?
+#   e.g. ifelse(x < (kMaxIndex - 1), x, kMaxIndex - 1)