R/summary.phylo.R

   1 ## summary.phylo.R (2011-08-04)
   2
   3 ##   Print Summary of a Phylogeny and "multiPhylo" operators
   4
   5 ## Copyright 2003-2011 Emmanuel Paradis, and 2006 Ben Bolker
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 Ntip <- function(phy)
  11 {
  12     if (!inherits(phy, "phylo"))
  13         stop('object "phy" is not of class "phylo"')
  14     length(phy$tip.label)
  15 }
  16
  17 Nnode <- function(phy, internal.only = TRUE)
  18 {
  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)
  23 }
  24
  25 Nedge <- function(phy)
  26 {
  27     if (!inherits(phy, "phylo"))
  28         stop('object "phy" is not of class "phylo"')
  29     dim(phy$edge)[1]
  30 }
  31
  32 summary.phylo <- function(object, ...)
  33 {
  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")
  41     else {
  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])
  47     }
  48     if (is.null(object$root.edge))
  49       cat("  No root edge.\n")
  50     else
  51       cat("  Root edge:", object$root.edge, "\n")
  52     if (nb.tip <= 10) {
  53         cat("  Tip labels:", object$tip.label[1], "\n")
  54         cat(paste("             ", object$tip.label[-1]), sep = "\n")
  55     }
  56     else {
  57         cat("  First ten tip labels:", object$tip.label[1], "\n")
  58         cat(paste("                       ", object$tip.label[2:10]), sep = "\n")
  59     }
  60     if (is.null(object$node.label))
  61       cat("  No node labels.\n")
  62     else {
  63         if (nb.node <= 10) {
  64             cat("  Node labels:", object$node.label[1], "\n")
  65             cat(paste("              ", object$node.label[-1]), sep = "\n")
  66         }
  67         else {
  68             cat("  First ten node labels:", object$node.label[1], "\n")
  69             cat(paste("                        ", object$node.label[2:10]), sep = "\n")
  70
  71         }
  72     }
  73 }
  74
  75 ### by BB:
  76 print.phylo <- function(x, printlen = 6,...)
  77 {
  78     nb.tip <- length(x$tip.label)
  79     nb.node <- x$Nnode
  80     cat(paste("\nPhylogenetic tree with", nb.tip, "tips and", nb.node,
  81               "internal nodes.\n\n"))
  82     cat("Tip labels:\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)
  93     }
  94     rlab <- if (is.rooted(x)) "Rooted" else "Unrooted"
  95     cat("\n", rlab, "; ", sep="")
  96
  97     blen <- if (is.null(x$edge.length)) "no branch lengths." else
  98     "includes branch lengths."
  99     cat(blen, "\n", sep = "")
 100 }
 101
 102 print.multiPhylo <- function(x, details = FALSE, ...)
 103 {
 104     N <- length(x)
 105     cat(N, "phylogenetic trees\n")
 106     if (details)
 107       for (i in 1:N)
 108         cat("tree", i, ":", length(x[[i]]$tip.label), "tips\n")
 109 }
 110
 111 "[[.multiPhylo" <- function(x, i)
 112 {
 113     class(x) <- NULL
 114     phy <- x[[i]]
 115     if (!is.null(attr(x, "TipLabel")))
 116         phy$tip.label <- attr(x, "TipLabel")
 117     phy
 118 }
 119
 120 `$.multiPhylo` <- function(x, name) x[[name]]
 121
 122 "[.multiPhylo" <- function(x, i)
 123 {
 124     oc <- oldClass(x)
 125     class(x) <- NULL
 126     structure(x[i], TipLabel = attr(x, "TipLabel"),
 127               class = oc)
 128 }
 129
 130 str.multiPhylo <- function(object, ...)
 131 {
 132     class(object) <- NULL
 133     cat('Class "multiPhylo"\n')
 134     str(object, ...)
 135 }
 136
 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
 141
 142 c.multiPhylo <- function(..., recursive = FALSE)
 143 {
 144     obj <- list(...)
 145     n <- length(obj)
 146     x <- obj[[1L]]
 147     N <- length(x)
 148     i <- 2L
 149     while (i <= n) {
 150         a <- N + 1L
 151         N <- N + length(obj[[i]])
 152         ## x is of class "multiPhylo", so this uses the operator below:
 153         x[a:N] <- obj[[i]]
 154         i <- i + 1L
 155     }
 156     x
 157 }
 158
 159 .uncompressTipLabel <- function(x)
 160 {
 161     Lab <- attr(x, "TipLabel")
 162     if (is.null(Lab)) return(x)
 163     class(x) <- NULL
 164     for (i in 1:length(x)) x[[i]]$tip.label <- Lab
 165     class(x) <- "multiPhylo"
 166     attr(x, "TipLabel") <- NULL
 167     x
 168 }
 169
 170 `[<-.multiPhylo` <- function(x, ..., value)
 171 {
 172     ## recycling is allowed so no need to check: length(value) != length(..1)
 173
 174     ## check that all elements in 'value' inherit class "phylo"
 175     test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo")))
 176     if (any(test))
 177         stop("at least one element in 'value' is not of class \"phylo\".")
 178
 179     oc <- oldClass(x)
 180     class(x) <- NULL
 181
 182     if (is.null(attr(x, "TipLabel"))) {
 183         x[..1] <- value
 184         class(x) <- oc
 185         return(x)
 186     }
 187
 188     x[..1] <- 0L # in case x needs to be elongated
 189     class(x) <- oc
 190     j <- 1L
 191     for (i in ..1) {
 192         ## x is of class "multiPhylo", so this uses the operator below:
 193         x[[i]] <- value[[j]]
 194         j <- j + 1L
 195     }
 196     x
 197 }
 198
 199 `[[<-.multiPhylo` <- function(x, ..., value)
 200 {
 201     if (!inherits(value, "phylo"))
 202         stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".')
 203
 204     oc <- oldClass(x)
 205     class(x) <- NULL
 206
 207     Lab <- attr(x, "TipLabel")
 208
 209     if (!is.null(Lab)) {
 210         n <- length(Lab)
 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)")
 213
 214         o <- match(value$tip.label, Lab)
 215         if (any(is.na(o)))
 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
 220     }
 221
 222     x[[..1]] <- value
 223     class(x) <- oc
 224     x
 225 }
 226
 227 `$<-.multiPhylo` <- function(x, ..., value)
 228 {
 229     x[[..1]] <- value
 230     x
 231 }