Merge branch 'main' into library_call

.lintr_new

@@ -2,7 +2,7 @@ linters: linters_with_defaults(
     any_duplicated_linter(),
     any_is_na_linter(),
     backport_linter("oldrel-4", except = c("R_user_dir", "str2lang", "str2expression", "deparse1")),
-    consecutive_stopifnot_linter(),
+    consecutive_assertion_linter(),
     expect_comparison_linter(),
     expect_length_linter(),
     expect_named_linter(),

NEWS.md

@@ -4,6 +4,10 @@
 
 * `inner_combine_linter()` no longer throws on length-1 calls to `c()` like `c(exp(2))` or `c(log(3))` (#2017, @MichaelChirico). Such usage is discouraged by `unnecessary_concatenation_linter()`, but `inner_combine_linter()` _per se_ does not apply.
 
+## Changes to defaults
+
+* `assignment_linter()` lints the {magrittr} assignment pipe `%<>%` (#2008, @MichaelChirico). This can be deactivated by setting the new argument `allow_pipe_assign` to `TRUE`.
+
 # lintr 3.1.0
 
 ## Deprecations & Breaking Changes

R/assignment_linter.R

@@ -6,6 +6,7 @@
 #'   If `FALSE`, [`<<-`][base::assignOps] and `->>` are not allowed.
 #' @param allow_right_assign Logical, default `FALSE`. If `TRUE`, `->` and `->>` are allowed.
 #' @param allow_trailing Logical, default `TRUE`. If `FALSE` then assignments aren't allowed at end of lines.
+#' @param allow_pipe_assign Logical, default `FALSE`. If `TRUE`, magrittr's `%<>%` assignment is allowed.
 #'
 #' @examples
 #' # will produce lints
@@ -21,6 +22,11 @@
 #'   linters = assignment_linter()
 #' )
 #'
+#' lint(
+#'   text = "x %<>% as.character()",
+#'   linters = assignment_linter()
+#' )
+#'
 #' # okay
 #' lint(
 #'   text = "x <- mean(x)",
@@ -53,19 +59,29 @@
 #'   linters = assignment_linter(allow_trailing = FALSE)
 #' )
 #'
+#' lint(
+#'   text = "x %<>% as.character()",
+#'   linters = assignment_linter(allow_pipe_assign = TRUE)
+#' )
+#'
 #' @evalRd rd_tags("assignment_linter")
 #' @seealso
 #' - [linters] for a complete list of linters available in lintr.
 #' - <https://style.tidyverse.org/syntax.html#assignment-1>
+#' - <https://style.tidyverse.org/pipes.html#assignment-2>
 #' @export
-assignment_linter <- function(allow_cascading_assign = TRUE, allow_right_assign = FALSE, allow_trailing = TRUE) {
+assignment_linter <- function(allow_cascading_assign = TRUE,
+                              allow_right_assign = FALSE,
+                              allow_trailing = TRUE,
+                              allow_pipe_assign = FALSE) {
   trailing_assign_xpath <- paste(
     collapse = " | ",
     c(
       paste0("//LEFT_ASSIGN", if (allow_cascading_assign) "" else "[text() = '<-']"),
       if (allow_right_assign) paste0("//RIGHT_ASSIGN", if (allow_cascading_assign) "" else "[text() = '->']"),
       "//EQ_SUB",
-      "//EQ_FORMALS"
+      "//EQ_FORMALS",
+      if (!allow_pipe_assign) "//SPECIAL[text() = '%<>%']"
     ),
     "[@line1 < following-sibling::expr[1]/@line1]"
   )
@@ -79,7 +95,8 @@ assignment_linter <- function(allow_cascading_assign = TRUE, allow_right_assign
     # NB: := is not linted because of (1) its common usage in rlang/data.table and
     #   (2) it's extremely uncommon as a normal assignment operator
     if (!allow_cascading_assign) "//LEFT_ASSIGN[text() = '<<-']",
-    if (!allow_trailing) trailing_assign_xpath
+    if (!allow_trailing) trailing_assign_xpath,
+    if (!allow_pipe_assign) "//SPECIAL[text() = '%<>%']"
   ))
 
   Linter(function(source_expression) {
@@ -95,16 +112,16 @@ assignment_linter <- function(allow_cascading_assign = TRUE, allow_right_assign
     }
 
     operator <- xml2::xml_text(bad_expr)
-    lint_message_fmt <- ifelse(
-      operator %in% c("<<-", "->>"),
-      "%s can have hard-to-predict behavior; prefer assigning to a specific environment instead (with assign() or <-).",
-      "Use <-, not %s, for assignment."
-    )
+    lint_message_fmt <- rep("Use <-, not %s, for assignment.", length(operator))
+    lint_message_fmt[operator %in% c("<<-", "->>")] <-
+      "%s can have hard-to-predict behavior; prefer assigning to a specific environment instead (with assign() or <-)."
+    lint_message_fmt[operator == "%<>%"] <-
+      "Avoid the assignment pipe %s; prefer using <- and %%>%% separately."
 
     if (!allow_trailing) {
       bad_trailing_expr <- xml2::xml_find_all(xml, trailing_assign_xpath)
       trailing_assignments <- xml2::xml_attrs(bad_expr) %in% xml2::xml_attrs(bad_trailing_expr)
-      lint_message_fmt[trailing_assignments] <- "Assignment %s should not be trailing at end of line"
+      lint_message_fmt[trailing_assignments] <- "Assignment %s should not be trailing at the end of a line."
     }
 
     lint_message <- sprintf(lint_message_fmt, operator)

R/make_linter_from_regex.R

@@ -1,73 +1,53 @@
 make_linter_from_regex <- function(regex,
                                    lint_type,
-                                   lint_msg,
-                                   ignore_strings = TRUE) {
-  # If a regex-based linter is found, only flag those lints that occur within
-  # a relevant section of source code
-  .in_ignorable_position <- function(source_expression, line_number, match) {
-    ignore_strings && in_string(source_expression, line_number, match)
-  }
-
+                                   lint_msg) {
   function() {
     Linter(function(source_expression) {
-      if (!is_lint_level(source_expression, "expression")) {
+      if (!is_lint_level(source_expression, "file")) {
         return(list())
       }
 
       all_matches <- re_matches(
-        source_expression[["lines"]],
+        source_expression[["file_lines"]],
         regex,
         locations = TRUE,
-        global = TRUE
+        global = FALSE
       )
+      all_matches <- all_matches[!is.na(all_matches$start), ]
+      all_matches$line_number <- as.integer(rownames(all_matches))
 
-      line_numbers <- as.integer(names(source_expression[["lines"]]))
-
-      lints <- Map(
-        function(line_matches, line_number) {
-          lapply(
-            split(line_matches, seq_len(nrow(line_matches))),
-            function(.match) {
-              if (
-                is.na(.match[["start"]]) ||
-                  .in_ignorable_position(source_expression, line_number, .match)
-              ) {
-                return()
-              }
-              start <- .match[["start"]]
-              end <- .match[["end"]]
-              Lint(
-                filename = source_expression[["filename"]],
-                line_number = line_number,
-                column_number = start,
-                type = lint_type,
-                message = lint_msg,
-                line = source_expression[["lines"]][[as.character(line_number)]],
-                ranges = list(c(start, end))
-              )
-            }
-          )
-        },
-        all_matches,
-        line_numbers
-      )
+      matches_by_row <- split(all_matches, seq_len(nrow(all_matches)))
 
-      Filter(function(x) any(lengths(x) > 0L), lints)
+      lints <- lapply(matches_by_row, function(.match) {
+        if (is_match_covered(.match, source_expression)) {
+          return()
+        }
+        Lint(
+          filename = source_expression[["filename"]],
+          line_number = .match$line_number,
+          type = lint_type,
+          message = lint_msg,
+          line = source_expression[["file_lines"]][[rownames(.match)]],
+          ranges = list(c(.match$start, .match$end))
+        )
+      })
+      lints[lengths(lints) > 0L]
     })
   }
 }
 
 #' Determine if a regex match is covered by an expression in a source_expression
 #'
+#' @param   match   The position where a regex match was observed.
+#'   match must have entries "start", "end", and "line_number".
 #' @param   source_expression   A source_expression
-#' @param   line_number,match   The position where a regex match was observed.
-#'   match must have entries "start" and "end".
 #' @param   token_type    Restrict analysis to tokens of this type, for example,
 #'   with token_type = "STR_CONST" you can check that a regex match occurs
 #'   within a string
 #' @noRd
-is_match_covered <- function(source_expression, line_number, match, token_type = NULL) {
-  pc <- source_expression[["parsed_content"]]
+is_match_covered <- function(match, source_expression, token_type = "STR_CONST") {
+  line_number <- match$line_number
+  pc <- source_expression[["full_parsed_content"]]
   if (!is.null(token_type)) {
     pc <- pc[pc[["token"]] == token_type, ]
   }
@@ -92,9 +72,3 @@ is_match_covered <- function(source_expression, line_number, match, token_type =
 
   any_single_line_covers() || any_multi_line_covers()
 }
-
-in_string <- function(source_expression, line_number, match) {
-  # do any of the strings in the parsed content contain the matched regex?
-
-  is_match_covered(source_expression, line_number, match, "STR_CONST")
-}

tests/testthat/test-assignment_linter.R

@@ -55,7 +55,7 @@ test_that("arguments handle trailing assignment operators correctly", {
 
   expect_lint(
     "foo(bar =\n1)",
-    rex::rex("= should not be trailing"),
+    rex::rex("= should not be trailing at the end of a line."),
     assignment_linter(allow_trailing = FALSE)
   )
 
@@ -163,3 +163,24 @@ test_that("allow_trailing interacts correctly with comments in braced expression
     linter
   )
 })
+
+test_that("%<>% throws a lint", {
+  expect_lint("x %<>% sum()", "Avoid the assignment pipe %<>%", assignment_linter())
+  expect_lint("x %<>% sum()", NULL, assignment_linter(allow_pipe_assign = TRUE))
+
+  # interaction with allow_trailing
+  expect_lint("x %<>%\n  sum()", "Assignment %<>% should not be trailing", assignment_linter(allow_trailing = FALSE))
+})
+
+test_that("multiple lints throw correct messages", {
+  expect_lint(
+    "{ x <<- 1; y ->> 2; z -> 3; x %<>% as.character() }",
+    list(
+      list(message = "<<- can have hard-to-predict behavior"),
+      list(message = "->> can have hard-to-predict behavior"),
+      list(message = "Use <-, not ->"),
+      list(message = "Avoid the assignment pipe %<>%")
+    ),
+    assignment_linter(allow_cascading_assign = FALSE)
+  )
+})