improved cbind.DNAbin for ape 2.2-2

[ape.git] / R / DNA.R

diff --git a/R/DNA.R b/R/DNA.R
index 9bcc28580c1ddcb0531b528f1e84c3f3b742b85a..7bc0431507ea22d5d4f35986f2cd2f3eb270d58a 100644 (file)
--- a/R/DNA.R
+++ b/R/DNA.R
@@ -96,27 +96,49 @@ rbind.DNAbin <- function(...)
     structure(obj[[1]], class = "DNAbin")
 }
 
-cbind.DNAbin <- function(..., check.names = TRUE, fill.with.gaps = FALSE,
-                         quiet = TRUE)
+cbind.DNAbin <-
+    function(..., check.names = TRUE, fill.with.gaps = FALSE,
+             quiet = FALSE)
 ### works only with matrices for the moment
 {
     obj <- list(...)
     n <- length(obj)
     if (n == 1) return(obj[[1]])
     NR <- unlist(lapply(obj, nrow))
-    if (length(unique(NR)) > 1)
-        stop("matrices do not have the same number of rows.")
     for (i in 1:n) class(obj[[i]]) <- NULL
-    nms <- rownames(obj[[1]])
     if (check.names) {
-        for (i in 2:n)
-          if (all(rownames(obj[[i]]) %in% nms))
-            obj[[i]] <- obj[[i]][nms, ]
-        else stop("rownames do not match among matrices.")
+        nms <- unlist(lapply(obj, rownames))
+        if (fill.with.gaps) {
+            NC <- unlist(lapply(obj, ncol))
+            nms <- unique(nms)
+            ans <- matrix(as.raw(4), length(nms), sum(NC))
+            rownames(ans) <- nms
+            from <- 1
+            for (i in 1:n) {
+                to <- from + NC[i] - 1
+                tmp <- rownames(obj[[i]])
+                nmsi <- tmp[tmp %in% nms]
+                ans[nmsi, from:to] <- obj[[i]][nmsi, , drop = FALSE]
+                from <- to + 1
+            }
+        } else {
+            tab <- table(nms)
+            ubi <- tab == n
+            nms <- names(tab)[which(ubi)]
+            ans <- obj[[1]][nms, , drop = FALSE]
+            for (i in 2:n)
+                ans <- cbind(ans, obj[[i]][nms, , drop = FALSE])
+            if (!quiet && !all(ubi))
+                warning("some rows were dropped.")
+        }
+    } else {
+        if (length(unique(NR)) > 1)
+            stop("matrices do not have the same number of rows.")
+        ans <- matrix(unlist(obj), NR)
+        rownames(ans) <- rownames(obj[[1]])
     }
-    ans <- matrix(unlist(obj), NR)
-    rownames(ans) <- nms
-    structure(ans, class = "DNAbin")
+    class(ans) <- "DNAbin"
+    ans
 }
 
 print.DNAbin <- function(x, ...)