1 ## summary.phylo.R (2011-08-04)
3 ## Print Summary of a Phylogeny and "multiPhylo" operators
5 ## Copyright 2003-2011 Emmanuel Paradis, and 2006 Ben Bolker
7 ## This file is part of the R-package `ape'.
8 ## See the file ../COPYING for licensing issues.
12 if (!inherits(phy, "phylo"))
13 stop('object "phy" is not of class "phylo"')
17 Nnode <- function(phy, internal.only = TRUE)
19 if (!inherits(phy, "phylo"))
20 stop('object "phy" is not of class "phylo"')
21 if (internal.only) return(phy$Nnode)
22 phy$Nnode + length(phy$tip.label)
25 Nedge <- function(phy)
27 if (!inherits(phy, "phylo"))
28 stop('object "phy" is not of class "phylo"')
32 summary.phylo <- function(object, ...)
34 cat("\nPhylogenetic tree:", deparse(substitute(object)), "\n\n")
35 nb.tip <- length(object$tip.label)
36 nb.node <- object$Nnode
37 cat(" Number of tips:", nb.tip, "\n")
38 cat(" Number of nodes:", nb.node, "\n")
39 if (is.null(object$edge.length))
40 cat(" No branch lengths.\n")
42 cat(" Branch lengths:\n")
43 cat(" mean:", mean(object$edge.length), "\n")
44 cat(" variance:", var(object$edge.length), "\n")
45 cat(" distribution summary:\n")
46 print(summary(object$edge.length)[-4])
48 if (is.null(object$root.edge))
49 cat(" No root edge.\n")
51 cat(" Root edge:", object$root.edge, "\n")
53 cat(" Tip labels:", object$tip.label[1], "\n")
54 cat(paste(" ", object$tip.label[-1]), sep = "\n")
57 cat(" First ten tip labels:", object$tip.label[1], "\n")
58 cat(paste(" ", object$tip.label[2:10]), sep = "\n")
60 if (is.null(object$node.label))
61 cat(" No node labels.\n")
64 cat(" Node labels:", object$node.label[1], "\n")
65 cat(paste(" ", object$node.label[-1]), sep = "\n")
68 cat(" First ten node labels:", object$node.label[1], "\n")
69 cat(paste(" ", object$node.label[2:10]), sep = "\n")
76 print.phylo <- function(x, printlen = 6,...)
78 nb.tip <- length(x$tip.label)
80 cat(paste("\nPhylogenetic tree with", nb.tip, "tips and", nb.node,
81 "internal nodes.\n\n"))
83 if (nb.tip > printlen) {
84 cat(paste("\t", paste(x$tip.label[1:printlen],
85 collapse=", "), ", ...\n", sep = ""))
86 } else print(x$tip.label)
87 if (!is.null(x$node.label)) {
88 cat("\tNode labels:\n")
89 if (nb.node > printlen) {
90 cat(paste("\t", paste(x$node.label[1:printlen],
91 collapse=", "), ", ...\n", sep = ""))
92 } else print(x$node.label)
94 rlab <- if (is.rooted(x)) "Rooted" else "Unrooted"
95 cat("\n", rlab, "; ", sep="")
97 blen <- if (is.null(x$edge.length)) "no branch lengths." else
98 "includes branch lengths."
99 cat(blen, "\n", sep = "")
102 print.multiPhylo <- function(x, details = FALSE, ...)
105 cat(N, "phylogenetic trees\n")
108 cat("tree", i, ":", length(x[[i]]$tip.label), "tips\n")
111 "[[.multiPhylo" <- function(x, i)
115 if (!is.null(attr(x, "TipLabel")))
116 phy$tip.label <- attr(x, "TipLabel")
120 `$.multiPhylo` <- function(x, name) x[[name]]
122 "[.multiPhylo" <- function(x, i)
126 structure(x[i], TipLabel = attr(x, "TipLabel"),
130 str.multiPhylo <- function(object, ...)
132 class(object) <- NULL
133 cat('Class "multiPhylo"\n')
137 c.phylo <- function(..., recursive = FALSE)
138 structure(list(...), class = "multiPhylo")
139 ## only the first object in '...' is checked for its class,
140 ## but that should be OK for the moment
142 c.multiPhylo <- function(..., recursive = FALSE)
151 N <- N + length(obj[[i]])
152 ## x is of class "multiPhylo", so this uses the operator below:
159 .uncompressTipLabel <- function(x)
161 Lab <- attr(x, "TipLabel")
162 if (is.null(Lab)) return(x)
164 for (i in 1:length(x)) x[[i]]$tip.label <- Lab
165 class(x) <- "multiPhylo"
166 attr(x, "TipLabel") <- NULL
170 `[<-.multiPhylo` <- function(x, ..., value)
172 ## recycling is allowed so no need to check: length(value) != length(..1)
174 ## check that all elements in 'value' inherit class "phylo"
175 test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo")))
177 stop("at least one element in 'value' is not of class \"phylo\".")
182 if (is.null(attr(x, "TipLabel"))) {
188 x[..1] <- 0L # in case x needs to be elongated
192 ## x is of class "multiPhylo", so this uses the operator below:
199 `[[<-.multiPhylo` <- function(x, ..., value)
201 if (!inherits(value, "phylo"))
202 stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".')
207 Lab <- attr(x, "TipLabel")
211 if (n != length(value$tip.label))
212 stop("tree with different number of tips than those in the list (which all have the same labels; maybe you want to uncompress them)")
214 o <- match(value$tip.label, Lab)
216 stop("tree tip labels do not match with those in the list; maybe you want to uncompress them.")
217 value$tip.label <- NULL
218 ie <- match(o, value$edge[, 2])
219 value$edge[ie, 2] <- 1:n
227 `$<-.multiPhylo` <- function(x, ..., value)