Merge branch 'main' into inner_comparison

Author: MichaelChirico

DESCRIPTION

@@ -81,6 +81,7 @@ Collate:
     'condition_message_linter.R'
     'conjunct_test_linter.R'
     'consecutive_assertion_linter.R'
+    'consecutive_mutate_linter.R'
     'cyclocomp_linter.R'
     'declared_functions.R'
     'deprecated.R'

NAMESPACE

@@ -40,6 +40,7 @@ export(comparison_negation_linter)
 export(condition_message_linter)
 export(conjunct_test_linter)
 export(consecutive_assertion_linter)
+export(consecutive_mutate_linter)
 export(consecutive_stopifnot_linter)
 export(cyclocomp_linter)
 export(default_linters)

NEWS.md

@@ -34,6 +34,7 @@
 * `which_grepl_linter()` for discouraging `which(grepl(ptn, x))` in favor of directly using `grep(ptn, x)` (part of #884, @MichaelChirico).
 * `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).
+* `consecutive_mutate_linter()` for encouraging consecutive calls to `dplyr::mutate()` to be combined (part of #884, @MichaelChirico).
 * `if_switch_linter()` for encouraging `switch()` over repeated `if`/`else` tests (part of #884, @MichaelChirico).
 * `nested_pipe_linter()` for discouraging pipes within pipes, e.g. `df1 %>% inner_join(df2 %>% select(a, b))` (part of #884, @MichaelChirico).
 * `nrow_subset_linter()` for discouraging usage like `nrow(subset(x, conditions))` in favor of something like `with(x, sum(conditions))` which doesn't require a full subset of `x` (part of #884, @MichaelChirico).

R/any_duplicated_linter.R

@@ -113,6 +113,6 @@ any_duplicated_linter <- function() {
       type = "warning"
     )
 
-    return(c(any_duplicated_lints, length_unique_lints))
+    c(any_duplicated_lints, length_unique_lints)
   })
 }

R/comments.R

@@ -42,7 +42,7 @@ jenkins_build_info <- function() {
 }
 
 in_travis <- function() {
-  return(nzchar(Sys.getenv("TRAVIS_REPO_SLUG")))
+  nzchar(Sys.getenv("TRAVIS_REPO_SLUG"))
 }
 
 travis_build_info <- function() {
@@ -59,7 +59,7 @@ travis_build_info <- function() {
 }
 
 in_wercker <- function() {
-  return(nzchar(Sys.getenv("WERCKER_GIT_BRANCH")))
+  nzchar(Sys.getenv("WERCKER_GIT_BRANCH"))
 }
 
 ci_build_info <- function() {

R/consecutive_mutate_linter.R

@@ -0,0 +1,101 @@
+#' Require consecutive calls to mutate() to be combined when possible
+#'
+#' `dplyr::mutate()` accepts any number of columns, so sequences like
+#'   `DF %>% dplyr::mutate(..1) %>% dplyr::mutate(..2)` are redundant --
+#'   they can always be expressed with a single call to `dplyr::mutate()`.
+#'
+#' An exception is for some SQL back-ends, where the translation logic may not be
+#'   as sophisticated as that in the default `dplyr`, for example in
+#'   `DF %>% mutate(a = a + 1) %>% mutate(b = a - 2)`.
+#'
+#' @param invalid_backends Character vector of packages providing dplyr backends
+#'   which may not be compatible with combining `mutate()` calls in all cases.
+#'   Defaults to `"dbplyr"` since not all SQL backends can handle re-using
+#'   a variable defined in the same `mutate()` expression.
+#'
+#' @examples
+#' # will produce lints
+#' lint(
+#'   text = "x %>% mutate(a = 1) %>% mutate(b = 2)",
+#'   linters = consecutive_mutate_linter()
+#' )
+#'
+#' # okay
+#' lint(
+#'   text = "x %>% mutate(a = 1, b = 2)",
+#'   linters = consecutive_mutate_linter()
+#' )
+#'
+#' code <- "library(dbplyr)\nx %>% mutate(a = 1) %>% mutate(a = a + 1)"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = consecutive_mutate_linter()
+#' )
+#'
+#' @evalRd rd_tags("consecutive_mutate_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+consecutive_mutate_linter <- function(invalid_backends = "dbplyr") {
+  attach_pkg_xpath <- glue("
+  //SYMBOL_FUNCTION_CALL[text() = 'library' or text() = 'require']
+    /parent::expr
+    /following-sibling::expr
+    /*[self::SYMBOL or self::STR_CONST]
+  ")
+
+  namespace_xpath <- glue("
+  //SYMBOL_PACKAGE[{ xp_text_in_table(invalid_backends) }]
+  |
+  //COMMENT[
+    contains(text(), '@import')
+    and (
+      {xp_or(sprintf(\"contains(text(), '%s')\", invalid_backends))}
+    )
+  ]
+  ")
+
+  # match on the expr, not the SYMBOL_FUNCTION_CALL, to ensure
+  #   namespace-qualified calls only match if the namespaces do.
+  # expr[2] needed in expr[1][expr[2]] to skip matches on pipelines
+  #   starting like mutate(DF, ...) %>% foo() %>% mutate().
+  # similarly, expr[1][expr[call='mutate']] covers pipelines
+  #   starting like mutate(DF, ...) %>% mutate(...)
+  mutate_cond <- xp_and(
+    "expr/SYMBOL_FUNCTION_CALL[text() = 'mutate']",
+    "not(SYMBOL_SUB[text() = '.keep' or text() = '.by'])"
+  )
+  xpath <- glue("
+  (//PIPE | //SPECIAL[{ xp_text_in_table(magrittr_pipes) }])
+    /preceding-sibling::expr[expr[2][{ mutate_cond }] or ({ mutate_cond })]
+    /following-sibling::expr[{ mutate_cond }]
+  ")
+
+  Linter(function(source_expression) {
+    # need the full file to also catch usages at the top level
+    if (!is_lint_level(source_expression, "file")) {
+      return(list())
+    }
+
+    xml <- source_expression$full_xml_parsed_content
+
+    attach_str <- get_r_string(xml_find_all(xml, attach_pkg_xpath))
+    if (any(invalid_backends %in% attach_str)) {
+      return(list())
+    }
+
+    namespace_expr <- xml_find_first(xml, namespace_xpath)
+    if (!is.na(namespace_expr)) {
+      return(list())
+    }
+
+    bad_expr <- xml_find_all(xml, xpath)
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = "Unify consecutive calls to mutate().",
+      type = "warning"
+    )
+  })
+}

R/inner_combine_linter.R

@@ -112,7 +112,7 @@ arg_match_condition <- function(arg) {
   this_symbol <- sprintf("SYMBOL_SUB[text() = '%s']", arg)
   following_symbol <- sprintf("following-sibling::expr/%s", this_symbol)
   next_expr <- "following-sibling::expr[1]"
-  return(xp_or(
+  xp_or(
     sprintf("not(%s) and not(%s)", this_symbol, following_symbol),
     xp_and(
       this_symbol,
@@ -122,7 +122,7 @@ arg_match_condition <- function(arg) {
         this_symbol, following_symbol, next_expr
       )
     )
-  ))
+  )
 }
 
 build_arg_condition <- function(calls, arguments) {

R/package_hooks_linter.R

@@ -183,13 +183,13 @@ package_hooks_linter <- function() {
     unload_arg_name_lints <-
       xml_nodes_to_lints(unload_arg_name_expr, source_expression, unload_arg_name_message, type = "warning")
 
-    return(c(
+    c(
       onload_bad_msg_call_lints,
       onattach_bad_msg_call_lints,
       load_arg_name_lints,
       library_require_lints,
       bad_unload_call_lints,
       unload_arg_name_lints
-    ))
+    )
   })
 }

R/redundant_ifelse_linter.R

@@ -108,6 +108,6 @@ redundant_ifelse_linter <- function(allow10 = FALSE) {
       lints <- c(lints, xml_nodes_to_lints(num_expr, source_expression, lint_message, type = "warning"))
     }
 
-    return(lints)
+    lints
   })
 }

R/regex_subset_linter.R

@@ -94,6 +94,6 @@ regex_subset_linter <- function() {
       type = "warning"
     )
 
-    return(c(grep_lints, stringr_lints))
+    c(grep_lints, stringr_lints)
   })
 }

R/scalar_in_linter.R

@@ -37,7 +37,7 @@ scalar_in_linter <- function() {
     /parent::expr
   "
 
-  return(Linter(function(source_expression) {
+  Linter(function(source_expression) {
     if (!is_lint_level(source_expression, "expression")) {
       return(list())
     }
@@ -55,5 +55,5 @@ scalar_in_linter <- function() {
       lint_message = lint_msg,
       type = "warning"
     )
-  }))
+  })
 }

R/xp_utils.R

@@ -11,7 +11,7 @@ xp_text_in_table <- function(table) {
   single_quoted <- grepl("'", table, fixed = TRUE)
   table[single_quoted] <- sQuote(table[single_quoted], '"')
   table[!single_quoted] <- sQuote(table[!single_quoted], "'")
-  return(paste0("text() = ", table, collapse = " or "))
+  paste0("text() = ", table, collapse = " or ")
 }
 
 paren_wrap <- function(..., sep) {

inst/lintr/linters.csv

@@ -14,6 +14,7 @@ comparison_negation_linter,readability consistency
 condition_message_linter,best_practices consistency
 conjunct_test_linter,package_development best_practices readability configurable pkg_testthat
 consecutive_assertion_linter,style readability consistency
+consecutive_mutate_linter,consistency readability configurable efficiency
 consecutive_stopifnot_linter,style readability consistency deprecated
 cyclocomp_linter,style readability best_practices default configurable
 duplicate_argument_linter,correctness common_mistakes configurable