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

diff --git a/R/DNA.R b/R/DNA.R
index dd9c60b..dea2d60 100644
--- a/R/DNA.R
+++ b/R/DNA.R
@@ -1,12 +1,19 @@
-## DNA.R (2009-09-06)
+## DNA.R (2010-05-17)
 
 ##   Manipulations and Comparisons of DNA Sequences
 
-## Copyright 2002-2009 Emmanuel Paradis
+## Copyright 2002-2010 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
 
+labels.DNAbin <- function(object, ...)
+{
+    if (is.list(object)) return(names(object))
+    if (is.matrix(object)) return(rownames(object))
+    NULL
+}
+
 del.gaps <- function(x)
 {
     deleteGaps <- function(x) {
@@ -49,7 +56,7 @@ as.alignment <- function(x)
     obj
 }
 
-"[.DNAbin" <- function(x, i, j, drop = TRUE)
+"[.DNAbin" <- function(x, i, j, drop = FALSE)
 {
     oc <- oldClass(x)
     class(x) <- NULL
@@ -90,6 +97,9 @@ rbind.DNAbin <- function(...)
     obj <- list(...)
     n <- length(obj)
     if (n == 1) return(obj[[1]])
+    for (i in 1:n)
+        if (!is.matrix(obj[[1]]))
+            stop("the 'rbind' method for \"DNAbin\" accepts only matrices")
     NC <- unlist(lapply(obj, ncol))
     if (length(unique(NC)) > 1)
         stop("matrices do not have the same number of columns.")
@@ -106,6 +116,9 @@ cbind.DNAbin <-
     obj <- list(...)
     n <- length(obj)
     if (n == 1) return(obj[[1]])
+    for (i in 1:n)
+        if (!is.matrix(obj[[1]]))
+            stop("the 'cbind' method for \"DNAbin\" accepts only matrices")
     NR <- unlist(lapply(obj, nrow))
     for (i in 1:n) class(obj[[i]]) <- NULL
     if (check.names) {
@@ -144,29 +157,24 @@ cbind.DNAbin <-
 }
 
 c.DNAbin <- function(..., recursive = FALSE)
-    structure(NextMethod("c"), class = "DNAbin")
-
-print.DNAbin <- function(x, ...)
 {
-    n <- 1 # <- if is.vector(x)
-    if (is.list(x)) n <- length(x)
-    else if (is.matrix(x)) n <- dim(x)[1]
-    if (n > 1) cat(n, "DNA sequences in binary format.\n")
-    else cat("1 DNA sequence in binary format.\n")
+    if (!all(unlist(lapply(list(...), is.list))))
+        stop("the 'c' method for \"DNAbin\" accepts only lists")
+    structure(NextMethod("c"), class = "DNAbin")
 }
 
-summary.DNAbin <- function(object, printlen = 6, digits = 3, ...)
+print.DNAbin <- function(x, printlen = 6, digits = 3, ...)
 {
-    if (is.list(object)) {
-        n <- length(object)
-        nms <- names(object)
+    if (is.list(x)) {
+        n <- length(x)
+        nms <- names(x)
         if (n == 1) {
             cat("1 DNA sequence in binary format stored in a list.\n\n")
-            cat("Sequence length:", length(object[[1]]), "\n\n")
+            cat("Sequence length:", length(x[[1]]), "\n\n")
             cat("Label:", nms, "\n\n")
         } else {
             cat(n, "DNA sequences in binary format stored in a list.\n\n")
-            tmp <- unlist(lapply(object, length))
+            tmp <- unlist(lapply(x, length))
             mini <- min(tmp)
             maxi <- max(tmp)
             if (mini == maxi)
@@ -183,9 +191,9 @@ summary.DNAbin <- function(object, printlen = 6, digits = 3, ...)
             }
             cat("\nLabels:", paste(nms, collapse = " "), TAIL)
         }
-    } else if (is.matrix(object)) {
-        nd <- dim(object)
-        nms <- rownames(object)
+    } else if (is.matrix(x)) {
+        nd <- dim(x)
+        nms <- rownames(x)
         cat(nd[1], "DNA sequences in binary format stored in a matrix.\n\n")
         cat("All sequences of same length:", nd[2], "\n")
         TAIL <- "\n\n"
@@ -196,10 +204,10 @@ summary.DNAbin <- function(object, printlen = 6, digits = 3, ...)
         cat("\nLabels:", paste(nms, collapse = " "), TAIL)
     } else {
         cat("1 DNA sequence in binary format stored in a vector.\n\n")
-        cat("Sequence length:", length(object), "\n\n")
+        cat("Sequence length:", length(x), "\n\n")
     }
     cat("Base composition:\n")
-    print(round(base.freq(object), digits))
+    print(round(base.freq(x), digits))
 }
 
 as.DNAbin <- function(x, ...) UseMethod("as.DNAbin")
@@ -259,11 +267,11 @@ as.character.DNAbin <- function(x, ...)
     if (is.list(x)) lapply(x, f) else f(x)
 }
 
-base.freq <- function(x)
+base.freq <- function(x, freq = FALSE)
 {
     if (is.list(x)) x <- unlist(x)
     n <- length(x)
-    BF <- .C("BaseProportion", x, n, double(4),
+    BF <- .C("BaseProportion", x, n, double(4), freq,
              DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")[[3]]
     names(BF) <- letters[c(1, 3, 7, 20)]
     BF
@@ -286,28 +294,16 @@ seg.sites <- function(x)
     which(as.logical(ans[[4]]))
 }
 
-nuc.div <- function(x, variance = FALSE, pairwise.deletion = FALSE)
-{
-    if (pairwise.deletion && variance)
-      warning("cannot compute the variance of nucleotidic diversity\nwith pairwise deletion: try 'pairwise.deletion = FALSE' instead.")
-    if (is.list(x)) x <- as.matrix(x)
-    n <- dim(x)[1]
-    ans <- sum(dist.dna(x, "raw", pairwise.deletion = pairwise.deletion))/
-        (n*(n - 1)/2)
-    if (variance) {
-        var <- (n + 1)*ans/(3*(n + 1)*dim(x)[2]) + 2*(n^2 + n + 3)*ans/(9*n*(n - 1))
-        ans <- c(ans, var)
-    }
-    ans
-}
-
 dist.dna <- function(x, model = "K80", variance = FALSE, gamma = FALSE,
                      pairwise.deletion = FALSE, base.freq = NULL,
                      as.matrix = FALSE)
 {
     MODELS <- c("RAW", "JC69", "K80", "F81", "K81", "F84", "T92", "TN93",
                 "GG95", "LOGDET", "BH87", "PARALIN", "N")
-    imod <- which(MODELS == toupper(model))
+    imod <- pmatch(toupper(model), MODELS)
+    if (is.na(imod))
+        stop(paste("'model' must be one of:",
+                   paste("\"", MODELS, "\"", sep = "", collapse = " ")))
     if (imod == 11 && variance) {
         warning("computing variance temporarily not available for model BH87.")
         variance <- FALSE