Merge branch 'main' into fix-pdf-issue

.Rbuildignore

@@ -23,6 +23,7 @@
 ^bench$
 ^tests/testthat/dummy_packages/package/[.]Rbuildignore$
 ^tests/testthat/dummy_packages/cp1252/[.]Rbuildignore$
+testthat-problems[.]rds$
 ^_pkgdown\.yaml$
 ^docs$
 ^pkgdown$

.github/workflows/pkgdown.yaml

@@ -39,7 +39,7 @@ jobs:
 
       - name: Deploy to GitHub pages 🚀
         if: github.event_name != 'pull_request'
-        uses: JamesIves/[email protected].8
+        uses: JamesIves/[email protected].9
         with:
           clean: false
           branch: gh-pages

NEWS.md

@@ -29,6 +29,7 @@
 * `.lintr` configs set by option `lintr.linter_file` or environment variable `R_LINTR_LINTER_FILE` can point to subdirectories (#2512, @MichaelChirico).
 * `indentation_linter()` returns `ranges[1L]==1L` when the offending line has 0 spaces (#2550, @MichaelChirico).
 * `literal_coercion_linter()` doesn't surface a warning about NAs during coercion for code like `as.integer("a")` (#2566, @MichaelChirico).
+* `commented_code_linter()` can detect commented code that ends with a pipe (#2671, @jcken95)
 
 ## Changes to default linters
 

R/class_equals_linter.R

@@ -48,9 +48,10 @@ class_equals_linter <- function() {
     bad_expr <- xml_find_all(xml_calls, xpath)
 
     operator <- xml_find_chr(bad_expr, "string(*[2])")
-    lint_message <- sprintf(
-      "Use inherits(x, 'class-name'), is.<class> or is(x, 'class') instead of comparing class(x) with %s.",
-      operator
+    lint_message <- paste0(
+      "Use inherits(x, 'class-name'), is.<class> for S3 classes, ",
+      "or is(x, 'S4Class') for S4 classes, ",
+      "instead of comparing class(x) with ", operator, "."
     )
     xml_nodes_to_lints(
       bad_expr,

R/commented_code_linter.R

@@ -83,9 +83,10 @@ commented_code_linter <- function() {
     all_comments <- xml_text(all_comment_nodes)
     code_candidates <- re_matches(all_comments, code_candidate_regex, global = FALSE, locations = TRUE)
     extracted_code <- code_candidates[, "code"]
-    # ignore trailing ',' when testing for parsability
-    extracted_code <- re_substitutes(extracted_code, rex(",", any_spaces, end), "")
+    # ignore trailing ',' or pipes ('|>', '%>%') when testing for parsability
+    extracted_code <- re_substitutes(extracted_code, rex(or(",", "|>", "%>%"), any_spaces, end), "")
     extracted_code <- re_substitutes(extracted_code, rex(start, any_spaces, ","), "")
+
     is_parsable <- which(vapply(extracted_code, parsable, logical(1L)))
 
     lint_list <- xml_nodes_to_lints(

R/extract.R

@@ -9,7 +9,7 @@ extract_r_source <- function(filename, lines, error = identity) {
   output <- rep.int(NA_character_, length(lines))
 
   chunks <- tryCatch(get_chunk_positions(pattern = pattern, lines = lines), error = error)
-  if (inherits(chunks, "error") || inherits(chunks, "lint")) {
+  if (is_error(chunks) || is_lint(chunks)) {
     assign("e", chunks, envir = parent.frame())
     # error, so return empty code
     return(output)

R/get_source_expressions.R

@@ -86,7 +86,7 @@ get_source_expressions <- function(filename, lines = NULL) {
   source_expression$content <- get_content(source_expression$lines)
   parsed_content <- get_source_expression(source_expression, error = function(e) lint_parse_error(e, source_expression))
 
-  if (inherits(e, "lint") && (is.na(e$line) || !nzchar(e$line) || e$message == "unexpected end of input")) {
+  if (is_lint(e) && (is.na(e$line) || !nzchar(e$line) || e$message == "unexpected end of input")) {
     # Don't create expression list if it's unreliable (invalid encoding or unhandled parse error)
     expressions <- list()
   } else {
@@ -502,7 +502,7 @@ get_source_expression <- function(source_expression, error = identity) {
     error = error
   )
 
-  if (inherits(parsed_content, c("error", "lint"))) {
+  if (is_error(parsed_content) || is_lint(parsed_content)) {
     assign("e", parsed_content, envir = parent.frame())
     parse_error <- TRUE
   }
@@ -513,7 +513,7 @@ get_source_expression <- function(source_expression, error = identity) {
     error = error
   )
 
-  if (inherits(parsed_content, c("error", "lint"))) {
+  if (is_error(parsed_content) || is_lint(parsed_content)) {
     # Let parse errors take precedence over encoding problems
     if (!parse_error) assign("e", parsed_content, envir = parent.frame())
     return() # parsed_content is unreliable if encoding is invalid

R/lint.R

@@ -696,7 +696,7 @@ maybe_report_progress <- function(pb) {
 }
 
 maybe_append_error_lint <- function(lints, error, lint_cache, filename) {
-  if (inherits(error, "lint")) {
+  if (is_lint(error)) {
     error$linter <- "error"
     lints[[length(lints) + 1L]] <- error
 

R/utils.R

@@ -245,9 +245,12 @@ get_r_string <- function(s, xpath = NULL) {
 }
 
 is_linter <- function(x) inherits(x, "linter")
+is_lint <- function(x) inherits(x, "lint")
+
+is_error <- function(x) inherits(x, "error")
 
 is_tainted <- function(lines) {
-  inherits(tryCatch(nchar(lines), error = identity), "error")
+  is_error(tryCatch(nchar(lines), error = identity))
 }
 
 #' Check that the entries in ... are valid

tests/testthat/test-class_equals_linter.R

@@ -11,7 +11,7 @@ test_that("class_equals_linter skips allowed usages", {
 
 test_that("class_equals_linter blocks simple disallowed usages", {
   linter <- class_equals_linter()
-  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> or is(x, 'class')")
+  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> for S3 classes, or is(x, 'S4Class') for S4 classes")
 
   expect_lint("if (class(x) == 'character') stop('no')", lint_msg, linter)
   expect_lint("is_regression <- class(x) == 'lm'", lint_msg, linter)
@@ -20,7 +20,7 @@ test_that("class_equals_linter blocks simple disallowed usages", {
 
 test_that("class_equals_linter blocks usage of %in% for checking class", {
   linter <- class_equals_linter()
-  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> or is(x, 'class')")
+  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> for S3 classes, or is(x, 'S4Class') for S4 classes")
 
   expect_lint("if ('character' %in% class(x)) stop('no')", lint_msg, linter)
   expect_lint("if (class(x) %in% 'character') stop('no')", lint_msg, linter)
@@ -29,7 +29,7 @@ test_that("class_equals_linter blocks usage of %in% for checking class", {
 test_that("class_equals_linter blocks class(x) != 'klass'", {
   expect_lint(
     "if (class(x) != 'character') TRUE",
-    rex::rex("Use inherits(x, 'class-name'), is.<class> or is(x, 'class')"),
+    rex::rex("Use inherits(x, 'class-name'), is.<class> for S3 classes, or is(x, 'S4Class') for S4 classes"),
     class_equals_linter()
   )
 })
@@ -43,13 +43,13 @@ test_that("class_equals_linter skips usage for subsetting", {
   # but not further nesting
   expect_lint(
     "x[if (class(x) == 'foo') 1 else 2]",
-    rex::rex("Use inherits(x, 'class-name'), is.<class> or is(x, 'class')"),
+    rex::rex("Use inherits(x, 'class-name'), is.<class> for S3 classes, or is(x, 'S4Class') for S4 classes"),
     linter
   )
 })
 
 test_that("lints vectorize", {
-  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> or is(x, 'class')")
+  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> for S3 classes, or is(x, 'S4Class') for S4 classes")
 
   expect_lint(
     trim_some("{

tests/testthat/test-commented_code_linter.R

@@ -103,3 +103,13 @@ test_that("commented_code_linter can detect operators in comments and lint corre
     commented_code_linter()
   )
 })
+
+test_that("commented_code_linter can detect commented code ending with pipes", {
+  linter <- commented_code_linter()
+  lint_msg <- rex::rex("Remove commented code.")
+
+  expect_lint("# f() %>%", lint_msg, linter)
+
+  skip_if_not_r_version("4.1.0")
+  expect_lint("# f() |>", lint_msg, linter)
+})