[Phylobase-commits] r376 - in pkg: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Dec 20 22:10:41 CET 2008
Author: bbolker
Date: 2008-12-20 22:10:41 +0100 (Sat, 20 Dec 2008)
New Revision: 376
Modified:
pkg/R/methods-phylo4.R
pkg/R/treewalk.R
pkg/man/treewalk.Rd
Log:
rename getnodes to getNode; allow warning, error, or nothing on bogus node numbers or names;
vectorize slightly (ancestor() is now vectorized, and getNode() may work better)
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2008-12-20 20:27:03 UTC (rev 375)
+++ pkg/R/methods-phylo4.R 2008-12-20 21:10:41 UTC (rev 376)
@@ -83,7 +83,7 @@
NULL
else {
if (missing(which)) return(x at edge.length)
- n <- getnodes(x,which)
+ n <- getNode(x,which)
return(x at edge.length[n])
}
})
@@ -92,7 +92,7 @@
if(!hasEdgeLength(phy))
NULL
else {
- nd <- getnodes(phy, node)
+ nd <- getNode(phy, node)
iEdges <- which(phy at edge[,2] %in% nd)
sumEdges <- sum(phy at edge.length[iEdges],na.rm=TRUE)
sumEdges
Modified: pkg/R/treewalk.R
===================================================================
--- pkg/R/treewalk.R 2008-12-20 20:27:03 UTC (rev 375)
+++ pkg/R/treewalk.R 2008-12-20 21:10:41 UTC (rev 376)
@@ -7,49 +7,58 @@
## x = n-nTips(phy)
## so: n = x+nTips(phy)
-getnodes <- function(phy,node) {
- if (is.numeric(node) && all(floor(node)==node)) {
+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)
}
+ nolabs <- rep(!hasNodeLabels(phy),length(node))
if (is.character(node)) {
## old getNodeByLabel()
nt <- nTips(phy)
tipmatch <- match(node,labels(phy,"all"))
vals <- ifelse(!is.na(tipmatch),
tipmatch,
- if (!hasNodeLabels(phy)) { NA } else {
- nt+match(node,nodeLabels(phy))
- })
+ ifelse(nolabs,NA,nt+match(node,nodeLabels(phy))))
names(vals) <- node
- return(vals)
+ rval <- vals
} else if (is.integer(node)) {
## old getLabelByNode
nt <- nTips(phy)
vals <- ifelse(node<=nt, ## tips
labels(phy,"all")[node],
ifelse(node<=nt+nNodes(phy),
- if (!hasNodeLabels(phy)) { NA }
- else {
- nodeLabels(phy)[pmax(0,node-nt)]
- },NA))
+ ifelse(nolabs,NA,
+ nodeLabels(phy)[pmax(0,node-nt)]),
+ NA))
## pmax above to avoid error from negative indices
names(node) <- vals
- return(node)
+ rval <- node
} else stop("node must be integer or character")
+ if (any(is.na(rval))) {
+ missnodes <- names(rval)[is.na(rval)]
+ msg <- paste("some nodes missing from tree: ",paste(missnodes,collapse=","))
+ switch(missing,
+ fail=stop(msg),
+ warn=warning(msg),
+ OK={})
+ }
+ return(rval)
}
ancestor <- function(phy,node) {
- node <- getnodes(phy,node)
- r <- which(phy at edge[,2]==node)
- return(getnodes(phy,phy at edge[r,1]))
+ node2 <- getNode(phy,node)
+ ## r <- which(edges(phy)[,2]==node)
+ r <- match(node2,edges(phy)[,2])
+ return(getNode(phy,edges(phy)[r,1],missing="OK"))
}
children <- function(phy,node) {
- node <- getnodes(phy,node)
- r <- which(phy at edge[,1]==node)
- return(getnodes(phy,phy at edge[r,2]))
+ node2 <- getNode(phy,node)
+ r <- which(edges(phy)[,1]==node2)
+ return(getNode(phy,edges(phy)[r,2]))
}
## get descendants [recursively]
@@ -58,7 +67,7 @@
## FIXME: allow vector of nodes? (or just let people lapply?)
which <- match.arg(which)
if (which=="children") return(children(phy,node))
- node <- getnodes(phy,node)
+ node <- getNode(phy,node)
if (is.na(node)) stop("node ",node," not found in tree")
n <- nTips(phy)
if (node <= n) return(labels(phy,"all")[node])
@@ -71,12 +80,12 @@
descendants(phy,j,which="all"))
else l <- c(l, descendants(phy,j,which=which))
}
- return(getnodes(phy,l))
+ return(getNode(phy,l))
}
siblings <- function(phy, node, include.self=FALSE) {
v <- children(phy,ancestor(phy,node))
- if (!include.self) v <- v[v!=getnodes(phy,node)]
+ if (!include.self) v <- v[v!=getNode(phy,node)]
v
}
@@ -85,7 +94,7 @@
{
which <- match.arg(which)
if (which=="parent") return(ancestor(phy,node))
- oNode <- node <- getnodes(phy,node)
+ oNode <- node <- getNode(phy,node)
if (is.na(node)) stop("node ",node," not found in tree")
res <- numeric(0)
n <- nTips(phy)
@@ -100,7 +109,7 @@
if (anc==n+1) break
}
if(which == "ALL") res <- c(oNode, res)
- return(getnodes(phy,res))
+ return(getNode(phy,res))
}
MRCA <- function(phy, ...) {
@@ -112,7 +121,7 @@
}
## Correct behavior when the root is part of the nodes
- testNodes <- lapply(nodes, getnodes, phy=phy)
+ testNodes <- lapply(nodes, getNode, phy=phy)
## BMB: why lapply, not sapply?
lNodes <- unlist(testNodes)
if (any(is.na(lNodes)))
@@ -121,7 +130,7 @@
uniqueNodes <- unique(testNodes)
root <- nTips(phy)+1
if(root %in% uniqueNodes) {
- res <- getnodes(phy, root)
+ res <- getNode(phy, root)
return(res)
}
## Correct behavior in case of MRCA of identical taxa
@@ -131,7 +140,7 @@
}
else {
ancests <- lapply(nodes, ancestors, phy=phy, which="ALL")
- res <- getnodes(phy, max(Reduce(intersect, ancests)))
+ res <- getNode(phy, max(Reduce(intersect, ancests)))
return(res)
}
} # end MRCA
@@ -151,8 +160,8 @@
## come checks
if (is.character(checkval <- check_phylo4(x))) stop(checkval)
- t1 <- getnodes(x, node1)
- t2 <- getnodes(x, node2)
+ t1 <- getNode(x, node1)
+ t2 <- getNode(x, node2)
if(any(is.na(c(t1,t2)))) stop("wrong node specified")
if(t1==t2) return(NULL)
@@ -171,7 +180,7 @@
res <- c(comAnc,res)
}
- res <- getnodes(x, res)
+ res <- getNode(x, res)
return(res)
} # end shortestPath
@@ -190,9 +199,9 @@
## come checks
if (is.character(checkval <- check_phylo4(x))) stop(checkval)
- node <- getnodes(x, node)
+ node <- getNode(x, node)
if(any(is.na(node))) stop("wrong node specified")
- root <- getnodes(x, nTips(x)+1)
+ root <- getNode(x, nTips(x)+1)
node[node==root] <- NA
## main computations
Modified: pkg/man/treewalk.Rd
===================================================================
--- pkg/man/treewalk.Rd 2008-12-20 20:27:03 UTC (rev 375)
+++ pkg/man/treewalk.Rd 2008-12-20 21:10:41 UTC (rev 376)
@@ -5,7 +5,7 @@
\alias{ancestors}
\alias{siblings}
\alias{MRCA}
-\alias{getnodes}
+\alias{getNode}
\alias{getedges}
\alias{shortestPath}
\alias{sumEdgeLength}
@@ -18,7 +18,7 @@
phylogenetic nodes (i.e. internal nodes or tips).
}
\usage{
-getnodes(phy,node)
+getNode(phy,node,missing=c("warn","OK","fail"))
ancestors(phy, node, which=c("all","parent","ALL"))
ancestor(phy, node)
siblings(phy,node,include.self=FALSE)
@@ -32,7 +32,7 @@
\item{phy}{a \linkS4class{phylo4} object (or one inheriting from
\linkS4class{phylo4}, e.g. a \linkS4class{phylo4d} object)
}
- \item{node}{a node number (or name)}
+ \item{node}{a node ID number (or name)}
\item{which}{(\code{ancestors}) specify whether to return just direct
ancestor ("parent"), all ancestor nodes ("all"), or all ancestor
nodes including self ("ALL"); (\code{descendants})
@@ -44,9 +44,11 @@
or a vector of node numbers or names}
\item{node1}{a node number (or name)}
\item{node2}{a node number (or name)}
+ \item{missing}{what to do if some requested node IDs or names are not
+ in the tree: warn, do nothing, or stop with an error}
}
\value{
- \item{\code{getnodes}}{takes character strings corresponding to tip
+ \item{\code{getNode}}{takes character strings corresponding to tip
or node labels, or node numbers; it returns a named
vector of node numbers}
\item{\code{getedges}}{takes character strings naming terminal
@@ -77,8 +79,8 @@
data(geospiza)
nodeLabels(geospiza) <- LETTERS[1:nNodes(geospiza)]
plot(as(geospiza,"phylo4"), show.node.label=TRUE)
- getnodes(geospiza,18)
- getnodes(geospiza,"D")
+ getNode(geospiza,18)
+ getNode(geospiza,"D")
ancestor(geospiza,"E")
children(geospiza,"C")
descendants(geospiza,"D",which="tips")
@@ -91,9 +93,9 @@
shortestPath(geospiza, "fortis","fuliginosa")
shortestPath(geospiza, "F","L")
- ## identifying an edge fron its terminal node
+ ## identifying an edge from its terminal node
getedges(geospiza,c("olivacea","B","fortis"))
- getnodes(geospiza, c("olivacea","B","fortis"))
+ getNode(geospiza, c("olivacea","B","fortis"))
geospiza$edge[c(26,1,11),]
## FIXME
## if(require(ape)){ edgelabels() }
More information about the Phylobase-commits
mailing list