Keep S7's := 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 rlang and data.table regardless of attachment order, without emitting `:=` masking messages (#697).
 * 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).
 * S7 and S4 now interoperate through inheritance. `new_class()` can use an S4 class as a parent, mapping S4 slots to S7 properties and registering the class with S4 automatically. Conversely, `S4_register()` registers an S7 class with S4, and `S4_contains()` returns an S4 class name suitable for `methods::setClass(contains = )`, exposing stored S7 properties as S4 slots for S4 subclasses. This support includes S4 initialization and validity integration, and S4/internal generic registration where needed; see `vignette("compatibility")` for caveats (#456).
 * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).

R/compatibility.R

@@ -7,6 +7,60 @@ activate_backward_compatiblility <- function() {
   invisible()
 }
 
+bind_conflict_packages <- c("data.table", "rlang")
+
+set_attached_bind <- function(env, value) {
+  get("unlockBinding", baseenv())(":=", env)
+  defer(lockBinding(":=", env))
+  env[[":="]] <- value
+}
+
+activate_bind_compatibility <- function() {
+  for (package in bind_conflict_packages) {
+    # These rules are session-wide. If S7 is detached, a package attached
+    # later may remain without its error-only := export on the search path.
+    rule <- conflictRules(package)
+    conflictRules(
+      package,
+      mask.ok = rule$mask.ok,
+      exclude = union(rule$exclude, ":=")
+    )
+
+    attached <- paste0("package:", package)
+    if (!attached %in% search()) {
+      next
+    }
+
+    env <- as.environment(attached)
+    if (
+      exists(":=", envir = env, inherits = FALSE) &&
+        identical(env[[":="]], getExportedValue(package, ":="))
+    ) {
+      # These exports are erroring sentinels for package-specific NSE syntax.
+      # An identical binding is not reported as a conflict by library().
+      set_attached_bind(env, `:=`)
+    }
+  }
+
+  invisible()
+}
+
+restore_attached_bindings <- function() {
+  for (package in bind_conflict_packages) {
+    attached <- paste0("package:", package)
+    if (!attached %in% search()) {
+      next
+    }
+
+    env <- as.environment(attached)
+    if (identical(env[[":="]], `:=`)) {
+      set_attached_bind(env, getExportedValue(package, ":="))
+    }
+  }
+
+  invisible()
+}
+
 #' @aliases @
 #' @usage NULL
 #' @rawNamespace if (getRversion() < "4.3.0") export(`@`)

R/zzz.R

@@ -132,12 +132,19 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
 # hooks -------------------------------------------------------------------
 
 .onAttach <- function(libname, pkgname) {
-  env <- as.environment(paste0("package:", pkgname))
+  activate_bind_compatibility()
+
   if (getRversion() < "4.3.0") {
-    env[[".conflicts.OK"]] <- TRUE
+    # S7_at already supplies @ without conflicting with base::@.
+    env <- as.environment(paste0("package:", pkgname))
+    rm(list = "@", envir = env)
   }
 }
 
+.onDetach <- function(...) {
+  restore_attached_bindings()
+}
+
 .onLoad <- function(...) {
   activate_backward_compatiblility()
 

tests/testthat/helper.R

@@ -126,6 +126,40 @@ local_libpath <- function(frame = parent.frame()) {
   lib
 }
 
+# Install the development S7 into a session-scoped library (built once per
+# test process) and prepend that library to .libPaths() until `frame` exits.
+local_dev_S7_lib <- local({
+  lib <- NULL
+  function(frame = parent.frame()) {
+    if (is.null(lib)) {
+      dir.create(new_lib <- tempfile("S7-dev-lib-"))
+      install.packages(
+        pkgs = normalizePath(test_path("..", "..")),
+        lib = new_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"
+        )
+      )
+      lib <<- new_lib
+    }
+
+    old <- .libPaths()
+    .libPaths(c(lib, old))
+    defer(.libPaths(old), frame = frame)
+    lib
+  }
+})
+
 # Install the package at `path` into `lib`, attach it, and detach (and unload)
 # it when `frame` exits. The package name is taken from `basename(path)`.
 local_install_and_attach <- function(path, lib, frame = parent.frame()) {

tests/testthat/test-bind.R

@@ -42,3 +42,112 @@ test_that(":= validates its inputs", {
     foo := no_name()
   })
 })
+
+test_that("S7 := wins without hiding unrelated attach conflicts", {
+  skip_if(quick_test())
+
+  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")
+
+  local_dev_S7_lib()
+
+  check_order <- function(package, order) {
+    output <- callr::r(
+      function(package, order) {
+        if (identical(order, "package-first")) {
+          package_bind <- getExportedValue(package, ":=")
+          attach(
+            list(as_class = function(...) NULL),
+            name = "shadow",
+            warn.conflicts = FALSE
+          )
+          library(package, character.only = TRUE)
+        }
+
+        messages <- character()
+        warnings <- character()
+
+        withCallingHandlers(
+          {
+            if (identical(order, "S7-first")) {
+              library(S7)
+              library(package, character.only = TRUE)
+            } else {
+              library(S7)
+            }
+          },
+          packageStartupMessage = function(cnd) {
+            messages <<- c(messages, conditionMessage(cnd))
+            invokeRestart("muffleMessage")
+          },
+          warning = function(cnd) {
+            warnings <<- c(warnings, conditionMessage(cnd))
+            invokeRestart("muffleWarning")
+          }
+        )
+
+        stopifnot(identical(get(":=", mode = "function"), S7::`:=`))
+
+        if (identical(order, "package-first")) {
+          stopifnot(identical(getExportedValue(package, ":="), package_bind))
+          detach("package:S7")
+          stopifnot(identical(
+            get(":=", mode = "function"),
+            package_bind
+          ))
+        }
+
+        list(messages = messages, warnings = warnings)
+      },
+      args = list(package = package, order = order)
+    )
+
+    expect_no_match(output$messages, ":=", fixed = TRUE)
+    expect_no_match(output$warnings, ":=", fixed = TRUE)
+    if (identical(order, "package-first")) {
+      expect_match(output$messages, "as_class", all = FALSE)
+    }
+  }
+
+  for (package in packages) {
+    check_order(package, "S7-first")
+    check_order(package, "package-first")
+  }
+})
+
+test_that("loading S7 does not affect := when S7 is not attached", {
+  skip_if(quick_test())
+
+  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")
+
+  local_dev_S7_lib()
+
+  for (package in packages) {
+    expect_no_error(callr::r(
+      function(package) {
+        loadNamespace("S7")
+        library(package, character.only = TRUE)
+        stopifnot(
+          identical(
+            get(":=", mode = "function"),
+            getExportedValue(package, ":=")
+          )
+        )
+      },
+      args = list(package = package)
+    ))
+  }
+})

vignettes/packages.Rmd

@@ -26,6 +26,16 @@ library(S7)
 
 First, add `S7` to the `Imports` field of your `DESCRIPTION`. We then recommend importing all S7 functions into your package `NAMESPACE` with `import(S7)`, or, if you're using roxygen2, `@import S7`.
 
+If your package also imports rlang or data.table, import `:=` from only S7. Otherwise, R warns that one import replaces the other when it loads your package. For example, to import all of rlang except `:=` with roxygen2:
+
+``` r
+#' @import S7
+#' @import rlang, except = ":="
+NULL
+```
+
+Use the same `except` argument when importing data.table.
+
 Next, create a `zzz.R` with a `.onLoad()` that calls `S7_on_load()`, an `.onUnload()` that calls `S7_on_unload()`, and a top-level call to `S7_on_build()`:
 
 ```{r}