Merge branch 'main' into rm-xml-missing-tests

.dev/lint_metadata_test.R

@@ -0,0 +1,54 @@
+# This script is designed to find linters that lack metadata tests.
+#   To do so, it forces Lint() to give the wrong information,
+#   runs the test suite, and finds linters that nevertheless pass all their tests.
+library(testthat)
+
+lint_file <- "R/lint.R"
+
+original <- readLines(lint_file)
+expected_line <- "line_number = as.integer(line_number)"
+if (sum(grepl(expected_line, original, fixed = TRUE)) != 1L) {
+  stop(sprintf(
+    "Please update this workflow -- need exactly one hit for line '%s' in file '%s'.",
+    expected_line, lint_file
+  ))
+}
+writeLines(
+  sub(expected_line, "line_number = as.integer(2^31 - 1)", original, fixed = TRUE),
+  lint_file
+)
+# Not useful in CI but good when running locally.
+withr::defer({
+  writeLines(original, lint_file)
+  pkgload::load_all()
+})
+
+pkgload::load_all()
+
+report <- test_dir(
+  "tests/testthat",
+  filter = "linter$",
+  stop_on_failure = FALSE,
+  reporter = SilentReporter$new()
+)
+names(report) <- gsub("^test-|\\.R$", "", vapply(report, `[[`, "file", FUN.VALUE = character(1L)))
+
+# Hack the nested structure of the testthat report to identify which files have
+#   any failed test
+failed <- report |>
+  vapply(
+    \(x) any(vapply(x$results, inherits, "expectation_failure", FUN.VALUE = logical(1L))),
+    logical(1L)
+  ) |>
+  which() |>
+  names() |>
+  unique()
+
+passed <- setdiff(
+  available_linters(tags = NULL)$linter,
+  failed
+)
+
+if (length(passed) > 0L) {
+  stop("Please add tests of lint metadata for the following linters: ", toString(passed))
+}

.github/workflows/ensure-metadata-tests.yaml

@@ -0,0 +1,30 @@
+# Ensure lint metadata is tested
+on:
+  push:
+    branches: [main]
+  pull_request:
+    branches: [main]
+
+name: ensure-metadata-tests
+
+jobs:
+  ensure-metadata-tests:
+    runs-on: ubuntu-latest
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: "release"
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+
+      - name: Ensure lint metadata is tested
+        run: |
+          options(crayon.enabled = TRUE)
+          callr::rscript(".dev/lint_metadata_test.R")
+        shell: Rscript {0}

tests/testthat/test-absolute_path_linter.R

@@ -185,3 +185,22 @@ test_that("raw strings are handled correctly", {
     absolute_path_linter(lax = FALSE)
   )
 })
+
+test_that("lints vectorize", {
+  lint_msg <- rex::rex("Do not use absolute paths.")
+
+  expect_lint(
+    trim_some("{
+      '/'
+      '/blah/file.txt'
+      'abcdefg'
+      '~'
+    }"),
+    list(
+      list(lint_msg, line_number = 2L),
+      list(lint_msg, line_number = 3L),
+      list(lint_msg, line_number = 5L)
+    ),
+    absolute_path_linter(lax = FALSE)
+  )
+})

tests/testthat/test-any_duplicated_linter.R

@@ -10,112 +10,77 @@ test_that("any_duplicated_linter skips allowed usages", {
 })
 
 test_that("any_duplicated_linter blocks simple disallowed usages", {
-  expect_lint(
-    "any(duplicated(x))",
-    rex::rex("anyDuplicated(x, ...) > 0 is better"),
-    any_duplicated_linter()
-  )
-
-  expect_lint(
-    "any(duplicated(foo(x)))",
-    rex::rex("anyDuplicated(x, ...) > 0 is better"),
-    any_duplicated_linter()
-  )
+  linter <- any_duplicated_linter()
+  lint_msg <- rex::rex("anyDuplicated(x, ...) > 0 is better")
 
+  expect_lint("any(duplicated(x))", lint_msg, linter)
+  expect_lint("any(duplicated(foo(x)))", lint_msg, linter)
   # na.rm doesn't really matter for this since duplicated can't return NA
-  expect_lint(
-    "any(duplicated(x), na.rm = TRUE)",
-    rex::rex("anyDuplicated(x, ...) > 0 is better"),
-    any_duplicated_linter()
-  )
-
+  expect_lint("any(duplicated(x), na.rm = TRUE)", lint_msg, linter)
   # also catch nested usage
-  expect_lint(
-    "foo(any(duplicated(x)))",
-    rex::rex("anyDuplicated(x, ...) > 0 is better"),
-    any_duplicated_linter()
-  )
+  expect_lint("foo(any(duplicated(x)))", lint_msg, linter)
 })
 
 test_that("any_duplicated_linter catches length(unique()) equivalencies too", {
+  linter <- any_duplicated_linter()
+  lint_msg_x <- rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)")
+  lint_msg_df <- rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)")
+
   # non-matches
   ## different variable
-  expect_lint("length(unique(x)) == length(y)", NULL, any_duplicated_linter())
+  expect_lint("length(unique(x)) == length(y)", NULL, linter)
   ## different table
-  expect_lint("length(unique(DF$x)) == nrow(DT)", NULL, any_duplicated_linter())
-  expect_lint("length(unique(l1$DF$x)) == nrow(l2$DF)", NULL, any_duplicated_linter())
+  expect_lint("length(unique(DF$x)) == nrow(DT)", NULL, linter)
+  expect_lint("length(unique(l1$DF$x)) == nrow(l2$DF)", NULL, linter)
 
   # lintable usage
-  expect_lint(
-    "length(unique(x)) == length(x)",
-    rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"),
-    any_duplicated_linter()
-  )
+  expect_lint("length(unique(x)) == length(x)", lint_msg_x, linter)
   # argument order doesn't matter
-  expect_lint(
-    "length(x) == length(unique(x))",
-    rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"),
-    any_duplicated_linter()
-  )
+  expect_lint("length(x) == length(unique(x))", lint_msg_x, linter)
   # nrow-style equivalency
-  expect_lint(
-    "nrow(DF) == length(unique(DF$col))",
-    rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)"),
-    any_duplicated_linter()
-  )
-  expect_lint(
-    "nrow(DF) == length(unique(DF[['col']]))",
-    rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)"),
-    any_duplicated_linter()
-  )
+  expect_lint("nrow(DF) == length(unique(DF$col))", lint_msg_df, linter)
+  expect_lint("nrow(DF) == length(unique(DF[['col']]))", lint_msg_df, linter)
   # match with nesting too
-  expect_lint(
-    "nrow(l$DF) == length(unique(l$DF[['col']]))",
-    rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)"),
-    any_duplicated_linter()
-  )
+  expect_lint("nrow(l$DF) == length(unique(l$DF[['col']]))", lint_msg_df, linter)
 
   # !=, <, and > usages are all alternative ways of writing a test for dupes
   #   technically, the direction of > / < matter, but writing
   #   length(unique(x)) > length(x) doesn't seem like it would ever happen.
-  expect_lint(
-    "length(unique(x)) != length(x)",
-    rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"),
-    any_duplicated_linter()
-  )
-  expect_lint(
-    "length(unique(x)) < length(x)",
-    rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"),
-    any_duplicated_linter()
-  )
-  expect_lint(
-    "length(x) > length(unique(x))",
-    rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"),
-    any_duplicated_linter()
-  )
+  expect_lint("length(unique(x)) != length(x)", lint_msg_x, linter)
+  expect_lint("length(unique(x)) < length(x)", lint_msg_x, linter)
+  expect_lint("length(x) > length(unique(x))", lint_msg_x, linter)
 
   # TODO(michaelchirico): try and match data.table- and dplyr-specific versions of
   #   this, e.g. DT[, length(unique(col)) == .N] or
   #   > DT %>% filter(length(unique(col)) == n())
 })
 
 test_that("any_duplicated_linter catches expression with two types of lint", {
+  linter <- any_duplicated_linter()
+  lint_msg <- rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)")
+
   expect_lint(
-    "table(any(duplicated(x)), length(unique(DF$col)) == nrow(DF))",
+    trim_some("{
+      any(duplicated(x))
+      length(unique(DF$col)) == nrow(DF)
+    }"),
     list(
-      rex::rex("anyDuplicated(x, ...) > 0 is better"),
-      rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)")
+      list(rex::rex("anyDuplicated(x, ...) > 0 is better"), line_number = 2L),
+      list(lint_msg, line_number = 3L)
     ),
-    any_duplicated_linter()
+    linter
   )
 
   # ditto for different messages within the length(unique()) tests
   expect_lint(
-    "table(length(unique(x)) == length(x), length(unique(DF$col)) == nrow(DF))",
+    trim_some("{
+      length(unique(x)) == length(x)
+      length(unique(DF$col)) == nrow(DF)
+    }"),
     list(
-      rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"),
-      rex::rex("anyDuplicated(DF$col) == 0L is better than length(unique(DF$col)) == nrow(DF)")
+      list(rex::rex("anyDuplicated(x) == 0L is better than length(unique(x)) == length(x)"), line_number = 2L),
+      list(lint_msg, line_number = 3L)
     ),
-    any_duplicated_linter()
+    linter
   )
 })

tests/testthat/test-any_is_na_linter.R

@@ -15,14 +15,29 @@ test_that("any_is_na_linter skips allowed usages", {
 })
 
 test_that("any_is_na_linter blocks simple disallowed usages", {
+  linter <- any_is_na_linter()
   lint_message <- rex::rex("anyNA(x) is better than any(is.na(x)).")
-  expect_lint("any(is.na(x))", lint_message, any_is_na_linter())
-
-  expect_lint("any(is.na(foo(x)))", lint_message, any_is_na_linter())
 
+  expect_lint("any(is.na(x))", lint_message, linter)
+  expect_lint("any(is.na(foo(x)))", lint_message, linter)
   # na.rm doesn't really matter for this since is.na can't return NA
-  expect_lint("any(is.na(x), na.rm = TRUE)", lint_message, any_is_na_linter())
-
+  expect_lint("any(is.na(x), na.rm = TRUE)", lint_message, linter)
   # also catch nested usage
-  expect_lint("foo(any(is.na(x)))", lint_message, any_is_na_linter())
+  expect_lint("foo(any(is.na(x)))", lint_message, linter)
+})
+
+test_that("lints vectorize", {
+  lint_message <- rex::rex("anyNA(x) is better than any(is.na(x)).")
+
+  expect_lint(
+    trim_some("{
+      any(is.na(foo(x)))
+      any(is.na(y), na.rm = TRUE)
+    }"),
+    list(
+      list(lint_message, line_number = 2L),
+      list(lint_message, line_number = 3L)
+    ),
+    any_is_na_linter()
+  )
 })

tests/testthat/test-assignment_linter.R

@@ -177,12 +177,17 @@ test_that("%<>% throws a lint", {
 
 test_that("multiple lints throw correct messages", {
   expect_lint(
-    "{ x <<- 1; y ->> 2; z -> 3; x %<>% as.character() }",
+    trim_some("{
+      x <<- 1
+      y ->> 2
+      z -> 3
+      x %<>% as.character()
+    }"),
     list(
-      list(message = "Replace <<- by assigning to a specific environment"),
-      list(message = "Replace ->> by assigning to a specific environment"),
-      list(message = "Use <-, not ->"),
-      list(message = "Avoid the assignment pipe %<>%")
+      list(message = "Replace <<- by assigning to a specific environment", line_number = 2L),
+      list(message = "Replace ->> by assigning to a specific environment", line_number = 3L),
+      list(message = "Use <-, not ->", line_number = 4L),
+      list(message = "Avoid the assignment pipe %<>%", line_number = 5L)
     ),
     assignment_linter(allow_cascading_assign = FALSE)
   )

tests/testthat/test-backport_linter.R

@@ -25,10 +25,14 @@ test_that("backport_linter detects backwards-incompatibility", {
   )
 
   expect_lint(
-    "trimws(...names())",
+    trim_some("
+      trimws(
+        ...names()
+      )
+    "),
     list(
-      rex::rex("trimws (R 3.2.0) is not available for dependency R >= 3.0.0."),
-      rex::rex("...names (R 4.1.0) is not available for dependency R >= 3.0.0.")
+      list(rex::rex("trimws (R 3.2.0) is not available for dependency R >= 3.0.0."), line_number = 1L),
+      list(rex::rex("...names (R 4.1.0) is not available for dependency R >= 3.0.0."), line_number = 2L)
     ),
     backport_linter("3.0.0")
   )

tests/testthat/test-boolean_arithmetic_linter.R

@@ -25,3 +25,19 @@ test_that("boolean_arithmetic_linter requires use of any() or !any()", {
   expect_lint("sum(x == y) != 0", lint_msg, linter)
   expect_lint("sum(grepl(pattern, x)) > 0L", lint_msg, linter)
 })
+
+test_that("lints vectorize", {
+  lint_msg <- rex::rex("Use any() to express logical aggregations.")
+
+  expect_lint(
+    trim_some("{
+      length(which(x == y)) > 0L
+      sum(x == y) != 0
+    }"),
+    list(
+      list(lint_msg, line_number = 2L),
+      list(lint_msg, line_number = 3L)
+    ),
+    boolean_arithmetic_linter()
+  )
+})

tests/testthat/test-class_equals_linter.R

@@ -47,3 +47,19 @@ test_that("class_equals_linter skips usage for subsetting", {
     linter
   )
 })
+
+test_that("lints vectorize", {
+  lint_msg <- rex::rex("Use inherits(x, 'class-name'), is.<class> or is(x, 'class')")
+
+  expect_lint(
+    trim_some("{
+      'character' %in% class(x)
+      class(x) == 'character'
+    }"),
+    list(
+      list(lint_msg, line_number = 2L),
+      list(lint_msg, line_number = 3L)
+    ),
+    class_equals_linter()
+  )
+})