[Rd] reduce limit number of arguments in methods:::cbind

[Yohan Chalabi]

Dear all,

As far as I understand, the number of arguments in methods:::cbind is
limited by the "self recursive" construction of the function
which generates nested loops.

A workaround could be to use the internal cbind function on blocks of
non S4 objects. The limitation would then be reduced to the number of
consecutive S4 objects.

##### R code #####

dfr  <- data.frame(matrix(0, nrow = 1 , ncol = 1000))
dfr2 <- is.na(dfr)

mlist <- rep(list(matrix(0, 2, 1)), 400)
cb1 <- do.call("cbind", c(mlist, mlist))

methods:::bind_activation(TRUE)

dfr2 <- is.na(dfr) # fails
cb2 <- do.call("cbind", mlist) # ok
cb3 <- do.call("cbind", c(mlist, mlist)) # fails

# This could be avoided by first checking that the arguments has no S4
# objects. If this is the case, the function falls back to the
# internal cbind function.

# But this would not be very helpful if the arguments are a mixture of
# S4 and non S4 objects

library(Matrix)

Mlist <- rep(list(Matrix(0, 2, 1)), 400)

cb4 <- do.call("cbind", Mlist) # ok
cb5 <- do.call("cbind", c(Mlist, Mlist)) # fails
cb6 <- do.call("cbind", c(Mlist, mlist)) # fails

# A workaround could be to use the internal cbind function on blocks of
# non S4 objects. The limitation would be reduced to the number of
# consecutive S4 objects

# After modifications

dfr2 <- is.na(dfr) # ok
cb7 <- do.call("cbind", mlist) # ok
cb8 <- do.call("cbind", c(mlist, mlist)) # ok

cb9 <- do.call("cbind", c(Mlist, mlist)) # ok

cb10 <- do.call("cbind", c(Mlist, Mlist)) # fails as expected

##### END #####

The code bellow gives an idea how to do it but was not fully tested!

Hope it helps,
Yohan


Index: methods/R/cbind.R
===================================================================
--- methods/R/cbind.R	(revision 47045)
+++ methods/R/cbind.R	(working copy)
@@ -39,11 +39,10 @@
     ## remove trailing 'NULL's:
     while(na > 0 && is.null(argl[[na]])) { argl <- argl[-na]; na <- na - 1 }
     if(na == 0) return(NULL)
-    if(na == 1) {
-	if(isS4(..1))
-	    return(cbind2(..1))
-	else return(.Internal(cbind(deparse.level, ...)))
-    }
+    if (!any(aS4 <- unlist(lapply(argl, isS4))))
+        return(.Internal(cbind(deparse.level, ...)))
+    if(na == 1)
+        return(cbind2(..1))

     ## else :  na >= 2

@@ -64,6 +63,15 @@
     else { ## na >= 3 arguments: -- RECURSION -- with care
 	## determine nrow(<result>)  for e.g.,	cbind(diag(2), 1, 2)
 	## only when the last two argument have *no* dim attribute:
+        idx.aS4 <- 0
+        while (!rev(aS4)[idx.aS4+1])
+            idx.aS4 <- idx.aS4 + 1
+        if (idx.aS4 > 1) {
+            argl0 <- argl[(na-idx.aS4+1):na]
+            argl1 <- do.call(cbind, c(argl0, list(deparse.level=deparse.level)))
+            argl2 <- c(argl[1L:(na-idx.aS4)], list(argl1))
+            return(do.call(cbind, c(argl2, list(deparse.level=deparse.level))))
+        }
 	nrs <- unname(lapply(argl, nrow)) # of length na
 	iV <- sapply(nrs, is.null)# is 'vector'
 	fix.na <- identical(nrs[(na-1):na], list(NULL,NULL))