Merge branch 'main' into todo-gh

.dev/roxygen_test.R

@@ -0,0 +1,54 @@
+# Test to ensure roxygenize() has been run on the current PR
+library(tools)
+library(roxygen2)
+
+old_dir <- file.path(tempdir(), "man")
+if (dir.exists(old_dir)) unlink(old_dir, recursive = TRUE)
+file.copy("man", tempdir(), recursive = TRUE)
+old_files <- list.files(old_dir, pattern = "\\.Rd$")
+new_dir <- "man"
+.Last <- function() unlink(old_dir, recursive = TRUE)
+
+# Rd2txt() prints to its out= argument, so we'd have to compare file contents;
+#   plain parse_Rd() keeps srcref info that encodes the file path, which as.character() strips.
+normalize_rd <- function(rd_file) as.character(parse_Rd(rd_file))
+
+rd_equal <- function(f1, f2) isTRUE(all.equal(normalize_rd(f1), normalize_rd(f2)))
+
+check_roxygenize_idempotent <- function(LOCALE) {
+  Sys.setlocale("LC_COLLATE", LOCALE)
+  roxygenize()
+
+  new_files <- list.files(new_dir, pattern = "\\.Rd$")
+
+  old_not_new <- setdiff(old_files, new_files)
+  if (length(old_not_new) > 0L) {
+    stop("Found saved .Rd files gone from a fresh run of roxygenize(): ", toString(old_not_new))
+  }
+
+  new_not_old <- setdiff(new_files, old_files)
+  if (length(new_not_old) > 0L) {
+    stop("Found new .Rd files from a fresh run of roxygenize(): ", toString(new_not_old))
+  }
+
+  for (file in new_files) {
+    old_file <- file.path(old_dir, file)
+    new_file <- file.path(new_dir, file)
+    if (rd_equal(old_file, new_file)) {
+      next
+    }
+    cat(sprintf("roxygenize() output differs from saved output for %s.\n", file))
+    cat("Here's the 'diff' comparison of the two files:\n")
+    cat("  [---]: saved output in man/ directory\n")
+    cat("  [+++]: roxygenize() output of R/ sources\n")
+    system2("diff", c("--unified", old_file, new_file))
+    stop("Failed in LOCALE=", LOCALE, ".", call. = FALSE)
+  }
+}
+
+# Run the check in a few locales to ensure there's no idempotency issues w.r.t. sorting, too
+for (LOCALE in c("C", "en_US", "hu_HU", "ja_JP")) {
+  check_roxygenize_idempotent(LOCALE)
+}
+
+unlink(old_dir, recursive = TRUE)

.github/workflows/ensure-metadata-tests.yaml → .github/workflows/repo-meta-tests.yaml

@@ -1,14 +1,14 @@
-# Ensure lint metadata is tested
+# Various repo-level tests for code quality
 on:
   push:
     branches: [main]
   pull_request:
     branches: [main]
 
-name: ensure-metadata-tests
+name: repo-meta-tests
 
 jobs:
-  ensure-metadata-tests:
+  repo-meta-tests:
     runs-on: ubuntu-latest
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
@@ -28,3 +28,8 @@ jobs:
           options(crayon.enabled = TRUE)
           callr::rscript(".dev/lint_metadata_test.R")
         shell: Rscript {0}
+
+      - name: Ensure roxygen content matches man directory
+        run: |
+          callr::rscript(".dev/roxygen_test.R")
+        shell: Rscript {0}

NEWS.md

@@ -22,7 +22,7 @@
 
 ## Changes to default linters
 
-* New default linter `return_linter()` for the style guide rule that terminal returns should be left implicit (#1100, #2354, and #2356, @MEO265 and @MichaelChirico).
+* New default linter `return_linter()` for the style guide rule that terminal returns should be left implicit (#1100, #2343, #2354, and #2356, @MEO265 and @MichaelChirico).
 
 ## New and improved features
 
@@ -62,7 +62,7 @@
 * `print_linter()` for discouraging usage of `print()` on string literals like `print("Reached here")` or `print(paste("Found", nrow(DF), "rows."))` (#1894, @MichaelChirico).
 * `unnecessary_nesting_linter()` for discouraging overly-nested code where an early return or eliminated sub-expression (inside '{') is preferable (#2317 and part of #884, @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).
+* `if_switch_linter()` for encouraging `switch()` over repeated `if`/`else` tests (#2322 and 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` (#2313, #2314 and part of #884, @MichaelChirico).
 * `pipe_return_linter()` for discouraging usage of `return()` inside a {magrittr} pipeline (part of #884, @MichaelChirico).

R/if_switch_linter.R

@@ -14,13 +14,77 @@
 #'   approach is roughly linear in the number of conditions that need to
 #'   be evaluated, here up to 3 times).
 #'
+#' @param max_branch_lines,max_branch_expressions Integer, default 0 indicates "no maximum".
+#'   If set any `if`/`else if`/.../`else` chain where any branch occupies more than
+#'   this number of lines (resp. expressions) will not be linted. The conjugate
+#'   applies to `switch()` statements -- if these parameters are set, any `switch()`
+#'   statement with any overly-complicated branches will be linted. See examples.
+#'
 #' @examples
 #' # will produce lints
 #' lint(
 #'   text = "if (x == 'a') 1 else if (x == 'b') 2 else 3",
 #'   linters = if_switch_linter()
 #' )
 #'
+#' code <- paste(
+#'   "if (x == 'a') {",
+#'   "  1",
+#'   "} else if (x == 'b') {",
+#'   "  2",
+#'   "} else if (x == 'c') {",
+#'   "  y <- x",
+#'   "  z <- sqrt(match(y, letters))",
+#'   "  z",
+#'   "}",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = if_switch_linter()
+#' )
+#'
+#' code <- paste(
+#'   "if (x == 'a') {",
+#'   "  1",
+#'   "} else if (x == 'b') {",
+#'   "  2",
+#'   "} else if (x == 'c') {",
+#'   "  y <- x",
+#'   "  z <- sqrt(",
+#'   "    match(y, letters)",
+#'   "  )",
+#'   "  z",
+#'   "}",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = if_switch_linter()
+#' )
+#'
+#' code <- paste(
+#'   "switch(x,",
+#'   "  a = {",
+#'   "    1",
+#'   "    2",
+#'   "    3",
+#'   "  },",
+#'   "  b = {",
+#'   "    1",
+#'   "    2",
+#'   "  }",
+#'   ")",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = if_switch_linter(max_branch_lines = 2L)
+#' )
+#'
 #' # okay
 #' lint(
 #'   text = "switch(x, a = 1, b = 2, 3)",
@@ -33,18 +97,105 @@
 #'   linters = if_switch_linter()
 #' )
 #'
+#' code <- paste(
+#'   "if (x == 'a') {",
+#'   "  1",
+#'   "} else if (x == 'b') {",
+#'   "  2",
+#'   "} else if (x == 'c') {",
+#'   "  y <- x",
+#'   "  z <- sqrt(match(y, letters))",
+#'   "  z",
+#'   "}",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = if_switch_linter(max_branch_lines = 2L)
+#' )
+#'
+#' code <- paste(
+#'   "if (x == 'a') {",
+#'   "  1",
+#'   "} else if (x == 'b') {",
+#'   "  2",
+#'   "} else if (x == 'c') {",
+#'   "  y <- x",
+#'   "  z <- sqrt(",
+#'   "    match(y, letters)",
+#'   "  )",
+#'   "  z",
+#'   "}",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = if_switch_linter(max_branch_expressions = 2L)
+#' )
+#'
+#' code <- paste(
+#'   "switch(x,",
+#'   "  a = {",
+#'   "    1",
+#'   "    2",
+#'   "    3",
+#'   "  },",
+#'   "  b = {",
+#'   "    1",
+#'   "    2",
+#'   "  }",
+#'   ")",
+#'   sep = "\n"
+#' )
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = if_switch_linter(max_branch_lines = 3L)
+#' )
+#'
 #' @evalRd rd_tags("if_switch_linter")
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
-if_switch_linter <- function() {
-  equal_str_cond <- "expr[1][EQ and expr[STR_CONST]]"
+if_switch_linter <- function(max_branch_lines = 0L, max_branch_expressions = 0L) {
+  equal_str_cond <- "expr[1][EQ and expr/STR_CONST]"
+
+  if (max_branch_lines > 0L || max_branch_expressions > 0L) {
+    complexity_cond <- xp_or(c(
+      if (max_branch_lines > 0L) paste("OP-RIGHT-BRACE/@line2 - OP-LEFT-BRACE/@line1 > 1 +", max_branch_lines),
+      if (max_branch_expressions > 0L) paste("count(expr) >", max_branch_expressions)
+    ))
+    branch_expr_cond <- xp_and(c(
+      xp_or(
+        # if (x) { <this expr> } ...
+        xp_and("preceding-sibling::IF", "position() = 2"),
+        # if (x) { ... } else { <this expr> }
+        xp_and("preceding-sibling::ELSE", "not(IF)")
+      ),
+      complexity_cond
+    ))
+    max_lines_cond <- glue(".//expr[{branch_expr_cond}]")
+
+    switch_xpath <- glue("
+    parent::expr
+      /parent::expr[expr[
+        position() > 2
+        and {complexity_cond}
+      ]]
+    ")
+  } else {
+    max_lines_cond <- "false"
+
+    switch_xpath <- NULL
+  }
 
   # NB: IF AND {...} AND ELSE/... implies >= 3 equality conditions are present
   # .//expr/IF/...: the expr in `==` that's _not_ the STR_CONST
   # not(preceding::IF): prevent nested matches which might be incorrect globally
   # not(. != .): don't match if there are _any_ expr which _don't_ match the top
   #   expr
-  xpath <- glue("
+  if_xpath <- glue("
   //IF
     /parent::expr[
       not(preceding-sibling::IF)
@@ -58,15 +209,16 @@ if_switch_linter <- function() {
         .//expr/IF/following-sibling::{equal_str_cond}/expr[not(STR_CONST)]
           != expr[1][EQ]/expr[not(STR_CONST)]
       )
+      and not({ max_lines_cond })
     ]
   ")
 
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
 
-    bad_expr <- xml_find_all(xml, xpath)
+    bad_expr <- xml_find_all(xml, if_xpath)
 
-    xml_nodes_to_lints(
+    lints <- xml_nodes_to_lints(
       bad_expr,
       source_expression = source_expression,
       lint_message = paste(
@@ -76,5 +228,19 @@ if_switch_linter <- function() {
       ),
       type = "warning"
     )
+
+    if (!is.null(switch_xpath)) {
+      xml_calls <- source_expression$xml_find_function_calls("switch")
+      switch_expr <- xml_find_all(xml_calls, switch_xpath)
+
+      lints <- c(lints, xml_nodes_to_lints(
+        switch_expr,
+        source_expression = source_expression,
+        lint_message = "Prefer repeated if/else statements over overly-complicated switch() statements.",
+        type = "warning"
+      ))
+    }
+
+    lints
   })
 }