more efficient conditional S3 method registration

shikokuchuo · Oct 11, 2023 · f926edb · f926edb
1 parent a343550
commit f926edb
Show file tree

Hide file tree

Showing 3 changed files with 44 additions and 26 deletions.
diff --git a/R/mirai-package.R b/R/mirai-package.R
@@ -85,16 +85,33 @@ NULL
     }
   )
 
+  registerConditionalMethods()
+
+}
+
+registerConditionalMethods <- function() {
+
   rversion <- .subset2(getRversion(), 1L)
   if (rversion[1L] >= 4 && rversion[2L] >= 4 || rversion[1L] >= 5) {
     ns <- .getNamespace("parallel")
-    registerS3method("recvData", "miraiNode", recvData.miraiNode, ns)
-    registerS3method("sendData", "miraiNode", sendData.miraiNode, ns)
-    registerS3method("recvOneData", "miraiCluster", recvOneData.miraiCluster, ns)
+    table <- ns[[".__S3MethodsTable__."]]
+    `[[<-`(table, "recvData.miraiNode", recvData.miraiNode)
+    `[[<-`(table, "sendData.miraiNode", sendData.miraiNode)
+    `[[<-`(table, "recvOneData.miraiCluster", recvOneData.miraiCluster)
+    regs <- rbind(.getNamespaceInfo(ns, "S3methods"),
+                  c("recvData", "miraiNode", "recvData.miraiNode", NA_character_),
+                  c("sendData", "miraiNode", "sendData.miraiNode", NA_character_),
+                  c("recvOneData", "miraiCluster", "recvOneData.miraiCluster", NA_character_))
+    setNamespaceInfo(ns, "S3methods", regs)
   }
 
-  if (requireNamespace("promises", quietly = TRUE))
-    registerS3method("as.promise", "mirai", as.promise.mirai, .getNamespace("promises"))
+  if (requireNamespace("promises", quietly = TRUE)) {
+    ns <- .getNamespace("promises")
+    `[[<-`(ns[[".__S3MethodsTable__."]], "as.promise.mirai", as.promise.mirai)
+    regs <- rbind(.getNamespaceInfo(ns, "S3methods"),
+                  c("as.promise", "mirai", "as.promise.mirai", NA_character_))
+    setNamespaceInfo(ns, "S3methods", regs)
+  }
 
 }
 
@@ -139,4 +156,3 @@ recvOneData <- NULL
 sendData <- NULL
 
 as.promise <- NULL
-
diff --git a/tests/parallel/parallel-tests.R b/tests/parallel/parallel-tests.R
@@ -35,7 +35,7 @@ nanotest(length(cluster) == 2L)
 
 clusterSetRNGStream(cluster, 123)
 j <- clusterEvalQ(cluster, expr = .GlobalEnv[[".Random.seed"]])
-a <- parSapply(cluster, 1:4, rnorm)
+a <- parSapply(cluster, 1:4, runif)
 
 setDefaultCluster(cluster)
 res <- parLapply(X = 1:10, fun = rnorm)
@@ -62,7 +62,7 @@ nanotest(attr(cl, "id") != attr(cluster, "id"))
 
 clusterSetRNGStream(cl, 123)
 k <- clusterEvalQ(cl, expr = .GlobalEnv[[".Random.seed"]])
-b <- parSapply(cl, 1:4, rnorm)
+b <- parSapply(cl, 1:4, runif)
 nanotesti(j, k)
 nanotesti(a, b)
 

diff --git a/tests/tests.R b/tests/tests.R
@@ -80,25 +80,27 @@ nanotestz(status(.compute = "new")[["connections"]])
 nanotestz(daemons(0L, .compute = "new"))
 Sys.sleep(1L)
 
-cl <- make_cluster(1)
-nanotest(inherits(cl, "miraiCluster"))
-nanotest(inherits(cl, "cluster"))
-nanotest(length(cl) == 1L)
-nanotest(inherits(cl[[1]], "miraiNode"))
-nanotestp(cl[1])
-nanotest(is.character(launch_remote(cl)))
-nanotest(is.character(launch_remote(cl[[1L]])))
-nanotest(is.list(status(cl)))
-nanotestn(stop_cluster(cl))
-Sys.sleep(1L)
+if (requireNamespace("promises", quietly = TRUE)) {
+  nanotest(promises::is.promise(p1 <- promises::as.promise(mirai("completed"))))
+  Sys.sleep(1L)
+  nanotest(promises::is.promise(p2 <- promises::`%...>%`(mirai("completed"), identity())))
+  Sys.sleep(1L)
+}
 
 if (.Platform[["OS.type"]] != "windows") {
-  if (requireNamespace("promises", quietly = TRUE)) {
-    nanotest(promises::is.promise(p1 <- promises::as.promise(mirai("completed"))))
-    Sys.sleep(1L)
-    nanotest(promises::is.promise(p2 <- promises::`%...>%`(mirai("completed"), identity())))
-    Sys.sleep(1L)
-  }
+
+  cl <- make_cluster(1)
+  nanotest(inherits(cl, "miraiCluster"))
+  nanotest(inherits(cl, "cluster"))
+  nanotest(length(cl) == 1L)
+  nanotest(inherits(cl[[1]], "miraiNode"))
+  nanotestp(cl[1])
+  nanotest(is.character(launch_remote(cl)))
+  nanotest(is.character(launch_remote(cl[[1L]])))
+  nanotest(is.list(status(cl)))
+  nanotestn(stop_cluster(cl))
+  Sys.sleep(1L)
+
   mlc <- launch_remote("ws://[::1]:5555")
   nanotest(is.character(mlc))
   nanotest(inherits(mlc, "miraiLaunchCmd"))
@@ -166,6 +168,7 @@ if (.Platform[["OS.type"]] != "windows") {
 }
 
 if (Sys.getenv("NOT_CRAN") == "true" && .Platform[["OS.type"]] != "windows") {
+
   nanotesto(daemons(url = "wss://127.0.0.1:0", token = TRUE, pass = "test"))
   nanotestn(launch_local(1L))
   Sys.sleep(1L)
@@ -178,7 +181,6 @@ if (Sys.getenv("NOT_CRAN") == "true" && .Platform[["OS.type"]] != "windows") {
   nanotesto(daemons(1, dispatcher = TRUE, maxtasks = 10L, timerstart = 1L, walltime = 1000L, seed = 1546, token = TRUE, lock = TRUE, cleanup = option))
   Sys.sleep(1L)
   mq <- mirai("daemon", .timeout = 1000)
-  nanotestn(saisei(i = 1L))
   nanotest(call_mirai(mq)$data == "daemon" || is_error_value(mq$data))
   mq <- mirai(Sys.sleep(1.5), .timeout = 500)
   dstatus <- status()[["daemons"]]