X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Fas.phylo.R;h=5d541bce67f3de75f947ba59caa0ea256921e4eb;hb=bfd7604547c1dd38cd97707c184bebf3525cf426;hp=b576a54e0b719992d2cf653ace068e15926566dc;hpb=50912ceb91f34227ae89432b6e6a8969a3a3f5f7;p=ape.git diff --git a/R/as.phylo.R b/R/as.phylo.R index b576a54..5d541bc 100644 --- a/R/as.phylo.R +++ b/R/as.phylo.R @@ -1,8 +1,8 @@ -## as.phylo.R (2010-09-30) +## as.phylo.R (2011-03-25) ## Conversion Among Tree Objects -## Copyright 2005-2010 Emmanuel Paradis +## Copyright 2005-2011 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. @@ -29,7 +29,8 @@ new2old.phylo <- function(phy) as.phylo <- function (x, ...) { - if (class(x) == "phylo") return(x) + if (length(class(x)) == 1 && class(x) == "phylo") + return(x) UseMethod("as.phylo") } @@ -88,21 +89,46 @@ as.hclust.phylo <- function(x, ...) { 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 <- x$Nnode:1 + n # fix by Filipe G. Vieira (2010-09-30) + 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, ...) +}