New lengths_linter (#1568)

* New lengths_linter

* tag follow-up issue in comment

* fix doc issue by merging main & redoc

* merge & redoc

Co-authored-by: Indrajeet Patil <[email protected]>

DESCRIPTION

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

NAMESPACE

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

NEWS.md

@@ -28,6 +28,7 @@
   `lapply(x, function(xi) sum(xi))` can be `lapply(x, sum)` and `purrr::map(x, ~quantile(.x, 0.75, na.rm = TRUE))`
   can be `purrr::map(x, quantile, 0.75, na.rm = TRUE)`. Naming `probs = 0.75` can further improve readability.
 * `redundant_equals_linter()` for redundant comparisons to `TRUE` or `FALSE` like `is_treatment == TRUE` (#1500, @MichaelChirico)
+* `lengths_linter()` for encouraging usage of `lengths(x)` instead of `sapply(x, length)` (and similar)
 
 * `function_return_linter()` for handling issues in function `return()` statements. Currently handles assignments within the `return()`
   clause, e.g. `return(x <- foo())` (@MichaelChirico)

R/lengths_linter.R

@@ -0,0 +1,33 @@
+#' Require usage of `lengths()` where possible
+#'
+#' [lengths()] is a function that was added to base R in version 3.2.0 to
+#'   get the length of each element of a list. It is equivalent to
+#'   `sapply(x, length)`, but faster and more readable.
+#'
+#' @evalRd rd_tags("lengths_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+lengths_linter <- function() {
+  loop_funs <- c("sapply", "vapply", "map_int", "map_dbl")
+  xpath <- glue::glue("
+  //SYMBOL_FUNCTION_CALL[ {xp_text_in_table(loop_funs)} ]
+  /parent::expr/parent::expr[expr[position() = 3 and SYMBOL[text() = 'length']]]
+  ")
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = "Use lengths() to find the length of each element in a list.",
+      type = "warning"
+    )
+  })
+}

inst/lintr/linters.csv

@@ -34,6 +34,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
+lengths_linter,efficiency readability best_practices
 line_length_linter,style readability default configurable
 literal_coercion_linter,best_practices consistency efficiency
 missing_argument_linter,correctness common_mistakes configurable

tests/testthat/test-lengths_linter.R

@@ -0,0 +1,32 @@
+test_that("lengths_linter skips allowed usages", {
+  # TODO(#1570): also throw a lint here, and for map(x, length)
+  expect_lint("lapply(x, length)", NULL, lengths_linter())
+})
+
+test_that("lengths_linter blocks simple disallowed base usages", {
+  expect_lint(
+    "sapply(x, length)",
+    rex::rex("Use lengths() to find the length of each element in a list."),
+    lengths_linter()
+  )
+
+  expect_lint(
+    "vapply(x, length, integer(1L))",
+    rex::rex("Use lengths() to find the length of each element in a list."),
+    lengths_linter()
+  )
+})
+
+test_that("lengths_linter blocks simple disallowed purrr usages", {
+  expect_lint(
+    "purrr::map_dbl(x, length)",
+    rex::rex("Use lengths() to find the length of each element in a list."),
+    lengths_linter()
+  )
+
+  expect_lint(
+    "map_int(x, length)",
+    rex::rex("Use lengths() to find the length of each element in a list."),
+    lengths_linter()
+  )
+})