R/as.phylo.R

   1 ## as.phylo.R (2011-03-16)
   2
   3 ##     Conversion Among Tree Objects
   4
   5 ## Copyright 2005-2011 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     if (!is.rooted(x)) stop("the tree is not rooted")
  92     n <- length(x$tip.label)
  93     x$node.label <- NULL # by Jinlong Zhang (2010-12-15)
  94     bt <- sort(branching.times(x))
  95     inode <- as.numeric(names(bt))
  96     N <- n - 1L
  97     nm <- numeric(N + n) # hash table
  98     nm[inode] <- 1:N
  99     merge <- matrix(NA, N, 2)
 100     for (i in 1:N) {
 101         ind <- which(x$edge[, 1] == inode[i])
 102         for (k in 1:2) {
 103             tmp <- x$edge[ind[k], 2]
 104             merge[i, k] <- if (tmp <= n) -tmp else nm[tmp]
 105         }
 106     }
 107     names(bt) <- NULL
 108     obj <- list(merge = merge, height = bt, order = 1:n, labels = x$tip.label,
 109                 call = match.call(), method = "unknown")
 110     class(obj) <- "hclust"
 111     obj
 112 }
 113
 114 as.network.phylo <- function(x, directed = is.rooted(x), ...)
 115 {
 116     if (is.null(x$node.label)) x <- makeNodeLabel(x)
 117     res <- network(x$edge, directed = directed, ...)
 118     network.vertex.names(res) <- c(x$tip.label, x$node.label)
 119     res
 120 }
 121
 122 as.igraph <- function(x, ...) UseMethod("as.igraph")
 123
 124 as.igraph.phylo <- function(x, directed = is.rooted(x), use.labels = TRUE, ...)
 125 {
 126     ## local copy because x will be changed before evaluating is.rooted(x):
 127     directed <- directed
 128     if (use.labels) {
 129         if (is.null(x$node.label)) x <- makeNodeLabel(x)
 130         x$edge <- matrix(c(x$tip.label, x$node.label)[x$edge], ncol = 2)
 131     } else x$edge <- x$edge - 1L
 132     graph.edgelist(x$edge, directed = directed, ...)
 133 }