New object_overwrite_linter

DESCRIPTION

@@ -141,6 +141,7 @@ Collate:
     'numeric_leading_zero_linter.R'
     'object_length_linter.R'
     'object_name_linter.R'
+    'object_overwrite_linter.R'
     'object_usage_linter.R'
     'outer_negation_linter.R'
     'package_hooks_linter.R'

NAMESPACE

@@ -103,6 +103,7 @@ export(nonportable_path_linter)
 export(numeric_leading_zero_linter)
 export(object_length_linter)
 export(object_name_linter)
+export(object_overwrite_linter)
 export(object_usage_linter)
 export(open_curly_linter)
 export(outer_negation_linter)

R/object_overwrite_linter.R

@@ -0,0 +1,94 @@
+#' Block assigning any variables whose name clashes with a `base` R function
+#'
+#' Re-using existing names creates a risk of subtle error best avoided.
+#'   Avoiding this practice also encourages using better, more descriptive names.
+#'
+#' @param packages Character vector of packages to search for names that should
+#'   be avoided. Defaults to the most common default packages: base, stats,
+#'   utils, tools, methods, graphics, and grDevices.
+#'
+#' @examples
+#' # will produce lints
+#' code <- "function(x) {\n  data <- x\n  data\n}"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = object_overwrite_linter()
+#' )
+#'
+#' code <- "function(x) {\n  lint <- 'fun'\n  lint\n}"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = object_overwrite_linter(packages = "lintr")
+#' )
+#'
+#' # okay
+#' code <- "function(x) {\n  data('mtcars')\n}"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = object_overwrite_linter()
+#' )
+#'
+#' code <- "function(x) {\n  data <- x\n  data\n}"
+#' writeLines(code)
+#' lint(
+#'   text = code,
+#'   linters = object_overwrite_linter(packages = "base")
+#' )
+#'
+#' @evalRd rd_tags("object_overwrite_linter")
+#' @seealso
+#'  - [linters] for a complete list of linters available in lintr.
+#'  - <https://style.tidyverse.org/syntax.html#object-names>
+#' @export
+object_overwrite_linter <- function(
+    packages = c("base", "stats", "utils", "tools", "methods", "graphics", "grDevices")) {
+  for (package in packages) {
+    if (!requireNamespace(package, quietly = TRUE)) {
+      stop("Package '", package, "' is not available.")
+    }
+  }
+  pkg_exports <- lapply(packages, getNamespaceExports)
+  pkg_exports <- data.frame(
+    package = rep(packages, lengths(pkg_exports)),
+    name = unlist(pkg_exports),
+    stringsAsFactors = FALSE
+  )
+
+  # test that the symbol doesn't match an argument name in the function
+  # NB: data.table := has parse token LEFT_ASSIGN as well
+  xpath <- glue("
+    //SYMBOL[
+      not(text() = ancestor::expr/preceding-sibling::SYMBOL_FORMALS/text())
+      and ({ xp_text_in_table(pkg_exports$name) })
+    ]/
+      parent::expr[
+        count(*) = 1
+        and following-sibling::LEFT_ASSIGN[text() = '<-']
+        and ancestor::expr/preceding-sibling::FUNCTION
+      ]
+  ")
+
+  Linter(function(source_expression) {
+    if (!is_lint_level(source_expression, "expression")) {
+      return(list())
+    }
+
+    xml <- source_expression$xml_parsed_content
+
+    bad_expr <- xml_find_all(xml, xpath)
+    bad_symbol <- xml_text(xml_find_first(bad_expr, "SYMBOL"))
+    source_pkg <- pkg_exports$package[match(bad_symbol, pkg_exports$name)]
+    lint_message <-
+      sprintf("'%s' is an exported object from package '%s'. Avoid re-using such symbols.", bad_symbol, source_pkg)
+
+    xml_nodes_to_lints(
+      bad_expr,
+      source_expression = source_expression,
+      lint_message = lint_message,
+      type = "warning"
+    )
+  })
+}

inst/lintr/linters.csv

@@ -60,6 +60,7 @@ nonportable_path_linter,robustness best_practices configurable
 numeric_leading_zero_linter,style consistency readability
 object_length_linter,style readability default configurable executing
 object_name_linter,style consistency default configurable executing
+object_overwrite_linter,best_practices robustness readability configurable executing
 object_usage_linter,style readability correctness default executing configurable
 open_curly_linter,style readability deprecated configurable
 outer_negation_linter,readability efficiency best_practices

tests/testthat/test-object_overwrite_linter

@@ -0,0 +1,83 @@
+test_that("object_overwrite_linter skips allowed usages", {
+  linter <- object_overwrite_linter()
+
+  expect_lint("function() DT <- data.frame(a = 1)", NULL, linter)
+
+  # don't block names subassigned e.g. as columns or list elements
+  expect_lint("function() x$sd <- sd(rnorm(100))", NULL, linter)
+})
+
+test_that("object_overwrite_linter blocks simple disallowed usages", {
+  linter <- object_overwrite_linter()
+
+  expect_lint(
+    "foo <- function() data <- mtcars",
+    rex::rex("'data' is an exported object from package 'utils'."),
+    linter
+  )
+
+  expect_lint(
+    trim_some("
+      foo <- function() {
+        sigma <- sd(rnorm(100))
+      }
+    "),
+    rex::rex("'sigma' is an exported object from package 'stats'."),
+    linter
+  )
+
+  # not just the top level of the function
+  expect_lint(
+    trim_some("
+      foo <- function() {
+        if (TRUE) {
+          sigma <- sd(rnorm(100))
+        } else {
+          all <- FALSE
+        }
+      }
+    "),
+    list(
+      rex::rex("'sigma' is an exported object from package 'stats'."),
+      rex::rex("'all' is an exported object from package 'base'.")
+    ),
+    linter
+  )
+})
+
+test_that("object_overwrite_linter skips any name assigned at the top level", {
+  linter <- object_overwrite_linter()
+
+  expect_lint("data <- mtcars", NULL, linter)
+  expect_lint("sigma <- sd(rnorm(100))", NULL, linter)
+})
+
+test_that("object_overwrite_linter skips argument names", {
+  linter <- object_overwrite_linter()
+
+  expect_lint("foo <- function(data) data <- data + 1", NULL, linter)
+
+  expect_lint(
+    trim_some("
+      bar <- function(a, b, c, sigma) {
+        sigma <- a * b * c ^ sigma
+      }
+    "),
+    NULL,
+    linter
+  )
+})
+
+test_that("object_overwrite_linter skips data.table assignments with :=", {
+  expect_lint("foo <- function() x[, title := 4]", NULL, object_overwrite_linter())
+})
+
+test_that("object_overwrite_linter optionally accepts package names", {
+  expect_lint("function() data <- 1", NULL, object_overwrite_linter(packages = "base"))
+
+  expect_lint(
+    "function() lint <- TRUE",
+    rex::rex("'lint' is an exported object from package 'lintr'."),
+    object_overwrite_linter(packages = "lintr")
+  )
+})