fix namespace hooks exception in object_name_linter

NEWS.md

@@ -16,7 +16,7 @@
 * New `sprintf_linter()` (#544, #578, #624, #625, @renkun-ken, @AshesITR)
 * Exclusions specified in the `.lintr` file are now relative to the location of that file 
   and support excluding entire directories (#158, #438, @AshesITR)
-* `object_name_linter()` now excludes special R hook functions such as `.onLoad` (#500, #614, @AshesITR)
+* `object_name_linter()` now excludes special R hook functions such as `.onLoad` (#500, #614, @AshesITR and @michaelchirico)
 * `equals_na_linter()` now lints `x != NA` and `NA == x`, and skips usages in comments (#545, @michaelchirico)
 * Malformed Rmd files now cause a lint instead of an error (#571, #575, @AshesITR)
 * `object_name_linter()` gains a new default style, `"symbols"`, which won't lint all-symbol object names (in particular, that means operator names like `%+%` are skipped; #615, @michaelchirico)

R/object_name_linters.R

@@ -51,14 +51,14 @@ object_name_linter <- function(styles = c("snake_case", "symbols")) {
     nms <- strip_names(
       as.character(xml2::xml_find_first(assignments, "./text()")))
 
-    generics <- c(
+    generics <- strip_names(c(
       declared_s3_generics(xml),
       namespace_imports()$fun,
       names(.knownS3Generics),
-      .S3PrimitiveGenerics, ls(baseenv()))
+      .S3PrimitiveGenerics, ls(baseenv())))
 
-    style_matches <- lapply(styles, function(x) {
-      check_style(nms, x, generics)
+    style_matches <- lapply(styles, function(style) {
+      check_style(nms, style, generics)
     })
 
     matches_a_style <- Reduce(`|`, style_matches)
@@ -90,6 +90,9 @@ check_style <- function(nms, style, generics = character()) {
       # If they are not conforming, but are S3 methods then ignore them
       conforming[!conforming][has_generic] <- TRUE
     }
+    # exclude namespace hooks like .onLoad, .Last.lib, etc (#500)
+    is_special <- is_special_function(nms[!conforming])
+    conforming[!conforming][is_special] <- TRUE
   }
   conforming
 }
@@ -130,8 +133,7 @@ make_object_linter <- function(fun) {
     keep_indices <- which(
       !is_operator(names) &
         !is_known_generic(names) &
-        !is_base_function(names) &
-        !is_special_function(names)
+        !is_base_function(names)
     )
 
     lapply(
@@ -229,27 +231,34 @@ base_pkgs <- c(
   "mgcv"
 )
 
-base_funs <- unlist(lapply(base_pkgs,
-                           function(x) {
-                             name <- try_silently(getNamespace(x))
-                             if (!inherits(name, "try-error")) {
-                               ls(name, all.names = TRUE)
-                             }
-                           }))
+# some duplicates such as .onLoad appear in multiple packages; sort for efficiency
+base_funs <- sort(unique(unlist(lapply(
+  base_pkgs,
+  function(x) {
+    name <- try_silently(getNamespace(x))
+    if (!inherits(name, "try-error")) {
+      ls(name, all.names = TRUE)
+    }
+  }
+))))
 
 is_base_function <- function(x) {
   x %in% base_funs
 }
 
-# see ?".onLoad" and ?"Startup"
+# see ?".onLoad", ?Startup, and ?quit. Remove leading dot to match behavior of strip_names().
+#   All of .onLoad, .onAttach, and .onUnload are used in base packages,
+#   and should be caught in is_base_function; they're included here for completeness / stability
+#   (they don't strictly _have_ to be defined in base, so could in principle be removed).
+#   .Last.sys and .First.sys are part of base itself, so aren't included here.
 special_funs <- c(
-  ".onLoad",
-  ".onAttach",
-  ".onUnload",
-  ".onDetach",
-  ".Last.lib",
-  ".First",
-  ".Last"
+  "onLoad",
+  "onAttach",
+  "onUnload",
+  "onDetach",
+  "Last.lib",
+  "First",
+  "Last"
 )
 
 is_special_function <- function(x) {
@@ -266,7 +275,7 @@ object_lint <- function(source_file, token, message, type) {
     line = source_file$lines[as.character(token$line1)],
     ranges = list(c(token$col1, token$col2)),
     linter = type
-    )
+  )
 }
 
 

tests/testthat/test-object_name_linter.R

@@ -48,6 +48,8 @@ test_that("linter ignores some objects", {
   expect_lint("print.foo <- t", NULL, object_name_linter("CamelCase"))         # S3 generic
   expect_lint("names.foo <- t", NULL, object_name_linter("CamelCase"))      # int generic
   expect_lint("sapply(x,f,USE.NAMES=T)", NULL, object_name_linter("snake_case")) # defined elsewhere
+  expect_lint(".onLoad <- function(...) TRUE", NULL, object_name_linter("snake_case")) # namespace hooks, #500
+  expect_lint(".First <- function(...) TRUE", NULL, object_name_linter("snake_case")) # namespace hooks
   expect_lint("`%++%` <- `+`", NULL, object_name_linter("symbols")) # all-symbol operator
 })