New nested_ifelse_linter

DESCRIPTION

@@ -92,6 +92,7 @@ Collate:
     'missing_package_linter.R'
     'namespace.R'
     'namespace_linter.R'
+    'nested_ifelse_linter.R'
     'no_tab_linter.R'
     'numeric_leading_zero_linter.R'
     'object_name_linters.R'

NAMESPACE

@@ -56,6 +56,7 @@ export(lint_package)
 export(missing_argument_linter)
 export(missing_package_linter)
 export(namespace_linter)
+export(nested_ifelse_linter)
 export(no_tab_linter)
 export(nonportable_path_linter)
 export(numeric_leading_zero_linter)

NEWS.md

@@ -102,6 +102,7 @@ function calls. (#850, #851, @renkun-ken)
    * `any_is_na_linter()` Require usage of `anyNA(x)` over `any(is.na(x))`
    * `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`
+   * `nested_ifelse_linter()` Prevent nested calls to `ifelse()` like `ifelse(A, x, ifelse(B, y, z))`, 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/nested_ifelse_linter.R

@@ -0,0 +1,49 @@
+#' Block usage of nested ifelse() calls
+#'
+#' Calling `ifelse` in nested calls is problematic for two main reasons:
+#'   1. It can be hard to read -- mapping the code to the expected output
+#'      for such code can be a messy task/require a lot of mental bandwidth,
+#'      especially for code that nests more than once
+#'   2. It is inefficient -- `ifelse` can evaluate _all_ of its arguments at
+#'      both yes and no (see https://stackoverflow.com/q/16275149); this issue
+#'      is exacerbated for nested calls
+#'
+#' Users can instead rely on a more readable alternative modeled after SQL
+#'   CASE WHEN statements, such as `data.table::fcase` or `dplyr::case_when`,
+#'   or use a look-up-and-merge approach (build a mapping table between values
+#'   and outputs and merge this to the input).
+#'
+#' @evalRd rd_tags("nested_ifelse_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+nested_ifelse_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[ {xp_text_in_table(ifelse_funs)} ]]]
+    /expr[expr[SYMBOL_FUNCTION_CALL[ {xp_text_in_table(ifelse_funs)} ]]]
+    ")
+
+    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"))
+        lint_message <- sprintf("Don't use nested %s() calls;", matched_call)
+        paste(lint_message, "instead, try (1) data.table::fcase; (2) dplyr::case_when; or (3) using a lookup table.")
+      },
+      type = "warning"
+    ))
+  })
+}
+
+# functions equivalent to base::ifelse() for linting purposes
+ifelse_funs <- c("ifelse", "if_else", "fifelse")

inst/lintr/linters.csv

@@ -29,6 +29,7 @@ line_length_linter,style readability default configurable
 missing_argument_linter,correctness common_mistakes configurable
 missing_package_linter,robustness common_mistakes
 namespace_linter,correctness robustness configurable
+nested_ifelse_linter,efficiency readability
 no_tab_linter,style consistency default
 nonportable_path_linter,robustness best_practices configurable
 numeric_leading_zero_linter,style consistency readability

tests/testthat/test-nested_ifelse_linter.R

@@ -0,0 +1,58 @@
+test_that("nested_ifelse_linter skips allowed usages", {
+  expect_lint("if (TRUE) 1 else 2", NULL, nested_ifelse_linter())
+
+  expect_lint("ifelse(runif(10) > .2, 4, 6)", NULL, nested_ifelse_linter())
+
+  # don't block suggested alternatives
+  expect_lint("fcase(l1, v1, l2, v2)", NULL, nested_ifelse_linter())
+  expect_lint("case_when(l1 ~ v1, l2 ~ v2)", NULL, nested_ifelse_linter())
+})
+
+test_that("nested_ifelse_linter blocks simple disallowed usages", {
+  expect_lint(
+    "ifelse(l1, v1, ifelse(l2, v2, v3))",
+    rex::rex("Don't use nested ifelse() calls"),
+    nested_ifelse_linter()
+  )
+
+  expect_lint(
+    "ifelse(l1, ifelse(l2, v1, v2), v3)",
+    rex::rex("Don't use nested ifelse() calls"),
+    nested_ifelse_linter()
+  )
+})
+
+test_that("nested_ifelse_linter also catches dplyr::if_else", {
+  expect_lint(
+    "if_else(l1, v1, if_else(l2, v2, v3))",
+    rex::rex("Don't use nested if_else() calls"),
+    nested_ifelse_linter()
+  )
+
+  expect_lint(
+    "dplyr::if_else(l1, dplyr::if_else(l2, v1, v2), v3)",
+    rex::rex("Don't use nested if_else() calls"),
+    nested_ifelse_linter()
+  )
+})
+
+test_that("nested_ifelse_linter also catches data.table::fifelse", {
+  expect_lint(
+    "fifelse(l1, v1, fifelse(l2, v2, v3))",
+    rex::rex("Don't use nested fifelse() calls"),
+    nested_ifelse_linter()
+  )
+
+  expect_lint(
+    "data.table::fifelse(l1, v1, data.table::fifelse(l2, v2, v3))",
+    rex::rex("Don't use nested fifelse() calls"),
+    nested_ifelse_linter()
+  )
+
+  # not sure why anyone would do this, but the readability still argument holds
+  expect_lint(
+    "data.table::fifelse(l1, dplyr::if_else(l2, v1, v2), v3)",
+    rex::rex("Don't use nested if_else() calls"),
+    nested_ifelse_linter()
+  )
+})