R/as.phylo.R

   1 ## as.phylo.R (2007-03-05)
   2
   3 ##     Conversion Among Tree Objects
   4
   5 ## Copyright 2005-2007 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 old2new.phylo <- function(phy)
  11 {
  12     mode(phy$edge) <- "numeric"
  13     phy$Nnode <- -min(phy$edge)
  14     n <- length(phy$tip.label)
  15     NODES <- phy$edge < 0
  16     phy$edge[NODES] <- n - phy$edge[NODES]
  17     phy
  18 }
  19
  20 new2old.phylo <- function(phy)
  21 {
  22     NTIP <- length(phy$tip.label)
  23     NODES <- phy$edge > NTIP
  24     phy$edge[NODES] <- NTIP - phy$edge[NODES]
  25     mode(phy$edge) <- "character"
  26     phy$Nnode <- NULL
  27     phy
  28 }
  29
  30 as.phylo <- function (x, ...)
  31 {
  32     if (class(x) == "phylo") return(x)
  33     UseMethod("as.phylo")
  34 }
  35
  36 as.phylo.hclust <- function(x, ...)
  37 {
  38     N <- dim(x$merge)[1]
  39     edge <- matrix(0L, 2*N, 2)
  40     edge.length <- numeric(2*N)
  41     ## `node' gives the number of the node for the i-th row of x$merge
  42     node <- integer(N)
  43     node[N] <- N + 2L
  44     cur.nod <- N + 3L
  45     j <- 1L
  46     for (i in N:1) {
  47         edge[j:(j + 1), 1] <- node[i]
  48         for (l in 1:2) {
  49             k <- j + l - 1L
  50             if (x$merge[i, l] > 0) {
  51                 edge[k, 2] <- node[x$merge[i, l]] <- cur.nod
  52                 cur.nod <- cur.nod + 1L
  53                 edge.length[k] <- x$height[i] - x$height[x$merge[i, l]]
  54             } else {
  55                 edge[k, 2] <- -x$merge[i, l]
  56                 edge.length[k] <- x$height[i]
  57             }
  58         }
  59         j <- j + 2L
  60     }
  61     if (is.null(x$labels))
  62       x$labels <- as.character(1:(N + 1))
  63     obj <- list(edge = edge, edge.length = edge.length,
  64                 tip.label = x$labels, Nnode = N)
  65     class(obj) <- "phylo"
  66     reorder(obj)
  67 }
  68
  69 as.phylo.phylog <- function(x, ...)
  70 {
  71     tr <- read.tree(text = x$tre)
  72     n <- length(tr$tip.label)
  73     edge.length <- numeric(dim(tr$edge)[1])
  74     term  <- which(tr$edge[, 2] <= n)
  75     inte  <- which(tr$edge[, 2] > n)
  76     edge.length[term] <- x$leaves[tr$tip.label]
  77     edge.length[inte] <- x$nodes[tr$node.label][-1]
  78     tr$edge.length <- edge.length
  79     if (x$nodes["Root"] != 0) {
  80         tr$edge.root <- x$nodes["Root"]
  81         names(tr$edge.root) <- NULL
  82     }
  83     tr
  84 }
  85
  86 as.hclust.phylo <- function(x, ...)
  87 {
  88     if (!is.ultrametric(x)) stop("the tree is not ultrametric")
  89     if (!is.binary.tree(x)) stop("the tree is not binary")
  90     n <- length(x$tip.label)
  91     bt <- rev(branching.times(x))
  92     N <- length(bt)
  93     nm <- as.numeric(names(bt))
  94     merge <- matrix(NA, N, 2)
  95     for (i in 1:N) {
  96         ind <- which(x$edge[, 1] == nm[i])
  97         for (k in 1:2)
  98           merge[i, k] <- if (x$edge[ind[k], 2] <= n) -x$edge[ind[k], 2]
  99           else which(nm == x$edge[ind[k], 2])
 100     }
 101     names(bt) <- NULL
 102     obj <- list(merge = merge, height = bt, order = 1:(N + 1),
 103                 labels = x$tip.label, call = match.call(),
 104                 method = "unknown")
 105     class(obj) <- "hclust"
 106     obj
 107 }