R/summary.phylo.R

   1 ## summary.phylo.R (2010-05-25)
   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     cat("\n")
 122 }
 123
 124 "[[.multiPhylo" <- function(x, i)
 125 {
 126     class(x) <- NULL
 127     phy <- x[[i]]
 128     if (!is.null(attr(x, "TipLabel")))
 129         phy$tip.label <- attr(x, "TipLabel")
 130     phy
 131 }
 132
 133 `$.multiPhylo` <- function(x, name) x[[name]]
 134
 135 "[.multiPhylo" <- function(x, i)
 136 {
 137     oc <- oldClass(x)
 138     class(x) <- NULL
 139     structure(x[i], TipLabel = attr(x, "TipLabel"),
 140               class = oc)
 141 }
 142
 143 str.multiPhylo <- function(object, ...)
 144 {
 145     class(object) <- NULL
 146     cat('Class "multiPhylo"\n')
 147     str(object, ...)
 148 }
 149
 150 c.phylo <- function(..., recursive = FALSE)
 151     structure(list(...), class = "multiPhylo")
 152 ## only the first object in '...' is checked for its class,
 153 ## but that should be OK for the moment
 154
 155 c.multiPhylo <- function(..., recursive = FALSE)
 156 {
 157     obj <- list(...)
 158     n <- length(obj)
 159     x <- obj[[1L]]
 160     N <- length(x)
 161     i <- 1L
 162     while (i < n) {
 163         a <- N + 1L
 164         N <- N + length(obj[[i]])
 165         ## x is of class "multiPhylo", so this uses the operator below:
 166         x[a:N] <- obj[[i]]
 167         i <- i + 1L
 168     }
 169     x
 170 }
 171
 172 .uncompressTipLabel <- function(x)
 173 {
 174     Lab <- attr(x, "TipLabel")
 175     if (is.null(Lab)) return(x)
 176     class(x) <- NULL
 177     for (i in 1:length(x)) x[[i]]$tip.label <- Lab
 178     class(x) <- "multiPhylo"
 179     attr(x, "TipLabel") <- NULL
 180     x
 181 }
 182
 183 `[<-.multiPhylo` <- function(x, ..., value)
 184 {
 185     ## recycling is allowed so no need to check: length(value) != length(..1)
 186
 187     ## check that all elements in 'value' inherit class "phylo"
 188     test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo")))
 189     if (any(test))
 190         stop("at least one element in 'value' is not of class \"phylo\".")
 191
 192     oc <- oldClass(x)
 193     class(x) <- NULL
 194
 195     if (is.null(attr(x, "TipLabel"))) {
 196         x[..1] <- value
 197         class(x) <- oc
 198         return(x)
 199     }
 200
 201     x[..1] <- 0L # in case x needs to be elongated
 202     class(x) <- oc
 203     j <- 1L
 204     for (i in ..1) {
 205         ## x is of class "multiPhylo", so this uses the operator below:
 206         x[[i]] <- value[[j]]
 207         j <- j + 1L
 208     }
 209     x
 210 }
 211
 212 `[[<-.multiPhylo` <- function(x, ..., value)
 213 {
 214     if (!inherits(value, "phylo"))
 215         stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".')
 216
 217     oc <- oldClass(x)
 218     class(x) <- NULL
 219
 220     Lab <- attr(x, "TipLabel")
 221
 222     if (!is.null(Lab)) {
 223         n <- length(Lab)
 224         if (n != length(value$tip.label))
 225             stop("tree with different number of tips than those in the list (which all have the same labels; maybe you want to uncompress them)")
 226
 227         o <- match(value$tip.label, Lab)
 228         if (any(is.na(o)))
 229             stop("tree tip labels do not match with those in the list; maybe you want to uncompress them.")
 230         value$tip.label <- NULL
 231         ie <- match(o, value$edge[, 2])
 232         value$edge[ie, 2] <- 1:n
 233     }
 234
 235     x[[..1]] <- value
 236     class(x) <- oc
 237     x
 238 }
 239
 240 `$<-.multiPhylo` <- function(x, ..., value)
 241 {
 242     x[[..1]] <- value
 243     x
 244 }