[Phylobase-commits] r671 - in pkg: R data inst/unitTests man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Sep 29 05:10:03 CEST 2009
Author: pdc
Date: 2009-09-29 05:10:03 +0200 (Tue, 29 Sep 2009)
New Revision: 671
Modified:
pkg/R/checkdata.R
pkg/R/class-phylo4.R
pkg/R/class-phylomats.R
pkg/R/methods-phylo4.R
pkg/R/prune.R
pkg/R/setAs-Methods.R
pkg/R/treePlot.R
pkg/R/treewalk.R
pkg/data/geospiza.rda
pkg/inst/unitTests/runit.class-phylo4d.R
pkg/inst/unitTests/runit.methods-phylo4.R
pkg/inst/unitTests/runit.methods-phylo4d.R
pkg/inst/unitTests/runit.setAs-Methods.R
pkg/inst/unitTests/runit.subset.R
pkg/man/phylo4-display.Rd
pkg/man/phylo4.Rd
pkg/man/subset-methods.Rd
Log:
Merge in root NA -> 0 changes
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/checkdata.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -60,12 +60,13 @@
if (!all(nDesc[1:nTips]==0))
return("nodes 1 to nTips must all be tips")
- if (nRoots>0) {
- if (sum(is.na(E[,1]))!=1) {
- return("for a rooted tree, edge matrix must contain (exactly one) explicit root edge with ancestor==NA")
+ if (nRoots > 0) {
+ if (sum(E[, 1] == 0) != 1) {
+ return("for a rooted tree, edge matrix must contain (exactly one) explicit root edge with ancestor==0")
}
- root.node <- unname(E[which(is.na(E[,1])),2])
- if (!root.node==nTips+1)
+ root.node <- unname(E[which(E[,1] == 0), 2])
+ if (!root.node == nTips + 1)
+ ## TODO this isn't actually a requirement
return("root node must be first row of edge matrix")
}
@@ -109,7 +110,7 @@
}
else {
if(!all(names(object at node.label) %in% nodeId(object, "internal")))
- stop("Internal names for tips don't match tip ID numbers")
+ stop("Internal names for nodes don't match node ID numbers")
}
if(hasEdgeLength(object)) {
Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/class-phylo4.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -117,8 +117,10 @@
colnames(edge) <- c("ancestor", "descendant")
## number of tips and number of nodes
- ntips <- sum(tabulate(na.omit(edge[, 1])) == 0)
- nnodes <- length(unique(na.omit(c(edge)))) - ntips
+ ntips <- sum(tabulate(na.omit(edge[, 1])) == 0)
+ # all the internal nodes except the root are the ancestor of an edge
+ nnodes <- sum(unique(c(edge)) != 0) - ntips
+ ## nnodes <- length(unique(na.omit(c(edge)))) - ntips
## edge.length
edge.length <- .createEdge(value=edge.length, edgeMat=edge, type="lengths", use.names=FALSE)
Modified: pkg/R/class-phylomats.R
===================================================================
--- pkg/R/class-phylomats.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/class-phylomats.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -77,7 +77,7 @@
## add explicit root
rootnode <- which(tabulate(temptree$edgemat[,2])==0)
## add root node to edge matrix and branch lengths
- temptree$edgemat <- rbind(temptree$edgemat,c(NA,rootnode))
+ temptree$edgemat <- rbind(temptree$edgemat, c(0, rootnode))
temptree$edgelens <- c(temptree$edgelens,NA)
reorder(phylo4(temptree$edgemat,edge.length=temptree$edgelens,
tip.label=rownames(from),
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/methods-phylo4.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -92,7 +92,11 @@
if(nTips(x) == 0)
return(NULL)
else {
- listNodes <- sort(unique(as.vector(edges(x))))
+ ## strip out the root ancestor
+ nodesVect <- as.vector(edges(x))
+ nodesVect <- nodesVect[nodesVect != 0]
+ ## get a sorted list of the unique nodes
+ listNodes <- sort(unique(nodesVect))
t <- rep("internal", length(listNodes)) # FM: internal is default (I think it's safer)
names(t) <- listNodes
@@ -121,13 +125,13 @@
## 1:nTips and nodes are not (nTips+1):nNodes
nid <- switch(type,
## all nodes appear at least once in the edge matrix
- all = unique(na.omit(as.vector(E))),
+ all = unique(as.vector(E)[as.vector(E) != 0]),
## tips are nodes that do not appear in the ancestor column
tip = setdiff(E[, 2], E[, 1]),
## internals are nodes that *do* appear in the ancestor column
- internal = na.omit(unique(E[, 1])),
+ internal = unique(E[E[, 1] != 0, 1]),
## roots are nodes that have NA as ancestor
- root = if (!isRooted(x)) NA else unname(E[is.na(E[, 1]), 2]))
+ root = if (!isRooted(x)) NA else unname(E[E[, 1] == 0, 2]))
return(sort(nid))
@@ -148,7 +152,7 @@
setMethod("edges", signature(x="phylo4"),
function(x, order, drop.root=FALSE, ...) {
e <- x at edge
- if (drop.root) e <- e[!is.na(e[,1]),]
+ if (drop.root) e <- e[e[, 1] != 0, ]
e
})
@@ -170,7 +174,7 @@
isInt <- (edge[, 2] %in% edge[, 1])
edge <- edge[isInt, , drop=FALSE]
} else if (type=="root") {
- isRoot <- is.na(edge[, 1])
+ isRoot <- edge[, 1] == 0
edge <- edge[isRoot, , drop=FALSE]
} # else just use complete edge matrix if type is "all"
id <- paste(edge[, 1], edge[, 2], sep="-")
@@ -228,14 +232,14 @@
function(x) {
## hack to avoid failure on an empty object
if(nTips(x) == 0) return(FALSE)
- any(is.na(edges(x)[,1]))
+ any(edges(x)[, 1] == 0)
})
setMethod("rootNode", signature(x="phylo4"),
function(x) {
if (!isRooted(x))
return(NA)
- unname(edges(x)[which(is.na(edges(x)[,1])),2])
+ unname(edges(x)[which(edges(x)[, 1] == 0), 2])
})
setReplaceMethod("rootNode", signature(x="phylo4"),
@@ -537,7 +541,7 @@
stop("Tree must be rooted to reorder")
}
## get a root node free edge matrix
- edge <- edges(x)[!is.na(edges(x)[, 1]), ]
+ edge <- edges(x, drop.root=TRUE)
## Sort edges -- ensures that starting order of edge matrix doesn't
## affect the order of reordered trees
edge <- edge[order(edge[, 2]), ]
Modified: pkg/R/prune.R
===================================================================
--- pkg/R/prune.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/prune.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -41,7 +41,7 @@
## remove singletons
edge.length.new <- edgeLength(x)
edge.label.new <- edgeLabels(x)
- singletons <- which(tabulate(na.omit(edge.new[,1]))==1)
+ singletons <- which(tabulate(edge.new[edge.new[, 1] != 0, 1])==1)
while (length(singletons)>0) {
sing.node <- singletons[1]
@@ -62,7 +62,7 @@
edge.label.new <- edge.label.new[-match(edge.names.drop,
names(edge.label.new))]
- singletons <- which(tabulate(na.omit(edge.new[,1]))==1)
+ singletons <- which(tabulate(edge.new[edge.new[, 1] != 0, 1])==1)
}
## remove dropped elements from tip.label and node.label
@@ -96,7 +96,7 @@
}
## renumber nodes in the edge matrix
- edge.new[] <- match(edge.new, sort(unique.default(edge.new)))
+ edge.new[] <- match(edge.new, sort(unique.default(edge.new))) - 1
## update corresponding element names in the other slots
edge.names <- makeEdgeNames(edge.new)
Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/setAs-Methods.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -12,7 +12,7 @@
}
root.node <- as.numeric(setdiff(unique(from$edge[,1]), unique(from$edge[,2])))
- from$edge <- rbind(from$edge[tip.idx,],c(NA,root.node),from$edge[int.idx,])
+ from$edge <- rbind(from$edge[tip.idx,],c(0,root.node),from$edge[int.idx,])
if (!is.null(from$edge.length)) {
if (is.null(from$root.edge)) {
from$edge.length <- c(from$edge.length[tip.idx],as.numeric(NA),from$edge.length[int.idx])
@@ -192,6 +192,9 @@
if (edgeOrder == "pretty") {
node <- nodeId(from, "all")
ancestr <- ancestor(from, node)
+
+ # ancestor returns an NA, replace this w/ 0 to construct names correctly
+ ancestr[is.na(ancestr)] <- as.integer(0)
} else {
E <- edges(from)
node <- E[, 2]
Modified: pkg/R/treePlot.R
===================================================================
--- pkg/R/treePlot.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/treePlot.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -216,7 +216,6 @@
phy <- reorder(phy, 'preorder')
pedges <- edges(phy)
Nedges <- nrow(pedges) ## TODO switch to the accessor once stablized
- pedges[is.na(pedges[,1]), 1] <- -1
Ntips <- nTips(phy)
tips <- pedges[, 2] <= Ntips
if(!is.null(tip.order)) {
@@ -273,6 +272,15 @@
}
return(list(segs=segs, yy=yy))
}
+ placeHolder2 <- function() {
+ for(i in rev((Ntips + 1):nEdges(phy))) {
+ cur <- pedges[, 2] == i
+ dex <- pedges[, 1] == i
+ yy[cur] <- segs$v0y[dex] <- mean(yy[dex])
+ }
+ return(list(segs=segs, yy=yy))
+ }
+
yPos <- placeHolder()
segs <- yPos$segs
yy <- yPos$yy
Modified: pkg/R/treewalk.R
===================================================================
--- pkg/R/treewalk.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/R/treewalk.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -9,7 +9,6 @@
getNode <- function(phy, node, missing=c("warn","OK","fail")) {
missing <- match.arg(missing)
-
if (is.numeric(node) && all(floor(node) == node, na.rm=TRUE)) {
node <- as.integer(node)
}
@@ -27,12 +26,16 @@
## node numbers
rval <- names(labels(phy, "all"))[irval]
+
+ rval[node == 0] <- NA # root ancestor gets special treatment
+ rval[is.na(node)] <- NA # return NA for any NA_character_ inputs
rval <- as.integer(rval)
- rval[is.na(node)] <- NA # return NA for any NA_character_ inputs
## node labels
nmNd <- labels(phy, "all")[irval]
+
names(rval) <- nmNd
+ names(rval)[rval == 0] <- "0" # root ancestor gets special treatment
## deal with nodes that don't match
if (any(is.na(rval))) {
Modified: pkg/data/geospiza.rda
===================================================================
(Binary files differ)
Modified: pkg/inst/unitTests/runit.class-phylo4d.R
===================================================================
--- pkg/inst/unitTests/runit.class-phylo4d.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/inst/unitTests/runit.class-phylo4d.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -7,7 +7,7 @@
tr <- read.tree(text=nwk)
# create analogous phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
edge <- cbind(ancestor, descendant)
nid.tip <- 1:5
Modified: pkg/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/inst/unitTests/runit.methods-phylo4.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -7,7 +7,7 @@
tr <- read.tree(text=nwk)
# create analogous phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
edge <- cbind(ancestor, descendant)
nid.tip <- 1:5
@@ -69,7 +69,7 @@
test.edges.phylo4 <- function() {
checkIdentical(edges(phy.alt), edge)
- checkIdentical(edges(phy.alt, drop.root=TRUE), edge[!is.na(edge[,1]),])
+ checkIdentical(edges(phy.alt, drop.root=TRUE), edge[edge[,1] != 0,])
}
test.edgeOrder.phylo4 <- function() {
@@ -84,7 +84,7 @@
checkIdentical(edgeId(phy.alt, "all"), eid)
checkIdentical(edgeId(phy.alt, "tip"), eid[descendant %in% nid.tip])
checkIdentical(edgeId(phy.alt, "internal"), eid[!descendant %in% nid.tip])
- checkIdentical(edgeId(phy.alt, "root"), eid[is.na(ancestor)])
+ checkIdentical(edgeId(phy.alt, "root"), eid[ancestor == 0])
}
test.hasEdgeLength.phylo4 <- function() {
Modified: pkg/inst/unitTests/runit.methods-phylo4d.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4d.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/inst/unitTests/runit.methods-phylo4d.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -3,7 +3,7 @@
#
# create phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
edge <- cbind(ancestor, descendant)
nid.tip <- 1:5
Modified: pkg/inst/unitTests/runit.setAs-Methods.R
===================================================================
--- pkg/inst/unitTests/runit.setAs-Methods.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/inst/unitTests/runit.setAs-Methods.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -7,7 +7,7 @@
tr <- read.tree(text=nwk)
# create analogous phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
edge <- cbind(ancestor, descendant)
nid.tip <- 1:5
@@ -138,7 +138,7 @@
test.phylo4.As.phylog <- function() {
}
-test..phylo4ToDataFrame <- function() {
+test.phylo4ToDataFrame <- function() {
phy.show <- phylobase:::.phylo4ToDataFrame(phy.alt, "pretty")
checkIdentical(phy.show$label, c(lab.tip, lab.int))
checkIdentical(phy.show$node, c(nid.tip, nid.int))
Modified: pkg/inst/unitTests/runit.subset.R
===================================================================
--- pkg/inst/unitTests/runit.subset.R 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/inst/unitTests/runit.subset.R 2009-09-29 03:10:03 UTC (rev 671)
@@ -3,7 +3,7 @@
#
# create phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
edge <- cbind(ancestor, descendant)
nid.tip <- 1:5
Modified: pkg/man/phylo4-display.Rd
===================================================================
--- pkg/man/phylo4-display.Rd 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/man/phylo4-display.Rd 2009-09-29 03:10:03 UTC (rev 671)
@@ -92,7 +92,7 @@
11, 5,
11, 6,
11, 7,
- NA, 8), ncol=2, byrow=TRUE)
+ 0, 8), ncol=2, byrow=TRUE)
P2 <- phylo4(E)
nodeLabels(P2) <- as.character(nodeId(P2, "internal"))
Modified: pkg/man/phylo4.Rd
===================================================================
--- pkg/man/phylo4.Rd 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/man/phylo4.Rd 2009-09-29 03:10:03 UTC (rev 671)
@@ -79,21 +79,21 @@
\examples{
# a three species tree:
-mytree <- phylo4(x=matrix(data=c(4,1, 4,5, 5,2, 5,3,NA,4), ncol=2,
+mytree <- phylo4(x=matrix(data=c(4,1, 4,5, 5,2, 5,3, 0,4), ncol=2,
byrow=TRUE), tip.label=c("speciesA", "speciesB", "speciesC"))
mytree
plot(mytree)
# another way to specify the same tree:
-mytree <- phylo4(x=cbind(c(4,4,5,5,NA), c(1,5,2,3,4)),
+mytree <- phylo4(x=cbind(c(4, 4, 5, 5, 0), c(1, 5, 2, 3, 4)),
tip.label=c("speciesA", "speciesB", "speciesC"))
# another way:
-mytree <- phylo4(x=rbind(c(4,1), c(4,5), c(5,2), c(5,3), c(NA,4)),
+mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)),
tip.label=c("speciesA", "speciesB", "speciesC"))
# with branch lengths:
-mytree <- phylo4(x=rbind(c(4,1), c(4,5), c(5,2), c(5,3), c(NA,4)),
+mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)),
tip.label=c("speciesA", "speciesB", "speciesC"), edge.length=c(1, .2,
.8, .8, NA))
plot(mytree)
Modified: pkg/man/subset-methods.Rd
===================================================================
--- pkg/man/subset-methods.Rd 2009-09-29 02:15:27 UTC (rev 670)
+++ pkg/man/subset-methods.Rd 2009-09-29 03:10:03 UTC (rev 671)
@@ -142,7 +142,7 @@
geospiza[c(1:6,14), c("wingL", "beakD")]
## note handling of root edge length:
-edgeLength(geotree)['NA-15'] <- 0.1
+edgeLength(geotree)['0-15'] <- 0.1
geotree2 <- geotree[1:2]
## in subset tree, edge of new root extends back to the original root
edgeLength(geotree2)['NA-3']
More information about the Phylobase-commits
mailing list