-## as.phylo.R (2007-03-05)
+## as.phylo.R (2011-03-25)
## Conversion Among Tree Objects
-## Copyright 2005-2007 Emmanuel Paradis
+## Copyright 2005-2011 Emmanuel Paradis
## This file is part of the R-package `ape'.
## See the file ../COPYING for licensing issues.
as.phylo <- function (x, ...)
{
- if (class(x) == "phylo") return(x)
+ if (length(class(x)) == 1 && class(x) == "phylo")
+ return(x)
UseMethod("as.phylo")
}
edge[j:(j + 1), 1] <- node[i]
for (l in 1:2) {
k <- j + l - 1L
- if (x$merge[i, l] > 0) {
- edge[k, 2] <- node[x$merge[i, l]] <- cur.nod
+ y <- x$merge[i, l]
+ if (y > 0) {
+ edge[k, 2] <- node[y] <- cur.nod
cur.nod <- cur.nod + 1L
- edge.length[k] <- x$height[i] - x$height[x$merge[i, l]]
+ edge.length[k] <- x$height[i] - x$height[y]
} else {
- edge[k, 2] <- -x$merge[i, l]
+ edge[k, 2] <- -y
edge.length[k] <- x$height[i]
}
}
j <- j + 2L
}
if (is.null(x$labels))
- x$labels <- as.character(1:(N + 1))
- obj <- list(edge = edge, edge.length = edge.length,
+ x$labels <- as.character(1:(N + 1))
+ obj <- list(edge = edge, edge.length = edge.length / 2,
tip.label = x$labels, Nnode = N)
class(obj) <- "phylo"
reorder(obj)
{
if (!is.ultrametric(x)) stop("the tree is not ultrametric")
if (!is.binary.tree(x)) stop("the tree is not binary")
+ if (!is.rooted(x)) stop("the tree is not rooted")
n <- length(x$tip.label)
- bt <- rev(branching.times(x))
- N <- length(bt)
- nm <- as.numeric(names(bt))
+ x$node.label <- NULL # by Jinlong Zhang (2010-12-15)
+ bt <- sort(branching.times(x))
+ inode <- as.numeric(names(bt))
+ N <- n - 1L
+ nm <- numeric(N + n) # hash table
+ nm[inode] <- 1:N
merge <- matrix(NA, N, 2)
for (i in 1:N) {
- ind <- which(x$edge[, 1] == nm[i])
- for (k in 1:2)
- merge[i, k] <- if (x$edge[ind[k], 2] <= n) -x$edge[ind[k], 2]
- else which(nm == x$edge[ind[k], 2])
+ ind <- which(x$edge[, 1] == inode[i])
+ for (k in 1:2) {
+ tmp <- x$edge[ind[k], 2]
+ merge[i, k] <- if (tmp <= n) -tmp else nm[tmp]
+ }
}
names(bt) <- NULL
- obj <- list(merge = merge, height = bt, order = 1:(N + 1),
- labels = x$tip.label, call = match.call(),
- method = "unknown")
+ obj <- list(merge = merge, height = bt, order = 1:n, labels = x$tip.label,
+ call = match.call(), method = "unknown")
class(obj) <- "hclust"
obj
}
+
+as.network.phylo <- function(x, directed = is.rooted(x), ...)
+{
+ if (is.null(x$node.label)) x <- makeNodeLabel(x)
+ res <- network(x$edge, directed = directed, ...)
+ network.vertex.names(res) <- c(x$tip.label, x$node.label)
+ res
+}
+
+as.igraph <- function(x, ...) UseMethod("as.igraph")
+
+as.igraph.phylo <- function(x, directed = is.rooted(x), use.labels = TRUE, ...)
+{
+ ## local copy because x will be changed before evaluating is.rooted(x):
+ directed <- directed
+ if (use.labels) {
+ if (is.null(x$node.label)) x <- makeNodeLabel(x)
+ x$edge <- matrix(c(x$tip.label, x$node.label)[x$edge], ncol = 2)
+ } else x$edge <- x$edge - 1L
+ graph.edgelist(x$edge, directed = directed, ...)
+}