X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2FDNA.R;h=dd9c60bb63ace9abfe1350c73664e365ed91ac36;hb=3ad385892d75db5c646c92f0f631ae9c5e3da4f6;hp=90e841badb278b4aed61031d6df4f4a50cfe14d2;hpb=41cdf69dd7d0b334a94575c857f0d4c91a61e86f;p=ape.git

diff --git a/R/DNA.R b/R/DNA.R
index 90e841b..dd9c60b 100644
--- a/R/DNA.R
+++ b/R/DNA.R
@@ -1,8 +1,8 @@
-## DNA.R (2008-08-07)
+## DNA.R (2009-09-06)
 
 ##   Manipulations and Comparisons of DNA Sequences
 
-## Copyright 2002-2008 Emmanuel Paradis
+## Copyright 2002-2009 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -11,14 +11,15 @@ del.gaps <- function(x)
 {
     deleteGaps <- function(x) {
         i <- which(x == 4)
-        x[-i]
+        if (length(i)) x[-i] else x
     }
 
-    if (class(x) != "DNAbin") x <- as.DNAbin(x)
+    if (!inherits(x, "DNAbin")) x <- as.DNAbin(x)
     if (is.matrix(x)) {
         n <- dim(x)[1]
         y <- vector("list", n)
         for (i in 1:n) y[[i]] <- x[i, ]
+        names(y) <- rownames(x)
         x <- y
         rm(y)
     }
@@ -50,6 +51,7 @@ as.alignment <- function(x)
 
 "[.DNAbin" <- function(x, i, j, drop = TRUE)
 {
+    oc <- oldClass(x)
     class(x) <- NULL
     if (is.matrix(x)) {
         if (nargs() == 2 && !missing(i)) ans <- x[i]
@@ -63,12 +65,12 @@ as.alignment <- function(x)
         if (missing(i)) i <- 1:length(x)
         ans <- x[i]
     }
-    structure(ans, class = "DNAbin")
+    class(ans) <- oc
+    ans
 }
 
 as.matrix.DNAbin <- function(x, ...)
 {
-    if (is.matrix(x)) return(x)
     if (is.list(x)) {
         if (length(unique(unlist(lapply(x, length)))) != 1)
           stop("DNA sequences in list not of the same length.")
@@ -86,41 +88,64 @@ rbind.DNAbin <- function(...)
 ### works only with matrices for the moment
 {
     obj <- list(...)
-    nobj <- length(obj)
-    if (nobj == 1) stop("only one matrix to bind.")
-    NC <- ncol(obj[[1]])
-    for (i in 2:nobj)
-      if(ncol(obj[[i]]) != NC)
+    n <- length(obj)
+    if (n == 1) return(obj[[1]])
+    NC <- unlist(lapply(obj, ncol))
+    if (length(unique(NC)) > 1)
         stop("matrices do not have the same number of columns.")
-    for (i in 1:nobj) class(obj[[i]]) <- NULL
-    ans <- obj[[1]]
-    for (i in 2:nobj) ans <- rbind(ans, obj[[i]])
-    structure(ans, class = "DNAbin")
+    for (i in 1:n) class(obj[[i]]) <- NULL
+    for (i in 2:n) obj[[1]] <- rbind(obj[[1]], obj[[i]])
+    structure(obj[[1]], class = "DNAbin")
 }
 
-cbind.DNAbin <- function(..., check.names = TRUE)
+cbind.DNAbin <-
+    function(..., check.names = TRUE, fill.with.gaps = FALSE,
+             quiet = FALSE)
 ### works only with matrices for the moment
 {
     obj <- list(...)
-    nobj <- length(obj)
-    if (nobj == 1) stop("only one matrix to bind.")
-    NR <- nrow(obj[[1]])
-    for (i in 2:nobj)
-      if(nrow(obj[[i]]) != NR)
-        stop("matrices do not have the same number of rows.")
-    for (i in 1:nobj) class(obj[[i]]) <- NULL
-    nms <- rownames(obj[[1]])
+    n <- length(obj)
+    if (n == 1) return(obj[[1]])
+    NR <- unlist(lapply(obj, nrow))
+    for (i in 1:n) class(obj[[i]]) <- NULL
     if (check.names) {
-        for (i in 2:nobj)
-          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
 }
 
+c.DNAbin <- function(..., recursive = FALSE)
+    structure(NextMethod("c"), class = "DNAbin")
+
 print.DNAbin <- function(x, ...)
 {
     n <- 1 # <- if is.vector(x)
@@ -249,9 +274,13 @@ GC.content <- function(x) sum(base.freq(x)[2:3])
 seg.sites <- function(x)
 {
     if (is.list(x)) x <- as.matrix(x)
-    n <- dim(x)
-    s <- n[2]
-    n <- n[1]
+    if (is.vector(x)) n <- 1
+    else { # 'x' is a matrix
+        n <- dim(x)
+        s <- n[2]
+        n <- n[1]
+    }
+    if (n == 1) return(integer(0))
     ans <- .C("SegSites", x, n, s, integer(s),
               DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")
     which(as.logical(ans[[4]]))
@@ -277,7 +306,7 @@ dist.dna <- function(x, model = "K80", variance = FALSE, gamma = FALSE,
                      as.matrix = FALSE)
 {
     MODELS <- c("RAW", "JC69", "K80", "F81", "K81", "F84", "T92", "TN93",
-                "GG95", "LOGDET", "BH87", "PARALIN")
+                "GG95", "LOGDET", "BH87", "PARALIN", "N")
     imod <- which(MODELS == toupper(model))
     if (imod == 11 && variance) {
         warning("computing variance temporarily not available for model BH87.")