Merge 44c82d9 into f61967b

DESCRIPTION

@@ -128,6 +128,7 @@ Collate:
     'linter_tags.R'
     'lintr-deprecated.R'
     'lintr-package.R'
+    'list_comparison_linter.R'
     'literal_coercion_linter.R'
     'make_linter_from_regex.R'
     'matrix_apply_linter.R'

NAMESPACE

@@ -90,6 +90,7 @@ export(lint_dir)
 export(lint_package)
 export(linters_with_defaults)
 export(linters_with_tags)
+export(list_comparison_linter)
 export(literal_coercion_linter)
 export(make_linter_from_xpath)
 export(matrix_apply_linter)

NEWS.md

@@ -26,6 +26,7 @@
 * `stopifnot_all_linter()` discourages tests with `all()` like `stopifnot(all(x > 0))`; `stopifnot()` runs `all()` itself, and uses a better error message (part of #884, @MichaelChirico).
 * `comparison_negation_linter()` for discouraging negated comparisons when a direct negation is preferable, e.g. `!(x == y)` could be `x != y` (part of #884, @MichaelChirico).
 * `terminal_close_linter()` for discouraging using `close()` to end functions (part of #884, @MichaelChirico). Such usages are not robust to errors, where `close()` will not be run as intended. Put `close()` in an `on.exit()` hook, or use {withr} to manage connections with proper cleanup.
+* `list_comparison_linter()` for discouraging comparisons on the output of `lapply()`, e.g. `lapply(x, sum) > 10` (part of #884, @MichaelChirico).
 * `print_linter()` for discouraging usage of `print()` on string literals like `print("Reached here")` or `print(paste("Found", nrow(DF), "rows."))` (#1894, @MichaelChirico).
 
 ### Lint accuracy fixes: removing false positives

R/list_comparison_linter.R

@@ -0,0 +1,70 @@
+#' Block usage of comparison operators with known-list() functions like lapply
+#'
+#' Usage like `lapply(x, sum) > 10` is awkward because the list must first
+#'   be coerced to a vector for comparison. A function like [vapply()]
+#'   should be preferred.
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "lapply(x, sum) > 10",
+#'   linters = list_comparison_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "unlist(lapply(x, sum)) > 10",
+#'   linters = list_comparison_linter()
+#' )
+#'
+#' @evalRd rd_tags("list_comparison_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+list_comparison_linter <- function() {
+  # TODO(michaelchirico): extend to cases where using simplify=FALSE implies a
+  #   list output, e.g. with sapply, replicate, mapply.
+  list_mapper_alternatives <- c(
+    lapply = "vapply(x, FUN, character(1L))",
+    map = "map_chr(x, FUN)",
+    Map = "mapply()",
+    .mapply = "mapply()"
+  )
+
+  # NB: anchor to the comparison expr so that we can easily include the comparator
+  #   in the lint message.
+  xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[{ xp_text_in_table(names(list_mapper_alternatives)) }]
+    /parent::expr
+    /parent::expr
+    /parent::expr[{ xp_or(infix_metadata$xml_tag[infix_metadata$comparator]) }]
+  ")
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    bad_expr <- xml_find_all(xml, xpath)
+
+    list_mapper <- xp_call_name(bad_expr, depth = 2L)
+
+    vector_mapper <- list_mapper_alternatives[list_mapper]
+    # we are at `x ? y` in which the comparator ? comes 2nd
+    comparator <- xml_find_chr(bad_expr, "string(*[2])")
+
+    lint_message <- as.character(glue(
+      "The output of {list_mapper}(), a list(), is being ",
+      "coerced for comparison by `{comparator}`. ",
+      "Instead, use a mapper that generates a vector with the correct type ",
+      "directly, for example {vector_mapper} if the output is a string."
+    ))
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = lint_message,
+      type = "warning"
+    )
+  })
+}

inst/lintr/linters.csv

@@ -49,6 +49,7 @@ length_test_linter,common_mistakes efficiency
 lengths_linter,efficiency readability best_practices
 library_call_linter,style best_practices readability configurable
 line_length_linter,style readability default configurable
+list_comparison_linter,best_practices common_mistakes efficiency
 literal_coercion_linter,best_practices consistency efficiency
 matrix_apply_linter,readability efficiency
 missing_argument_linter,correctness common_mistakes configurable

tests/testthat/test-list_comparison_linter.R

@@ -0,0 +1,34 @@
+test_that("list_comparison_linter skips allowed usages", {
+  expect_lint("sapply(x, sum) > 10", NULL, list_comparison_linter())
+})
+
+local({
+  linter <- list_comparison_linter()
+  lint_msg <- rex::rex("a list(), is being coerced for comparison")
+
+  cases <- expand.grid(
+    list_mapper = c("lapply", "map", "Map", ".mapply"),
+    comparator = c("==", "!=", ">=", "<=", ">", "<")
+  )
+  cases$.test_name <- with(cases, paste(list_mapper, comparator))
+  patrick::with_parameters_test_that(
+    "list_comparison_linter blocks simple disallowed usages",
+    expect_lint(sprintf("%s(x, sum) %s 10", list_mapper, comparator), lint_msg, linter),
+    .cases = cases
+  )
+})
+
+test_that("list_comparison_linter vectorizes", {
+  expect_lint(
+    trim_some("{
+      sapply(x, sum) > 10
+      .mapply(`+`, list(1:10, 1:10), NULL) == 2
+      lapply(x, sum) < 5
+    }"),
+    list(
+      list(rex::rex(".mapply()", anything, "`==`"), line_number = 3L),
+      list(rex::rex("lapply()", anything, "`<`"), line_number = 4L)
+    ),
+    list_comparison_linter()
+  )
+})