diff --git a/NEWS.md b/NEWS.md index 6c34bdcc..eb578c58 100644 --- a/NEWS.md +++ b/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). diff --git a/R/compatibility.R b/R/compatibility.R index b7421ee9..a67f24bb 100644 --- a/R/compatibility.R +++ b/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(`@`) diff --git a/R/zzz.R b/R/zzz.R index 5b9bc2fe..2e039e35 100644 --- a/R/zzz.R +++ b/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() diff --git a/tests/testthat/test-bind.R b/tests/testthat/test-bind.R index c9d1920d..06228f81 100644 --- a/tests/testthat/test-bind.R +++ b/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") + } +})