R/summary.phylo.R

   1 ## summary.phylo.R (2010-11-03)
   2
   3 ##   Print Summary of a Phylogeny and "multiPhylo" operators
   4
   5 ## Copyright 2003-2010 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     if (!is.null(attr(object, "loglik"))) {
  74         cat("Phylogeny estimated by maximum likelihood.\n")
  75         cat("  log-likelihood:", attr(object, "loglik"), "\n\n")
  76         npart <- length(attr(object, "para"))
  77         for (i in 1:npart) {
  78             cat("partition ", i, ":\n", sep = "")
  79             print(attr(object, "para")[[i]])
  80             if (i == 1) next
  81             else cat("  contrast parameter (xi):",
  82                      attr(object, "xi")[i - 1], "\n")
  83         }
  84     }
  85 }
  86
  87 ### by BB:
  88 print.phylo <- function(x, printlen = 6,...)
  89 {
  90     nb.tip <- length(x$tip.label)
  91     nb.node <- x$Nnode
  92     cat(paste("\nPhylogenetic tree with", nb.tip, "tips and", nb.node,
  93               "internal nodes.\n\n"))
  94     cat("Tip labels:\n")
  95     if (nb.tip > printlen) {
  96         cat(paste("\t", paste(x$tip.label[1:printlen],
  97                               collapse=", "), ", ...\n", sep = ""))
  98     } else print(x$tip.label)
  99     if (!is.null(x$node.label)) {
 100         cat("\tNode labels:\n")
 101         if (nb.node > printlen) {
 102             cat(paste("\t", paste(x$node.label[1:printlen],
 103                                  collapse=", "), ",...\n", sep = ""))
 104         } else print(x$node.label)
 105     }
 106     rlab <- if (is.rooted(x)) "Rooted" else "Unrooted"
 107     cat("\n", rlab, "; ", sep="")
 108
 109     blen <- if (is.null(x$edge.length)) "no branch lengths." else
 110     "includes branch lengths."
 111     cat(blen, "\n", sep = "")
 112 }
 113
 114 print.multiPhylo <- function(x, details = FALSE, ...)
 115 {
 116     N <- length(x)
 117     cat(N, "phylogenetic trees\n")
 118     if (details)
 119       for (i in 1:N)
 120         cat("tree", i, ":", length(x[[i]]$tip.label), "tips\n")
 121 }
 122
 123 "[[.multiPhylo" <- function(x, i)
 124 {
 125     class(x) <- NULL
 126     phy <- x[[i]]
 127     if (!is.null(attr(x, "TipLabel")))
 128         phy$tip.label <- attr(x, "TipLabel")
 129     phy
 130 }
 131
 132 `$.multiPhylo` <- function(x, name) x[[name]]
 133
 134 "[.multiPhylo" <- function(x, i)
 135 {
 136     oc <- oldClass(x)
 137     class(x) <- NULL
 138     structure(x[i], TipLabel = attr(x, "TipLabel"),
 139               class = oc)
 140 }
 141
 142 str.multiPhylo <- function(object, ...)
 143 {
 144     class(object) <- NULL
 145     cat('Class "multiPhylo"\n')
 146     str(object, ...)
 147 }
 148
 149 c.phylo <- function(..., recursive = FALSE)
 150     structure(list(...), class = "multiPhylo")
 151 ## only the first object in '...' is checked for its class,
 152 ## but that should be OK for the moment
 153
 154 c.multiPhylo <- function(..., recursive = FALSE)
 155 {
 156     obj <- list(...)
 157     n <- length(obj)
 158     x <- obj[[1L]]
 159     N <- length(x)
 160     i <- 1L
 161     while (i < n) {
 162         a <- N + 1L
 163         N <- N + length(obj[[i]])
 164         ## x is of class "multiPhylo", so this uses the operator below:
 165         x[a:N] <- obj[[i]]
 166         i <- i + 1L
 167     }
 168     x
 169 }
 170
 171 .uncompressTipLabel <- function(x)
 172 {
 173     Lab <- attr(x, "TipLabel")
 174     if (is.null(Lab)) return(x)
 175     class(x) <- NULL
 176     for (i in 1:length(x)) x[[i]]$tip.label <- Lab
 177     class(x) <- "multiPhylo"
 178     attr(x, "TipLabel") <- NULL
 179     x
 180 }
 181
 182 `[<-.multiPhylo` <- function(x, ..., value)
 183 {
 184     ## recycling is allowed so no need to check: length(value) != length(..1)
 185
 186     ## check that all elements in 'value' inherit class "phylo"
 187     test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo")))
 188     if (any(test))
 189         stop("at least one element in 'value' is not of class \"phylo\".")
 190
 191     oc <- oldClass(x)
 192     class(x) <- NULL
 193
 194     if (is.null(attr(x, "TipLabel"))) {
 195         x[..1] <- value
 196         class(x) <- oc
 197         return(x)
 198     }
 199
 200     x[..1] <- 0L # in case x needs to be elongated
 201     class(x) <- oc
 202     j <- 1L
 203     for (i in ..1) {
 204         ## x is of class "multiPhylo", so this uses the operator below:
 205         x[[i]] <- value[[j]]
 206         j <- j + 1L
 207     }
 208     x
 209 }
 210
 211 `[[<-.multiPhylo` <- function(x, ..., value)
 212 {
 213     if (!inherits(value, "phylo"))
 214         stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".')
 215
 216     oc <- oldClass(x)
 217     class(x) <- NULL
 218
 219     Lab <- attr(x, "TipLabel")
 220
 221     if (!is.null(Lab)) {
 222         n <- length(Lab)
 223         if (n != length(value$tip.label))
 224             stop("tree with different number of tips than those in the list (which all have the same labels; maybe you want to uncompress them)")
 225
 226         o <- match(value$tip.label, Lab)
 227         if (any(is.na(o)))
 228             stop("tree tip labels do not match with those in the list; maybe you want to uncompress them.")
 229         value$tip.label <- NULL
 230         ie <- match(o, value$edge[, 2])
 231         value$edge[ie, 2] <- 1:n
 232     }
 233
 234     x[[..1]] <- value
 235     class(x) <- oc
 236     x
 237 }
 238
 239 `$<-.multiPhylo` <- function(x, ..., value)
 240 {
 241     x[[..1]] <- value
 242     x
 243 }