R/as.phylo.R

   1 ## as.phylo.R (2010-04-06)
   2
   3 ##     Conversion Among Tree Objects
   4
   5 ## Copyright 2005-2010 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             y <- x$merge[i, l]
  51             if (y > 0) {
  52                 edge[k, 2] <- node[y] <- cur.nod
  53                 cur.nod <- cur.nod + 1L
  54                 edge.length[k] <- x$height[i] - x$height[y]
  55             } else {
  56                 edge[k, 2] <- -y
  57                 edge.length[k] <- x$height[i]
  58             }
  59         }
  60         j <- j + 2L
  61     }
  62     if (is.null(x$labels))
  63         x$labels <- as.character(1:(N + 1))
  64     obj <- list(edge = edge, edge.length = edge.length / 2,
  65                 tip.label = x$labels, Nnode = N)
  66     class(obj) <- "phylo"
  67     reorder(obj)
  68 }
  69
  70 as.phylo.phylog <- function(x, ...)
  71 {
  72     tr <- read.tree(text = x$tre)
  73     n <- length(tr$tip.label)
  74     edge.length <- numeric(dim(tr$edge)[1])
  75     term  <- which(tr$edge[, 2] <= n)
  76     inte  <- which(tr$edge[, 2] > n)
  77     edge.length[term] <- x$leaves[tr$tip.label]
  78     edge.length[inte] <- x$nodes[tr$node.label][-1]
  79     tr$edge.length <- edge.length
  80     if (x$nodes["Root"] != 0) {
  81         tr$edge.root <- x$nodes["Root"]
  82         names(tr$edge.root) <- NULL
  83     }
  84     tr
  85 }
  86
  87 as.hclust.phylo <- function(x, ...)
  88 {
  89     if (!is.ultrametric(x)) stop("the tree is not ultrametric")
  90     if (!is.binary.tree(x)) stop("the tree is not binary")
  91     n <- length(x$tip.label)
  92     bt <- rev(branching.times(x))
  93     N <- length(bt)
  94     nm <- as.numeric(names(bt))
  95     merge <- matrix(NA, N, 2)
  96     for (i in 1:N) {
  97         ind <- which(x$edge[, 1] == nm[i])
  98         for (k in 1:2)
  99           merge[i, k] <- if (x$edge[ind[k], 2] <= n) -x$edge[ind[k], 2]
 100           else which(nm == x$edge[ind[k], 2])
 101     }
 102     names(bt) <- NULL
 103     obj <- list(merge = merge, height = bt, order = 1:(N + 1),
 104                 labels = x$tip.label, call = match.call(),
 105                 method = "unknown")
 106     class(obj) <- "hclust"
 107     obj
 108 }