From 5432a54c18f69a73d7f46899a60897e2d92fb857 Mon Sep 17 00:00:00 2001 From: paradis Date: Mon, 3 Mar 2008 17:29:31 +0000 Subject: [PATCH] update for ape 2.1-2 git-svn-id: https://svn.mpl.ird.fr/ape/dev/ape@20 6e262413-ae40-0410-9e79-b911bd7a66b7 --- Changes | 16 ++++- DESCRIPTION | 2 +- R/compar.gee.R | 2 +- R/identify.phylo.R | 13 ++-- R/nodelabels.R | 48 +++++++-------- R/plot.phylo.R | 6 +- R/read.nexus.R | 147 ++++++++++++++++++++++++++++++--------------- R/read.tree.R | 90 ++++++++++++++------------- R/scales.R | 27 ++++----- R/summary.phylo.R | 24 +++++++- man/MoranI.Rd | 3 +- man/ltt.plot.Rd | 2 +- man/print.phylo.Rd | 16 ++++- 13 files changed, 241 insertions(+), 155 deletions(-) diff --git a/Changes b/Changes index c488bf7..9a33fa8 100644 --- a/Changes +++ b/Changes @@ -3,11 +3,14 @@ NEW FEATURES + o There three new methods for the "multiPhylo" class: str, $, + and [[. + o root() gains the options 'node' and 'resolve.root' (FALSE by default) as well as its code being improved. o mltt.plot() has now an option 'log' used in the same way - than in plot.default() + than in plot.default(). BUG FIXES @@ -19,12 +22,23 @@ BUG FIXES 'cex' to draw symbols of different sizes (which has worked already for thermometers). + o read.nexus() generally failed to read very big files. + OTHER CHANGES o The argument 'family' of compar.gee() can now be a function as well as a character string. + o read.tree() and read.nexus() now return an unnamed list if + 'tree.names = NULL'. + + o read.nexus() now returns a modified object of class "multiPhylo" + when there is a TRANSLATE block in the NEXUS file: the individual + trees have no 'tip.label' vector, but the list has a 'TipLabel' + attribute. The new methods '$' and '[[' set these elements + correctly when extracting trees. + CHANGES IN APE VERSION 2.1-1 diff --git a/DESCRIPTION b/DESCRIPTION index f7c1c7a..e1d5bea 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: ape Version: 2.1-2 -Date: 2008-02-21 +Date: 2008-02-28 Title: Analyses of Phylogenetics and Evolution Author: Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong, Richard Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel, diff --git a/R/compar.gee.R b/R/compar.gee.R index 9c52460..e9075a1 100644 --- a/R/compar.gee.R +++ b/R/compar.gee.R @@ -31,7 +31,7 @@ do not match: the former were ignored in the analysis.") scale.value = scale.value)) W <- geemod$naive.variance fname <- - if is.function(family) deparse(substitute(family)) else family + if (is.function(family)) deparse(substitute(family)) else family if (fname == "binomial") W <- summary(glm(formula, family = quasibinomial, data = data))$cov.scaled N <- geemod$nobs diff --git a/R/identify.phylo.R b/R/identify.phylo.R index 108f03e..130a878 100644 --- a/R/identify.phylo.R +++ b/R/identify.phylo.R @@ -1,4 +1,4 @@ -## identify.phylo.R (2008-02-08) +## identify.phylo.R (2008-02-28) ## Graphical Identification of Nodes and Tips @@ -12,22 +12,21 @@ identify.phylo <- function(x, nodes = TRUE, tips = FALSE, { cat("Click close to a node of the tree...\n") xy <- locator(1) - Ntip <- get("last_plot.phylo$Ntip", envir = .PlotPhyloEnv) - d <- sqrt((xy$x - get("last_plot.phylo$xx", envir = .PlotPhyloEnv))^2 + - (xy$y - get("last_plot.phylo$yy", envir = .PlotPhyloEnv))^2) + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) + d <- sqrt((xy$x - lastPP$xx)^2 + (xy$y - lastPP$yy)^2) NODE <- which.min(d) res <- list() - if (NODE <= Ntip) { + if (NODE <= lastPP$Ntip) { res$tips <- if (labels) x$tip.label[NODE] else NODE return(res) } if (tips) { - TIPS <- prop.part(x)[[NODE - Ntip]] + TIPS <- prop.part(x)[[NODE - lastPP$Ntip]] res$tips <- if (labels) x$tip.label[TIPS] else TIPS } if (nodes) { if (is.null(x$node.label)) labels <- FALSE - res$nodes <- if (labels) x$node.label[NODE - Ntip] else NODE + res$nodes <- if (labels) x$node.label[NODE - lastPP$Ntip] else NODE } res } diff --git a/R/nodelabels.R b/R/nodelabels.R index 0b73597..43ffb93 100644 --- a/R/nodelabels.R +++ b/R/nodelabels.R @@ -1,4 +1,4 @@ -## nodelabels.R (2008-02-21) +## nodelabels.R (2008-02-28) ## Labelling Trees @@ -120,13 +120,10 @@ nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightblue", ...) { - xx <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv) - yy <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv) - if (missing(node)) - node <- (get("last_plot.phylo$Ntip", - envir = .PlotPhyloEnv) + 1):length(xx) - XX <- xx[node] - YY <- yy[node] + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) + if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx) + XX <- lastPP$xx[node] + YY <- lastPP$yy[node] BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, ...) } @@ -135,10 +132,10 @@ tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "yellow", ...) { - if (missing(tip)) - tip <- 1:get("last_plot.phylo$Ntip", envir = .PlotPhyloEnv) - XX <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv)[tip] - YY <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv)[tip] + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) + if (missing(tip)) tip <- 1:lastPP$Ntip + XX <- lastPP$xx[tip] + YY <- lastPP$yy[tip] BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, ...) } @@ -147,28 +144,25 @@ edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightgreen", ...) { - xx <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv) - yy <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv) - lastEdge <- get("last_plot.phylo$edge", envir = .PlotPhyloEnv) + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(edge)) { - sel <- 1:dim(lastEdge)[1] - subedge <- lastEdge + sel <- 1:dim(lastPP$edge)[1] + subedge <- lastPP$edge } else { sel <- edge - subedge <- lastEdge[sel, , drop = FALSE] + subedge <- lastPP$edge[sel, , drop = FALSE] } - if (get("last_plot.phylo$type", envir = .PlotPhyloEnv) == "phylogram") { - if(get("last_plot.phylo$direction", envir = .PlotPhyloEnv) - %in% c("rightwards", "leftwards")) { - XX <- (xx[subedge[, 1]] + xx[subedge[, 2]]) / 2 - YY <- yy[subedge[, 2]] + if (lastPP$type == "phylogram") { + if (lastPP$direction %in% c("rightwards", "leftwards")) { + XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2 + YY <- lastPP$yy[subedge[, 2]] } else { - XX <- xx[subedge[, 2]] - YY <- (yy[subedge[, 1]] + yy[subedge[, 2]]) / 2 + XX <- lastPP$xx[subedge[, 2]] + YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2 } } else { - XX <- (xx[subedge[, 1]] + xx[subedge[, 2]]) / 2 - YY <- (yy[subedge[, 1]] + yy[subedge[, 2]]) / 2 + XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2 + YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2 } BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, ...) diff --git a/R/plot.phylo.R b/R/plot.phylo.R index 6ab7a3e..3235300 100644 --- a/R/plot.phylo.R +++ b/R/plot.phylo.R @@ -1,4 +1,4 @@ -## plot.phylo.R (2008-02-08) +## plot.phylo.R (2008-02-28) ## Plot Phylogenies @@ -356,7 +356,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, label.offset = label.offset, x.lim = x.lim, y.lim = y.lim, direction = direction, tip.color = tip.color, Ntip = Ntip, Nnode = Nnode) - assing("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)), + assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)), envir = .PlotPhyloEnv) invisible(L) } @@ -515,5 +515,5 @@ plot.multiPhylo <- function(x, layout = 1, ...) par(ask = TRUE) on.exit(par(ask = FALSE)) } - for (i in x) plot(i, ...) + for (i in 1:length(x)) plot(x[[i]], ...) } diff --git a/R/read.nexus.R b/R/read.nexus.R index d20995a..0b0cacc 100644 --- a/R/read.nexus.R +++ b/R/read.nexus.R @@ -1,13 +1,26 @@ -## read.nexus.R (2007-12-22) +## read.nexus.R (2008-02-28) ## Read Tree File in Nexus Format -## Copyright 2003-2007 Emmanuel Paradis +## Copyright 2003-2008 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. -clado.build <- function(tp) { +.treeBuildWithTokens <- function(x) +{ + phy <- .Call("treeBuildWithTokens", x, PACKAGE = "ape") + dim(phy[[1]]) <- c(length(phy[[1]])/2, 2) + nms <- c("edge", "edge.length", "Nnode", "node.label") + if (length(phy) == 5) nms <- c(nms, "root.edge") + names(phy) <- nms + if (!sum(phy[[4]])) phy[[4]] <- NULL + class(phy) <- "phylo" + phy +} + +clado.build <- function(tp) +{ add.internal <- function() { edge[j, 1] <<- current.node node <<- node + 1 @@ -78,82 +91,118 @@ clado.build <- function(tp) { edge <- edge[-nb.edge, ] obj <- list(edge = edge, tip.label = tip.label, Nnode = nb.node, node.label = node.label) - obj$node.label <- if (all(obj$node.label == "NA")) NULL else gsub("^NA", "", obj$node.label) + obj$node.label <- + if (all(obj$node.label == "NA")) NULL + else gsub("^NA", "", obj$node.label) class(obj) <- "phylo" - return(obj) + obj } read.nexus <- function(file, tree.names = NULL) { - X <- scan(file = file, what = character(), sep = "\n", quiet = TRUE) - ## first remove all the comments + X <- scan(file = file, what = "", sep = "\n", quiet = TRUE) + ## remove all comments + ## (this might not work if there are square brackets within the comments) LEFT <- grep("\\[", X) RIGHT <- grep("\\]", X) - if (length(LEFT)) { - for (i in length(LEFT):1) { - if (LEFT[i] == RIGHT[i]) { - X[LEFT[i]] <- gsub("\\[.*\\]", "", X[LEFT[i]]) - } else { - X[LEFT[i]] <- gsub("\\[.*", "", X[LEFT[i]]) - X[RIGHT[i]] <- gsub(".*\\]", "", X[RIGHT[i]]) - if (LEFT[i] < RIGHT[i] - 1) X <- X[-((LEFT[i] + 1):(RIGHT[i] - 1))] - } + if (length(LEFT)) { # in case there are no comments at all + w <- LEFT == RIGHT + if (any(w)) { # in case all comments use at least 2 lines + s <- LEFT[w] + X[s] <- gsub("\\[.*\\]", "", X[s]) + } + w <- !w + if (any(w)) { + s <- LEFT[w] + X[s] <- gsub("\\[.*", "", X[s]) + sb <- RIGHT[w] + X[sb] <- gsub(".*\\]", "", X[sb]) + if (any(s < sb - 1)) + X <- X[-unlist(mapply(":", (s + 1), (sb - 1)))] } } - X <- gsub("ENDBLOCK;", "END;", X, ignore.case = TRUE) - endblock <- grep("END;", X, ignore.case = TRUE) + endblock <- grep("END;|ENDBLOCK;", X, ignore.case = TRUE) semico <- grep(";", X) i1 <- grep("BEGIN TREES;", X, ignore.case = TRUE) i2 <- grep("TRANSLATE", X, ignore.case = TRUE) - translation <- FALSE - if (length(i2) == 1) if (i2 > i1) translation <- TRUE + translation <- if (length(i2) == 1 && i2 > i1) TRUE else FALSE if (translation) { end <- semico[semico > i2][1] - x <- paste(X[i2:end], sep = "", collapse = "") - x <- gsub("TRANSLATE", "", x, ignore.case = TRUE) + x <- X[(i2 + 1):end] # assumes there's a 'new line' after "TRANSLATE" + ## x <- gsub("TRANSLATE", "", x, ignore.case = TRUE) x <- unlist(strsplit(x, "[,; \t]")) - x <- x[x != ""] + x <- x[nzchar(x)] TRANS <- matrix(x, ncol = 2, byrow = TRUE) TRANS[, 2] <- gsub("['\"]", "", TRANS[, 2]) + n <- dim(TRANS)[1] } - start <- if (translation) semico[semico > i2][1] + 1 else semico[semico > i1][1] + start <- + if (translation) semico[semico > i2][1] + 1 + else semico[semico > i1][1] end <- endblock[endblock > i1][1] - 1 - tree <- paste(X[start:end], sep = "", collapse = "") - tree <- gsub(" ", "", tree) - tree <- unlist(strsplit(tree, "[=;]")) - tree <- tree[grep("[\\(\\)]", tree)] - nb.tree <- length(tree) - STRING <- as.list(tree) - trees <- list() - for (i in 1:nb.tree) { - obj <- if (length(grep(":", STRING[[i]]))) tree.build(STRING[[i]]) else clado.build(STRING[[i]]) + tree <- X[start:end] + rm(X) + tree <- gsub("^.*= *", "", tree) + semico <- grep(";", tree) + Ntree <- length(semico) + ## are some trees on several lines? + if (any(diff(semico) != 1)) { + STRING <- character(Ntree) + s <- c(1, semico[-Ntree] + 1) + j <- mapply(":", s, semico) + for (i in 1:Ntree) + STRING[i] <- paste(tree[j[, i]], collapse = "") + } else STRING <- tree + rm(tree) + STRING <- gsub(" ", "", STRING) + colon <- grep(":", STRING) + if (!length(colon)) { + trees <- lapply(STRING, clado.build) + } else if (length(colon) == Ntree) { + trees <- + if (translation) lapply(STRING, .treeBuildWithTokens) + else lapply(STRING, tree.build) + } else { + trees <- vector("list", Ntree) + trees[colon] <- lapply(STRING[colon], tree.build) + nocolon <- (1:Ntree)[!1:Ntree %in% colon] + trees[nocolon] <- lapply(STRING[nocolon], clado.build) if (translation) { - for (j in 1:length(obj$tip.label)) { - ind <- which(obj$tip.label[j] == TRANS[, 1]) - obj$tip.label[j] <- TRANS[ind, 2] - } - if (!is.null(obj$node.label)) { - for (j in 1:length(obj$node.label)) { - ind <- which(obj$node.label[j] == TRANS[, 1]) - obj$node.label[j] <- TRANS[ind, 2] + for (i in 1:Ntree) { + tr <- trees[[i]] + for (j in 1:n) { + ind <- which(tr$tip.label[j] == TRANS[, 1]) + tr$tip.label[j] <- TRANS[ind, 2] } + if (!is.null(tr$node.label)) { + for (j in 1:length(tr$node.label)) { + ind <- which(tr$node.label[j] == TRANS[, 1]) + tr$node.label[j] <- TRANS[ind, 2] + } + } + trees[[i]] <- tr } + translation <- FALSE } + } + for (i in 1:Ntree) { + tr <- trees[[i]] ## Check here that the root edge is not incorrectly represented ## in the object of class "phylo" by simply checking that there ## is a bifurcation at the root - ROOT <- length(obj$tip.label) + 1 - if (sum(obj$edge[, 1] == ROOT) == 1 && dim(obj$edge)[1] > 1) { + if (!translation) n <- length(tr$tip.label) + ROOT <- n + 1 + if (sum(tr$edge[, 1] == ROOT) == 1 && dim(tr$edge)[1] > 1) { stop(paste("There is apparently two root edges in your file: cannot read tree file.\n Reading NEXUS file aborted at tree no.", i, sep = "")) } - trees[[i]] <- obj } - if (nb.tree == 1) trees <- trees[[1]] else { - names(trees) <- if (is.null(tree.names)) - paste("tree", 1:nb.tree, sep = "") else tree.names + if (Ntree == 1) trees <- trees[[1]] else { + if (!is.null(tree.names)) names(trees) <- tree.names + if (translation) attr(trees, "TipLabel") <- TRANS[, 2] class(trees) <- "multiPhylo" } - if (length(grep("[\\/]", file)) == 1) attr(trees, "origin") <- file - else attr(trees, "origin") <- paste(getwd(), file, sep = "/") + if (length(grep("[\\/]", file)) == 1) + file <- paste(getwd(), file, sep = "/") + attr(trees, "origin") <- file trees } diff --git a/R/read.tree.R b/R/read.tree.R index ff6d9ef..cbcfd3f 100644 --- a/R/read.tree.R +++ b/R/read.tree.R @@ -1,8 +1,8 @@ -## read.tree.R (2007-12-22) +## read.tree.R (2008-02-18) ## Read Tree Files in Parenthetic Format -## Copyright 2002-2007 Emmanuel Paradis +## Copyright 2002-2008 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. @@ -11,8 +11,8 @@ tree.build <- function(tp) { add.internal <- function() { edge[j, 1] <<- current.node - edge[j, 2] <<- current.node <<- node <<- node + 1 - j <<- j + 1 + edge[j, 2] <<- current.node <<- node <<- node + 1L + j <<- j + 1L } add.terminal <- function() { edge[j, 1] <<- current.node @@ -20,32 +20,34 @@ tree.build <- function(tp) X <- unlist(strsplit(tpc[k], ":")) tip.label[tip] <<- X[1] edge.length[j] <<- as.numeric(X[2]) - k <<- k + 1 - tip <<- tip + 1 - j <<- j + 1 + k <<- k + 1L + tip <<- tip + 1L + j <<- j + 1L } go.down <- function() { l <- which(edge[, 2] == current.node) X <- unlist(strsplit(tpc[k], ":")) node.label[current.node - nb.tip] <<- X[1] edge.length[l] <<- as.numeric(X[2]) - k <<- k + 1 + k <<- k + 1L current.node <<- edge[l, 1] } if (!length(grep(",", tp))) { - obj <- list(edge = matrix(c(2, 1), 1, 2)) + obj <- list(edge = matrix(c(2L, 1L), 1, 2)) tp <- unlist(strsplit(tp, "[\\(\\):;]")) obj$edge.length <- as.numeric(tp[3]) - obj$Nnode <- 1 + obj$Nnode <- 1L obj$tip.label <- tp[2] if (length(tp) == 4) obj$node.label <- tp[4] class(obj) <- "phylo" return(obj) } - tsp <- unlist(strsplit(tp, NULL)) + tpc <- unlist(strsplit(tp, "[\\(\\),;]")) - tpc <- tpc[tpc != ""] - skeleton <- tsp[tsp == "(" | tsp == ")" | tsp == "," | tsp == ";"] + tpc <- tpc[nzchar(tpc)] + ## the following 2 lines are (slightly) faster than using gsub() + tsp <- unlist(strsplit(tp, NULL)) + skeleton <- tsp[tsp %in% c("(", ")", ",", ";")] nsk <- length(skeleton) nb.node <- sum(skeleton == ")") nb.tip <- sum(skeleton == ",") + 1 @@ -56,15 +58,14 @@ tree.build <- function(tp) tip.label <- character(nb.tip) edge.length <- numeric(nb.edge) - edge <- matrix(NA, nb.edge, 2) - current.node <- node <- nb.tip + 1 # node number - edge[nb.edge, 1] <- 0 # see comment above + edge <- matrix(0L, nb.edge, 2) + current.node <- node <- as.integer(nb.tip + 1) # node number edge[nb.edge, 2] <- node # ## j: index of the line number of edge ## k: index of the line number of tpc ## tip: tip number - j <- k <- tip <- 1 + j <- k <- tip <- 1L for (i in 2:nsk) { if (skeleton[i] == "(") add.internal() # add an internal branch (on top) @@ -79,16 +80,16 @@ tree.build <- function(tp) if (skeleton[i - 1] == ")") go.down() # go down one level } } - if (is.na(node.label[1])) node.label[1] <- "" + edge <- edge[-nb.edge, ] + obj <- list(edge = edge, Nnode = nb.node, tip.label = tip.label) root.edge <- edge.length[nb.edge] edge.length <- edge.length[-nb.edge] - obj <- list(edge = edge, edge.length = edge.length, Nnode = nb.node, - tip.label = tip.label, node.label = node.label, - root.edge = root.edge) - if (all(obj$node.label == "")) obj$node.label <- NULL - if (is.na(obj$root.edge)) obj$root.edge <- NULL - if (all(is.na(obj$edge.length))) obj$edge.length <- NULL # added 2005-08-18 + if (!all(is.na(edge.length))) # added 2005-08-18 + obj$edge.length <- edge.length + if (is.na(node.label[1])) node.label[1] <- "" + if (any(nzchar(node.label))) obj$node.label <- node.label + if (!is.na(root.edge)) obj$root.edge <- root.edge class(obj) <- "phylo" obj } @@ -101,7 +102,7 @@ read.tree <- function(file = "", text = NULL, tree.names = NULL, stop("argument `text' must be of mode character") tree <- text } else { - tree <- scan(file = file, what = character(), sep = "\n", quiet = TRUE, + tree <- scan(file = file, what = "", sep = "\n", quiet = TRUE, skip = skip, comment.char = comment.char, ...) } ## Suggestion from Eric Durand and Nicolas Bortolussi (added 2005-08-17): @@ -110,33 +111,36 @@ read.tree <- function(file = "", text = NULL, tree.names = NULL, return(NULL) } tree <- gsub("[ \t]", "", tree) - tsp <- unlist(strsplit(tree, NULL)) - ind <- which(tsp == ";") - nb.tree <- length(ind) - x <- c(1, ind[-nb.tree] + 1) - y <- ind - 1 + tree <- unlist(strsplit(tree, NULL)) + y <- which(tree == ";") + Ntree <- length(y) + x <- c(1, y[-Ntree] + 1) ## Suggestion from Olivier François (added 2006-07-15): if (is.na(y[1])) return(NULL) - else { - STRING <- vector("list", nb.tree) - for (i in 1:nb.tree) - STRING[[i]] <- paste(tsp[x[i]:y[i]], sep = "", collapse = "") + STRING <- character(Ntree) + for (i in 1:Ntree) + STRING[i] <- paste(tree[x[i]:y[i]], sep = "", collapse = "") + colon <- grep(":", STRING) + if (!length(colon)) { + obj <- lapply(STRING, clado.build) + } else if (length(colon) == Ntree) { + obj <- lapply(STRING, tree.build) + } else { + obj <- vector("list", Ntree) + obj[colon] <- lapply(STRING[colon], tree.build) + nocolon <- (1:Ntree)[!1:Ntree %in% colon] + obj[nocolon] <- lapply(STRING[nocolon], clado.build) } - obj <- vector("list", nb.tree) - for (i in 1:nb.tree) { - obj[[i]] <- if (length(grep(":", STRING[[i]]))) tree.build(STRING[[i]]) else clado.build(STRING[[i]]) + for (i in 1:Ntree) { ## Check here that the root edge is not incorrectly represented ## in the object of class "phylo" by simply checking that there ## is a bifurcation at the root ROOT <- length(obj[[i]]$tip.label) + 1 - if(sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 1) { + if(sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 1) stop(paste("There is apparently two root edges in your file: cannot read tree file.\n Reading Newick file aborted at tree no.", i, sep = "")) - } } - if (nb.tree == 1) obj <- obj[[1]] else { - if (is.null(tree.names)) - tree.names <- paste("tree", 1:nb.tree, sep = "") - names(obj) <- tree.names + if (Ntree == 1) obj <- obj[[1]] else { + if (!is.null(tree.names)) names(obj) <- tree.names class(obj) <- "multiPhylo" } obj diff --git a/R/scales.R b/R/scales.R index 69c9f46..c8da7e7 100644 --- a/R/scales.R +++ b/R/scales.R @@ -1,4 +1,4 @@ -## scales.R (2008-02-08) +## scales.R (2008-02-28) ## Add a Scale Bar or Axis to a Phylogeny Plot @@ -12,9 +12,9 @@ add.scale.bar <- function(x = 0, y = 1, length = NULL, ...) { + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (is.null(length)) { - nb.digit <- ceiling(log10(mean(get("last_plot.phylo$xx", - envir = .PlotPhyloEnv)))) - 2 + nb.digit <- ceiling(log10(mean(lastPP$xx))) - 2 length <- eval(parse(text = paste("1e", nb.digit, sep = ""))) } segments(x, y, x + length, y) @@ -23,23 +23,20 @@ add.scale.bar <- function(x = 0, y = 1, length = NULL, ...) axisPhylo <- function(side = 1, ...) { - type <- get("last_plot.phylo$type", envir = .PlotPhyloEnv) - direction <- get("last_plot.phylo$direction", envir = .PlotPhyloEnv) - if (type %in% c("phylogram", "cladogram")) { - if (direction %in% c("rightwards", "leftwards")) { - xx <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv) - x <- pretty(xx) - if (direction == "rightwards") maxi <- max(xx) + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) + if (lastPP$type %in% c("phylogram", "cladogram")) { + if (lastPP$direction %in% c("rightwards", "leftwards")) { + x <- pretty(lastPP$xx) + if (lastPP$direction == "rightwards") maxi <- max(lastPP$xx) else { - maxi <- min(xx) + maxi <- min(lastPP$xx) x <- -x } } else { - yy <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv) - x <- pretty(yy) - if (direction == "upwards") maxi <- max(yy) + x <- pretty(lastPP$yy) + if (lastPP$direction == "upwards") maxi <- max(lastPP$yy) else { - maxi <- min(yy) + maxi <- min(lastPP$yy) x <- -x } } diff --git a/R/summary.phylo.R b/R/summary.phylo.R index cffe0d1..365f615 100644 --- a/R/summary.phylo.R +++ b/R/summary.phylo.R @@ -1,8 +1,8 @@ -## summary.phylo.R (2007-12-29) +## summary.phylo.R (2008-02-28) ## Print Summary of a Phylogeny -## Copyright 2003-2007 Emmanuel Paradis, and 2006 Ben Bolker +## Copyright 2003-2008 Emmanuel Paradis, and 2006 Ben Bolker ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. @@ -121,8 +121,26 @@ print.multiPhylo <- function(x, details = FALSE, ...) cat("\n") } +"[[.multiPhylo" <- function(x, i) +{ + class(x) <- NULL + phy <- x[[i]] + if (!is.null(attr(x, "TipLabel"))) + phy$tip.label <- attr(x, "TipLabel") + phy +} + +`$.multiPhylo` <- function(x, name) x[[name]] + "[.multiPhylo" <- function(x, i) { class(x) <- NULL - structure(x[i], class = "multiPhylo") + structure(x[i], TipLabel = attr(x, "TipLabel"), + class = "multiPhylo") +} + +str.multiPhylo <- function(object, ...) +{ + class(object) <- NULL + str(object, ...) } diff --git a/man/MoranI.Rd b/man/MoranI.Rd index f1a062a..50eb63b 100644 --- a/man/MoranI.Rd +++ b/man/MoranI.Rd @@ -28,8 +28,7 @@ Moran's I coefficient is computed using the formula: \deqn{I = \frac{n}{S_0} \frac{\sum_{i=1}^n\sum_{j=1}^n w_{i,j}(y_i - \overline{y})(y_j - \overline{y})}{\sum_{i=1}^n {(y_i - - \overline{y})}^2}} - {\code{I = n/S0 * (sum\{i=1..n\} sum\{j=1..n\} wij(yi - ym))(yj - ym) + \overline{y})}^2}}{\code{I = n/S0 * (sum\{i=1..n\} sum\{j=1..n\} wij(yi - ym))(yj - ym) / (sum\{i=1..n\} (yi - ym)^2)}} with \itemize{ diff --git a/man/ltt.plot.Rd b/man/ltt.plot.Rd index b090250..2b192ef 100644 --- a/man/ltt.plot.Rd +++ b/man/ltt.plot.Rd @@ -7,7 +7,7 @@ ltt.plot(phy, xlab = "Time", ylab = "N", ...) ltt.lines(phy, ...) mltt.plot(phy, ..., dcol = TRUE, dlty = FALSE, legend = TRUE, - xlab = "Time", ylab = "N", log = "")) + xlab = "Time", ylab = "N", log = "") } \arguments{ \item{phy}{an object of class \code{"phylo"}; this could be an object diff --git a/man/print.phylo.Rd b/man/print.phylo.Rd index f0b83a4..1d216b3 100644 --- a/man/print.phylo.Rd +++ b/man/print.phylo.Rd @@ -2,27 +2,39 @@ \alias{print.phylo} \alias{print.multiPhylo} \alias{[.multiPhylo} +\alias{[[.multiPhylo} +\alias{$.multiPhylo} +\alias{str.multiPhylo} \title{Compact Display of a Phylogeny} \usage{ \method{print}{phylo}(x, printlen = 6 ,...) \method{print}{multiPhylo}(x, details = FALSE ,...) \method{[}{multiPhylo}(x, i) +\method{[[}{multiPhylo}(x, i) +\method{$}{multiPhylo}(x, name) +\method{str}{multiPhylo}(object, ...) } \arguments{ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} + \item{object}{an object of class \code{"multiPhylo"}.} \item{printlen}{the number of labels to print (6 by default).} \item{details}{a logical indicating whether to print information on all trees.} - \item{i}{indices of the trees to select from a list; this may be a + \item{i}{indices of the tree(s) to select from a list; this may be a vector of integers, logicals, or names.} + \item{name}{a character string specifying the tree to be extracted.} \item{...}{further arguments passed to or from other methods.} } \description{ These functions prints a compact summary of a phylogeny, or a list of, on the console. + + The operators \code{[}, \code{[[}, and \code{$} propagate the class + correctly. } \value{ - An object of class \code{"multiPhylo"} or NULL. + An object of class \code{"phylo"} (\code{[[}, \code{$}) or of class + \code{"multiPhylo"} (\code{[[}), or NULL. } \author{Ben Bolker \email{bolker@zoo.ufl.edu} and Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}} -- 2.39.5