Fix S4 method dispatch on imported S3 generics (e.g. setMethod("as.data.table", "Basket", ...))

R/loadfast.R

@@ -186,8 +186,8 @@ load_fast <- function(path = ".", helpers = TRUE, attach_testthat = NULL, full =
     }
     .timer(paste0("incr source ", length(files_to_source), " files"))
 
-    list2env(as.list(ns_env, all.names = FALSE), envir = pkg_env)
     list2env(as.list(parent.env(ns_env), all.names = TRUE), envir = pkg_env)
+    list2env(as.list(ns_env, all.names = FALSE), envir = pkg_env)
     .timer("incr pkg_env sync")
 
     .loadfast.cache[[abs_path]] <- list(
@@ -379,9 +379,10 @@ load_fast <- function(path = ".", helpers = TRUE, attach_testthat = NULL, full =
   .timer(paste0("source ", length(r_files), " files"))
 
   if (file.exists(ns_file)) {
-    exports <- nsInfo$exports
-    if (length(exports) > 0L) {
-      namespaceExport(ns_env, exports)
+    all_exports <- unique(c(nsInfo$exports, nsInfo$exportMethods, nsInfo$exportClasses))
+    all_exports <- all_exports[nzchar(all_exports)]
+    if (length(all_exports) > 0L) {
+      namespaceExport(ns_env, all_exports)
     }
   }
 
@@ -399,8 +400,8 @@ load_fast <- function(path = ".", helpers = TRUE, attach_testthat = NULL, full =
   .timer("attach testthat")
 
   pkg_env <- attach(NULL, name = pkg_env_name)
-  list2env(as.list(ns_env, all.names = FALSE), envir = pkg_env)
   list2env(as.list(impenv, all.names = TRUE), envir = pkg_env)
+  list2env(as.list(ns_env, all.names = FALSE), envir = pkg_env)
   .timer("attach pkg to search path")
 
   if (isTRUE(helpers) && uses_testthat) {

devpackage/R/s4_classes.R

@@ -45,4 +45,11 @@ animal <- function(name, species, legs) {
 
 pet <- function(name, species, legs, owner) {
   new("Pet", name = name, species = species, legs = legs, owner = owner)
-}
+}
+
+# --- Class: Basket (for testing setMethod on an imported S3 generic) ---
+setClass("Basket", representation(contents = "character"))
+
+setMethod("as.data.table", "Basket", function(x, keep.rownames = FALSE, ...) {
+  data.table(item = x@contents)
+})

test_loadfast.R

@@ -441,6 +441,69 @@ check("testthat devpackage: all tests pass", quote(
 
 cat(sprintf("  (testthat devpackage: %d passed, %d failed)\n", n_tt_pass1, n_tt_fail1))
 
+# --- S4 method on imported S3 generic (as.data.table) ---
+b1        <- new("Basket", contents = c("apple", "pear"))
+b1_single <- new("Basket", contents = "only")
+b1_empty  <- new("Basket", contents = character(0))
+
+check("Basket class is defined", quote(
+  isClass("Basket")
+))
+
+check("as.data.table method is registered for Basket", quote(
+  existsMethod("as.data.table", "Basket")
+))
+
+check("as.data.table implicit generic is in ns_env (not just the imported S3 fn)", quote(
+  is(get("as.data.table", envir = ns, inherits = FALSE), "genericFunction")
+))
+
+check("as.data.table in pkg_env is the implicit generic (not overwritten by impenv)", quote(
+  is(get("as.data.table", pos = "package:devpackage", inherits = FALSE), "genericFunction")
+))
+
+check("as.data.table not in namespace exports (no exportMethods directive)", quote(
+  !"as.data.table" %in% getNamespaceExports("devpackage")
+))
+
+check("as.data.table(Basket) dispatches correctly from ns_env", quote({
+  f <- get("as.data.table", envir = ns)
+  dt <- f(b1)
+  data.table::is.data.table(dt) && identical(dt$item, c("apple", "pear"))
+}))
+
+check("as.data.table(Basket) dispatches correctly via search path", quote({
+  f <- get("as.data.table", pos = "package:devpackage")
+  dt <- f(b1)
+  data.table::is.data.table(dt) && identical(dt$item, c("apple", "pear"))
+}))
+
+check("as.data.table(Basket) direct call via pkg_env", quote({
+  dt <- get("as.data.table", pos = "package:devpackage")(b1)
+  data.table::is.data.table(dt) && identical(dt$item, c("apple", "pear"))
+}))
+
+check("as.data.table(Basket) direct call evaluated in pkg_env scope", quote({
+  dt <- evalq(as.data.table(b1), envir = as.environment("package:devpackage"))
+  data.table::is.data.table(dt) && identical(dt$item, c("apple", "pear"))
+}))
+
+check("as.data.table(Basket) single-element Basket", quote({
+  dt <- get("as.data.table", pos = "package:devpackage")(b1_single)
+  data.table::is.data.table(dt) && nrow(dt) == 1L && identical(dt$item, "only")
+}))
+
+check("as.data.table(Basket) empty Basket yields 0-row DT with item column", quote({
+  dt <- get("as.data.table", pos = "package:devpackage")(b1_empty)
+  data.table::is.data.table(dt) && nrow(dt) == 0L && identical(names(dt), "item")
+}))
+
+check("as.data.table on data.frame still works (non-Basket dispatch unaffected)", quote({
+  dt <- data.table::as.data.table(data.frame(x = 1:2, y = c("a", "b"), stringsAsFactors = FALSE))
+  data.table::is.data.table(dt) && identical(dt$x, 1:2)
+}))
+
+
 # ============================================================================
 # STAGE 2: Full reload with mutated code (project2-style changes, ad-hoc)
 # ============================================================================
@@ -1469,6 +1532,42 @@ check("remove-fn: R6 classes unaffected", quote(
     exists("Counter", envir = ns4b, inherits = FALSE)
 ))
 
+check("incr-reload: Basket method still registered after base.R changed", quote(
+  existsMethod("as.data.table", "Basket")
+))
+
+check("incr-reload: as.data.table implicit generic still in ns_env after reload (not reverted to S3 fn)", quote(
+  is(get("as.data.table", envir = ns4b, inherits = FALSE), "genericFunction")
+))
+
+check("incr-reload: as.data.table in pkg_env is still the implicit generic after reload", quote(
+  is(get("as.data.table", pos = "package:devpackage", inherits = FALSE), "genericFunction")
+))
+
+check("incr-reload: Basket method still works via pkg_env after base.R changed", quote({
+  b_incr <- new("Basket", contents = c("x", "y"))
+  f <- get("as.data.table", pos = pkg_env4)
+  dt <- f(b_incr)
+  data.table::is.data.table(dt) && identical(dt$item, c("x", "y"))
+}))
+
+check("incr-reload: Basket direct call via pkg_env after reload", quote({
+  b_incr2 <- new("Basket", contents = c("x", "y"))
+  dt <- get("as.data.table", pos = "package:devpackage")(b_incr2)
+  data.table::is.data.table(dt) && identical(dt$item, c("x", "y"))
+}))
+
+check("incr-reload: Basket direct call evaluated in pkg_env scope after reload", quote({
+  b_incr3 <- new("Basket", contents = c("x", "y"))
+  dt <- evalq(as.data.table(b_incr3), envir = as.environment("package:devpackage"))
+  data.table::is.data.table(dt) && identical(dt$item, c("x", "y"))
+}))
+
+check("incr-reload: empty Basket yields 0-row DT after reload", quote({
+  dt <- get("as.data.table", pos = "package:devpackage")(new("Basket", contents = character(0)))
+  data.table::is.data.table(dt) && nrow(dt) == 0L && identical(names(dt), "item")
+}))
+
 ns4b_full <- load_fast(tmp_c, helpers = FALSE, attach_testthat = FALSE, full = TRUE)
 
 check("remove-fn: full=TRUE clears summarize_values from ns", quote(