+
+image.DNAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "",
+ show.labels = TRUE, cex.lab = 1, legend = TRUE, ...)
+{
+ what <-
+ if (missing(what)) c("a", "g", "c", "t", "n", "-") else tolower(what)
+ if (missing(col))
+ col <- c("red", "yellow", "green", "blue", "grey", "black")
+ n <- (dx <- dim(x))[1] # number of sequences
+ s <- dx[2] # number of sites
+ y <- integer(N <- length(x))
+ ncl <- length(what)
+ col <- rep(col, length.out = ncl)
+ brks <- 0.5:(ncl + 0.5)
+ sm <- 0L
+ for (i in ncl:1) {
+ k <- ._bs_[._cs_ == what[i]]
+ sel <- which(x == k)
+ if (L <- length(sel)) {
+ y[sel] <- i
+ sm <- sm + L
+ } else {
+ what <- what[-i]
+ col <- col[-i]
+ brks <- brks[-i]
+ }
+ }
+ dim(y) <- dx
+ ## if there's no 0 in y, must drop 'bg' from the cols passed to image:
+ if (sm == N) {
+ leg.co <- co <- col
+ leg.txt <- toupper(what)
+ } else {
+ co <- c(bg, col)
+ leg.txt <- c(toupper(what), "others")
+ leg.co <- c(col, bg)
+ brks <- c(-0.5, brks)
+ }
+ yaxt <- if (show.labels) "n" else "s"
+ graphics::image.default(1:s, 1:n, t(y), col = co, xlab = xlab,
+ ylab = ylab, yaxt = yaxt, breaks = brks, ...)
+ if (show.labels)
+ mtext(rownames(x), side = 2, line = 0.1, at = 1:n,
+ cex = cex.lab, adj = 1, las = 1)
+ if (legend) {
+ psr <- par("usr")
+ xx <- psr[2]/2
+ yy <- psr[4] * (0.5 + 0.5/par("plt")[4])
+ legend(xx, yy, legend = leg.txt, pch = 22, pt.bg = leg.co,
+ pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5,
+ 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
+}