[Phylobase-commits] r368 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Dec 20 04:51:18 CET 2008
Author: skembel
Date: 2008-12-20 04:51:17 +0100 (Sat, 20 Dec 2008)
New Revision: 368
Modified:
pkg/R/checkdata.R
pkg/R/class-phylo4.R
pkg/R/setAs-Methods.R
Log:
Modify check and print methods to work with unrooted trees
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2008-12-20 03:44:09 UTC (rev 367)
+++ pkg/R/checkdata.R 2008-12-20 03:51:17 UTC (rev 368)
@@ -6,8 +6,8 @@
check_tree <- function(object,warn="retic",err=NULL) {
## FIXME: check for cyclicity?
- N <- nrow(object at edge)
- if (hasEdgeLength(object) && length(object at edge.length) != N)
+ nedges <- nrow(object at edge)
+ if (hasEdgeLength(object) && length(object at edge.length) != nedges)
return("edge lengths do not match number of edges")
## if (length(object at tip.label)+object at Nnode-1 != N) # does not work with multifurcations
## return("number of tip labels not consistent with number of edges and nodes")
@@ -19,14 +19,17 @@
tips <- sort(E[,2][!E[,2] %in% E[,1]])
nodes <- unique(sort(c(E)))
intnodes <- nodes[!nodes %in% tips]
+ roots <- E[which(is.na(E[,1])),2]
+ nRoots <- length(roots)
if (!(all(tips==1:ntips) && all(nodes=(ntips+1):(ntips+length(intnodes)))))
return("tips and nodes incorrectly numbered")
- nAncest <- tabulate(E[, 2],nbins=max(nodes)) ## bug fix from Jim Regetz
+ ##careful - nAncest does not work for counting nRoots in unrooted trees
+ nAncest <- tabulate(na.omit(E)[, 2],nbins=max(nodes)) ## bug fix from Jim Regetz
nDesc <- tabulate(na.omit(E[,1]))
nTips <- sum(nDesc==0)
if (!all(nDesc[1:nTips]==0))
return("nodes 1 to nTips must all be tips")
- nRoots <- sum(nAncest==0)
+ #nRoots <- sum(nAncest==0)
## no longer
##if (which(nAncest==0)!=nTips+1) {
## return("root node is not at position (nTips+1)")
Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2008-12-20 03:44:09 UTC (rev 367)
+++ pkg/R/class-phylo4.R 2008-12-20 03:51:17 UTC (rev 368)
@@ -51,7 +51,7 @@
}
## node.label for internal nodes
- nnodes <- sum(tabulate(edge[, 2]) > 0) - ntips
+ nnodes <- length(unique(c(edge))) - ntips
## if(is.null(node.label)) {
## node.label <- .genlab("N", nnodes)
## } else {
Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R 2008-12-20 03:44:09 UTC (rev 367)
+++ pkg/R/setAs-Methods.R 2008-12-20 03:51:17 UTC (rev 368)
@@ -108,34 +108,53 @@
if (is.character(checkval <- check_phylo4(from))) # check the phylo4
stop(checkval)
x <- from
- E <- edges(x) # E: matrix of edges
- ancestor <- E[, 1]
- node <- E[, 2]
- root <- which(is.na(ancestor))
- int.node <- node[(node %in% ancestor)]
- tip <- node[!(node %in% ancestor)]
- n.tip <- length(tip)
- n.int <- length(int.node)
- ## node <- c(root, node) # doesn't fit the ordering: root, other internal nodes, tips
- #node <- c(int.node, tip)
- ## retrieve the ancestor of each node
- #idx <- match(node, E[, 2]) # new ordering of the descendants/edges
- ## if (length(ancestor)>0) ancestor <- c(NA, ancestor)
- #ancestor <- E[idx, 1]
- ## branch.length <- c(x at root.edge, x at edge.length) # root.edge is not an edge length
- branch.length <- edgeLength(x)#[idx]
- if (is.null(edgeLength(x))) {
- branch.length <- rep(NA, length(node))
+ if (isRooted(x)) {
+ E <- edges(x) # E: matrix of edges
+ ancestor <- E[, 1]
+ node <- E[, 2]
+ root <- which(is.na(ancestor))
+ int.node <- node[(node %in% ancestor)]
+ tip <- node[!(node %in% ancestor)]
+ n.tip <- length(tip)
+ n.int <- length(int.node)
+ ## node <- c(root, node) # doesn't fit the ordering: root, other internal nodes, tips
+ #node <- c(int.node, tip)
+ ## retrieve the ancestor of each node
+ #idx <- match(node, E[, 2]) # new ordering of the descendants/edges
+ ## if (length(ancestor)>0) ancestor <- c(NA, ancestor)
+ #ancestor <- E[idx, 1]
+ ## branch.length <- c(x at root.edge, x at edge.length) # root.edge is not an edge length
+ branch.length <- edgeLength(x)#[idx]
+ if (is.null(edgeLength(x))) {
+ branch.length <- rep(NA, length(node))
+ }
+ ## node and tip labels ##
+ ## beware: they cannot be NULL
+ ## there are always tip labels (or check_phylo4 complains)
+ ## there may not be node labels (character(0))
+ label <- labels(x,which="all")[node]
+ node.type <- nodeType(x)[node]
+ return(data.frame(label, node, ancestor, branch.length,
+ node.type,stringsAsFactors=FALSE))
}
- ## node and tip labels ##
- ## fixme this is broken! using old assumption of order of edge matrix
- ## beware: they cannot be NULL
- ## there are always tip labels (or check_phylo4 complains)
- ## there may not be node labels (character(0))
- label <- labels(x,which="all")[node]
- node.type <- nodeType(x)[node]
- return(data.frame(label, node, ancestor, branch.length,
- node.type,stringsAsFactors=FALSE))
+ else {
+ E <- edges(x) # E: matrix of edges
+ node <- unique(c(E))
+ ancestor <- E[, 1][node]
+ #orphan <- setdiff(E[,1],E[,2])
+ branch.length <- edgeLength(x)[node]
+ if (is.null(edgeLength(x))) {
+ branch.length <- rep(NA, length(node))
+ }
+ ## node and tip labels ##
+ ## beware: they cannot be NULL
+ ## there are always tip labels (or check_phylo4 complains)
+ ## there may not be node labels (character(0))
+ label <- labels(x,which="all")[node]
+ node.type <- nodeType(x)[node]
+ return(data.frame(label, node, ancestor, branch.length,
+ node.type,stringsAsFactors=FALSE))
+ }
})
setAs(from = "phylo4d", to = "data.frame", function(from) {
More information about the Phylobase-commits
mailing list