new code for reading FASTA files

[ape.git] / R / DNA.R

diff --git a/R/DNA.R b/R/DNA.R
index b426dbd6126728c02992f994fe408a593d2a4f27..d1b3625f0da247fe8da35377d3762a81575add2b 100644 (file)
--- a/R/DNA.R
+++ b/R/DNA.R
@@ -1,4 +1,4 @@
-## DNA.R (2012-09-13)
+## DNA.R (2012-12-27)
 
 ##   Manipulations and Comparisons of DNA Sequences
 
@@ -58,21 +58,8 @@ as.alignment <- function(x)
 
 "[.DNAbin" <- function(x, i, j, drop = FALSE)
 {
-    oc <- oldClass(x)
-    class(x) <- NULL
-    if (is.matrix(x)) {
-        if (nargs() == 2 && !missing(i)) ans <- x[i]
-        else {
-            nd <- dim(x)
-            if (missing(i)) i <- 1:nd[1]
-            if (missing(j)) j <- 1:nd[2]
-            ans <- x[i, j, drop = drop]
-        }
-    } else {
-        if (missing(i)) i <- 1:length(x)
-        ans <- x[i]
-    }
-    class(ans) <- oc
+    ans <- NextMethod("[", drop = drop)
+    class(ans) <- "DNAbin"
     ans
 }
 
@@ -293,10 +280,19 @@ as.character.DNAbin <- function(x, ...)
 
 base.freq <- function(x, freq = FALSE, all = FALSE)
 {
-    if (is.list(x)) x <- unlist(x)
-    n <- length(x)
-    BF <-.C("BaseProportion", x, as.integer(n), double(17),
-            DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")[[3]]
+    f <- function(x)
+        .C("BaseProportion", x, as.integer(length(x)), double(17),
+           DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")[[3]]
+
+    if (is.list(x)) {
+        BF <- rowSums(sapply(x, f))
+        n <- sum(sapply(x, length))
+    } else {
+        n <- length(x)
+        BF <-.C("BaseProportion", x, as.integer(n), double(17),
+                DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")[[3]]
+    }
+
     names(BF) <- c("a", "c", "g", "t", "r", "m", "w", "s",
                    "k", "y", "v", "h", "d", "b", "n", "-", "?")
     if (all) {
@@ -471,3 +467,29 @@ image.DNAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "",
                horiz = TRUE, xpd = TRUE)
     }
 }
+
+where <- function(x, pattern)
+{
+    pat <- as.DNAbin(strsplit(pattern, NULL)[[1]])
+    p <- as.integer(length(pat))
+
+    foo <- function(x, pat, p) {
+        s <- as.integer(length(x))
+        if (s < p) stop("sequence shorter than the pattern")
+        ans <- .C("where", x, pat, s, p, integer(s), 0L,
+                  DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")
+        n <- ans[[6]]
+        if (n) ans[[5]][seq_len(n)] - p + 2L else integer()
+    }
+
+    if (is.list(x)) return(lapply(x, foo, pat = pat, p = p))
+    if (is.matrix(x)) {
+        n <- nrow(x)
+        res <- vector("list", n)
+        for (i in seq_along(n))
+            res[[i]] <- foo(x[i, , drop = TRUE], pat, p)
+        names(res) <- rownames(x)
+        return(res)
+    }
+    foo(x, pat, p) # if x is a vector
+}