some news for ape 3.0-8

[ape.git] / R / summary.phylo.R

diff --git a/R/summary.phylo.R b/R/summary.phylo.R
index 365f615117962de5677c73542ef19d772c1d59d5..f390b24d25bbb936331e26fea1e25aa51a45dd5a 100644 (file)
--- a/R/summary.phylo.R
+++ b/R/summary.phylo.R
@@ -1,31 +1,31 @@
-## summary.phylo.R (2008-02-28)
+## summary.phylo.R (2011-08-04)
 
-##   Print Summary of a Phylogeny
+##   Print Summary of a Phylogeny and "multiPhylo" operators
 
-## Copyright 2003-2008 Emmanuel Paradis, and 2006 Ben Bolker
+## Copyright 2003-2011 Emmanuel Paradis, and 2006 Ben Bolker
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
 
 Ntip <- function(phy)
 {
-    if (class(phy) != "phylo")
-      stop('object "phy" is not of class "phylo"')
+    if (!inherits(phy, "phylo"))
+        stop('object "phy" is not of class "phylo"')
     length(phy$tip.label)
 }
 
 Nnode <- function(phy, internal.only = TRUE)
 {
-    if (class(phy) != "phylo")
-      stop('object "phy" is not of class "phylo"')
+    if (!inherits(phy, "phylo"))
+        stop('object "phy" is not of class "phylo"')
     if (internal.only) return(phy$Nnode)
     phy$Nnode + length(phy$tip.label)
 }
 
 Nedge <- function(phy)
 {
-    if (class(phy) != "phylo")
-      stop('object "phy" is not of class "phylo"')
+    if (!inherits(phy, "phylo"))
+        stop('object "phy" is not of class "phylo"')
     dim(phy$edge)[1]
 }
 
@@ -70,18 +70,6 @@ summary.phylo <- function(object, ...)
 
         }
     }
-    if (!is.null(attr(object, "loglik"))) {
-        cat("Phylogeny estimated by maximum likelihood.\n")
-        cat("  log-likelihood:", attr(object, "loglik"), "\n\n")
-        npart <- length(attr(object, "para"))
-        for (i in 1:npart) {
-            cat("partition ", i, ":\n", sep = "")
-            print(attr(object, "para")[[i]])
-            if (i == 1) next
-            else cat("  contrast parameter (xi):",
-                     attr(object, "xi")[i - 1], "\n")
-        }
-    }
 }
 
 ### by BB:
@@ -97,10 +85,10 @@ print.phylo <- function(x, printlen = 6,...)
                               collapse=", "), ", ...\n", sep = ""))
     } else print(x$tip.label)
     if (!is.null(x$node.label)) {
-        cat("\tNode labels:\n")
+        cat("Node labels:\n")
         if (nb.node > printlen) {
             cat(paste("\t", paste(x$node.label[1:printlen],
-                                 collapse=", "), ",...\n", sep = ""))
+                                 collapse=", "), ", ...\n", sep = ""))
         } else print(x$node.label)
     }
     rlab <- if (is.rooted(x)) "Rooted" else "Unrooted"
@@ -118,7 +106,6 @@ print.multiPhylo <- function(x, details = FALSE, ...)
     if (details)
       for (i in 1:N)
         cat("tree", i, ":", length(x[[i]]$tip.label), "tips\n")
-    cat("\n")
 }
 
 "[[.multiPhylo" <- function(x, i)
@@ -134,13 +121,111 @@ print.multiPhylo <- function(x, details = FALSE, ...)
 
 "[.multiPhylo" <- function(x, i)
 {
+    oc <- oldClass(x)
     class(x) <- NULL
     structure(x[i], TipLabel = attr(x, "TipLabel"),
-              class = "multiPhylo")
+              class = oc)
 }
 
 str.multiPhylo <- function(object, ...)
 {
     class(object) <- NULL
+    cat('Class "multiPhylo"\n')
     str(object, ...)
 }
+
+c.phylo <- function(..., recursive = FALSE)
+    structure(list(...), class = "multiPhylo")
+## only the first object in '...' is checked for its class,
+## but that should be OK for the moment
+
+c.multiPhylo <- function(..., recursive = FALSE)
+{
+    obj <- list(...)
+    n <- length(obj)
+    x <- obj[[1L]]
+    N <- length(x)
+    i <- 2L
+    while (i <= n) {
+        a <- N + 1L
+        N <- N + length(obj[[i]])
+        ## x is of class "multiPhylo", so this uses the operator below:
+        x[a:N] <- obj[[i]]
+        i <- i + 1L
+    }
+    x
+}
+
+.uncompressTipLabel <- function(x)
+{
+    Lab <- attr(x, "TipLabel")
+    if (is.null(Lab)) return(x)
+    class(x) <- NULL
+    for (i in 1:length(x)) x[[i]]$tip.label <- Lab
+    class(x) <- "multiPhylo"
+    attr(x, "TipLabel") <- NULL
+    x
+}
+
+`[<-.multiPhylo` <- function(x, ..., value)
+{
+    ## recycling is allowed so no need to check: length(value) != length(..1)
+
+    ## check that all elements in 'value' inherit class "phylo"
+    test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo")))
+    if (any(test))
+        stop("at least one element in 'value' is not of class \"phylo\".")
+
+    oc <- oldClass(x)
+    class(x) <- NULL
+
+    if (is.null(attr(x, "TipLabel"))) {
+        x[..1] <- value
+        class(x) <- oc
+        return(x)
+    }
+
+    x[..1] <- 0L # in case x needs to be elongated
+    class(x) <- oc
+    j <- 1L
+    for (i in ..1) {
+        ## x is of class "multiPhylo", so this uses the operator below:
+        x[[i]] <- value[[j]]
+        j <- j + 1L
+    }
+    x
+}
+
+`[[<-.multiPhylo` <- function(x, ..., value)
+{
+    if (!inherits(value, "phylo"))
+        stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".')
+
+    oc <- oldClass(x)
+    class(x) <- NULL
+
+    Lab <- attr(x, "TipLabel")
+
+    if (!is.null(Lab)) {
+        n <- length(Lab)
+        if (n != length(value$tip.label))
+            stop("tree with different number of tips than those in the list (which all have the same labels; maybe you want to uncompress them)")
+
+        o <- match(value$tip.label, Lab)
+        if (any(is.na(o)))
+            stop("tree tip labels do not match with those in the list; maybe you want to uncompress them.")
+        value$tip.label <- NULL
+        ie <- match(o, value$edge[, 2])
+        value$edge[ie, 2] <- 1:n
+    }
+
+    x[[..1]] <- value
+    class(x) <- oc
+    x
+}
+
+`$<-.multiPhylo` <- function(x, ..., value)
+{
+    x[[..1]] <- value
+    x
+}