Keep S7 := ahead of rlang and data.table

NEWS.md

@@ -1,6 +1,7 @@
 # S7 (development version)
 
 * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658).
+* The `:=` operator now stays ahead of other attached packages that export `:=`, such as rlang or data.table, without emitting attach-time masking messages.
 * The class object that S7 stores on each instance now lives in the `_S7_class` attribute (previously `S7_class`), moving it into the `_`-prefixed namespace reserved for S7 internals so it can't collide with a user-defined property. Objects created by an older version of S7 (e.g. serialised to disk or baked into another package's lazy-load database) continue to work, as S7 falls back to the old attribute name when reading them (#677).
 * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).
 * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401).

R/compatibility.R

@@ -7,6 +7,55 @@ activate_backward_compatiblility <- function() {
   invisible()
 }
 
+activate_attach_compatibility <- function(pkgname) {
+  if (getRversion() >= "4.3.0" && !search_has_bind_conflict(pkgname)) {
+    return(invisible())
+  }
+
+  env <- as.environment(paste0("package:", pkgname))
+  env[[".conflicts.OK"]] <- TRUE
+  invisible()
+}
+
+search_has_bind_conflict <- function(pkgname) {
+  pkg <- paste0("package:", pkgname)
+  env <- as.environment(pkg)
+  bind <- env[[":="]]
+  where <- setdiff(search(), c(pkg, "Autoloads", "CheckExEnv"))
+
+  for (pos in where) {
+    other <- as.environment(pos)
+    if (!exists(":=", envir = other, inherits = FALSE)) {
+      next
+    }
+
+    other_bind <- other[[":="]]
+    if (is.function(other_bind) && !identical(other_bind, bind)) {
+      return(TRUE)
+    }
+  }
+
+  FALSE
+}
+
+activate_bind_compatibility <- function() {
+  conflictRules <- get0("conflictRules", envir = baseenv(), inherits = FALSE)
+  if (is.null(conflictRules)) {
+    return(invisible())
+  }
+
+  for (package in c("data.table", "rlang")) {
+    rule <- conflictRules(package)
+    conflictRules(
+      package,
+      mask.ok = rule$mask.ok,
+      exclude = union(rule$exclude, ":=")
+    )
+  }
+
+  invisible()
+}
+
 #' @aliases @
 #' @usage NULL
 #' @rawNamespace if (getRversion() < "4.3.0") export(`@`)

R/zzz.R

@@ -131,14 +131,13 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
 # hooks -------------------------------------------------------------------
 
 .onAttach <- function(libname, pkgname) {
-  env <- as.environment(paste0("package:", pkgname))
-  if (getRversion() < "4.3.0") {
-    env[[".conflicts.OK"]] <- TRUE
-  }
+  activate_bind_compatibility()
+  activate_attach_compatibility(pkgname)
 }
 
 .onLoad <- function(...) {
   activate_backward_compatiblility()
+  activate_bind_compatibility()
 
   on_load_define_environment()
   on_load_define_S7_generic()

tests/testthat/test-bind.R

@@ -42,3 +42,76 @@ test_that(":= validates its inputs", {
     foo := no_name()
   })
 })
+
+test_that("S7 := wins search-path conflicts without attach warnings", {
+  skip_if(quick_test())
+
+  tmp_lib <- local_libpath()
+  install.packages(
+    pkgs = normalizePath(test_path("..", "..")),
+    lib = tmp_lib,
+    repos = NULL,
+    type = "source",
+    quiet = TRUE,
+    INSTALL_opts = c(
+      "--data-compress=none",
+      "--no-byte-compile",
+      "--no-data",
+      "--no-demo",
+      "--no-docs",
+      "--no-help",
+      "--no-html",
+      "--use-vanilla"
+    )
+  )
+
+  packages <- c("data.table", "rlang")
+  packages <- packages[vapply(
+    packages,
+    requireNamespace,
+    logical(1),
+    quietly = TRUE
+  )]
+  skip_if(length(packages) == 0, "rlang and data.table are not installed")
+
+  check_order <- function(package, order) {
+    expect_no_error(callr::r(
+      function(package, order) {
+        messages <- character()
+        warnings <- character()
+
+        withCallingHandlers(
+          {
+            if (identical(order, "S7-first")) {
+              library(S7)
+              library(package, character.only = TRUE)
+            } else {
+              library(package, character.only = TRUE)
+              library(S7)
+            }
+          },
+          packageStartupMessage = function(cnd) {
+            messages <<- c(messages, conditionMessage(cnd))
+            invokeRestart("muffleMessage")
+          },
+          warning = function(cnd) {
+            warnings <<- c(warnings, conditionMessage(cnd))
+            invokeRestart("muffleWarning")
+          }
+        )
+
+        stopifnot(exprs = {
+          identical(get(":=", mode = "function"), S7::`:=`)
+          !any(grepl(":=", messages, fixed = TRUE))
+          !any(grepl(":=", warnings, fixed = TRUE))
+        })
+      },
+      args = list(package = package, order = order)
+    ))
+  }
+
+  for (package in packages) {
+    check_order(package, "S7-first")
+    check_order(package, "alias-first")
+  }
+})