ignore irrelevant symbols when pinpointing undefined variable lints (#1915)

Author: MichaelChirico

NEWS.md

@@ -37,6 +37,8 @@
 
 * `object_name_linter()` allows all S3 group Generics (see `?base::groupGeneric`) and S3 generics defined in a different file in the same package (#1808, #1841, @AshesITR)
 
+* `object_usage_linter()` improves identification of the exact source of a lint for undefined variables in expressions with where the variable is used as a symbol in a usual way, for example in a formula or in an extraction with `$` (#1914, @MichaelChirico).
+
 ## Changes to defaults
 
 * Set the default for the `except` argument in `duplicate_argument_linter()` to `c("mutate", "transmute")`.

R/object_usage_linter.R

@@ -46,6 +46,15 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
     sep = " | "
   )
 
+  # not all instances of linted symbols are potential sources for the observed violations -- see #1914
+  symbol_exclude_cond <- "preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT or ancestor::expr[OP-TILDE]"
+  xpath_culprit_symbol <- glue::glue("
+    descendant::SYMBOL[not( {symbol_exclude_cond} )]
+    | descendant::SYMBOL_FUNCTION_CALL[not( {symbol_exclude_cond} )]
+    | descendant::SPECIAL
+    | descendant::LEFT_ASSIGN[text() = ':=']
+  ")
+
   Linter(function(source_expression) {
     if (!is_lint_level(source_expression, "file")) {
       return(list())
@@ -97,15 +106,7 @@ object_usage_linter <- function(interpret_glue = TRUE, skip_with = TRUE) {
       # e.g. `not_existing<-`(a, b)
       res$name <- rex::re_substitutes(res$name, rex::rex("<-"), "")
 
-      lintable_symbols <- xml2::xml_find_all(
-        fun_assignment,
-        "
-        descendant::SYMBOL
-        | descendant::SYMBOL_FUNCTION_CALL
-        | descendant::SPECIAL
-        | descendant::LEFT_ASSIGN[text() = ':=']
-        "
-      )
+      lintable_symbols <- xml2::xml_find_all(fun_assignment, xpath_culprit_symbol)
 
       lintable_symbol_names <- gsub("^`|`$", "", xml2::xml_text(lintable_symbols))
       lintable_symbol_lines <- as.integer(xml2::xml_attr(lintable_symbols, "line1"))

tests/testthat/test-object_usage_linter.R

@@ -639,6 +639,119 @@ test_that("messages without a quoted name are caught", {
   )
 })
 
+# See #1914
+test_that("symbols in formulas aren't treated as 'undefined global'", {
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        lm(
+          y ~ z,
+          data = x[!is.na(y)]
+        )
+      }
+    "),
+    list(
+      message = "no visible binding for global variable 'y'",
+      line_number = 4L,
+      column_number = 21L
+    ),
+    object_usage_linter()
+  )
+
+  # neither on the RHS
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        lm(
+          z ~ y,
+          data = x[!is.na(y)]
+        )
+      }
+    "),
+    list(
+      message = "no visible binding for global variable 'y'",
+      line_number = 4L,
+      column_number = 21L
+    ),
+    object_usage_linter()
+  )
+
+  # nor in nested expressions
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        lm(
+          log(log(y)) ~ z,
+          data = x[!is.na(y)]
+        )
+      }
+    "),
+    list(
+      message = "no visible binding for global variable 'y'",
+      line_number = 4L,
+      column_number = 21L
+    ),
+    object_usage_linter()
+  )
+
+  # nor as a call
+  # NB: I wanted this to be s(), as in mgcv::s(), but that
+  #   doesn't work in this test suite because it resolves to
+  #   rex::s() since we attach that in testthat.R
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        lm(
+          y(w) ~ z,
+          data = x[!is.na(y)]
+        )
+      }
+    "),
+    list(
+      message = "no visible binding for global variable 'y'",
+      line_number = 4L,
+      column_number = 21L
+    ),
+    object_usage_linter()
+  )
+})
+
+test_that("NSE-ish symbols after $/@ are ignored as sources for lints", {
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        ggplot2::ggplot(
+          x[!is.na(x$column), ],
+          ggplot2::aes(x = column, fill = factor(x$grp))
+        )
+      }
+    "),
+    list(
+      message = "no visible binding for global variable 'column'",
+      line_number = 4L,
+      column_number = 22L
+    ),
+    object_usage_linter()
+  )
+
+  expect_lint(
+    trim_some("
+      foo <- function(x) {
+        ggplot2::ggplot(
+          x[!is.na(x@column), ],
+          ggplot2::aes(x = column, fill = factor(x$grp))
+        )
+      }
+    "),
+    list(
+      message = "no visible binding for global variable 'column'",
+      line_number = 4L,
+      column_number = 22L
+    ),
+    object_usage_linter()
+  )
+})
+
 test_that("functional lambda definitions are also caught", {
   skip_if_not_r_version("4.1.0")