[Phylobase-commits] r826 - in pkg: . R inst/unitTests man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Feb 11 00:00:55 CET 2011
Author: francois
Date: 2011-02-11 00:00:55 +0100 (Fri, 11 Feb 2011)
New Revision: 826
Modified:
pkg/NAMESPACE
pkg/R/methods-phylo4.R
pkg/R/phylo4.R
pkg/R/treewalk.R
pkg/inst/unitTests/runit.methods-phylo4.R
pkg/man/phylo4-accessors.Rd
Log:
new methods: nodeDepth, gives distance from node to root; isUltrametric, test whether a tree is ultrametric
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2011-02-09 20:20:01 UTC (rev 825)
+++ pkg/NAMESPACE 2011-02-10 23:00:55 UTC (rev 826)
@@ -33,8 +33,11 @@
#export(rootEdge) # no methods defined yet?
# node methods
-exportMethods(nodeId, nodeType)
+exportMethods(nodeId, nodeType, nodeDepth)
+# tree properties methods
+exportMethods(isUltrametric)
+
# tree data methods
exportMethods(tdata, "tdata<-", tipData, "tipData<-", nodeData,
"nodeData<-", hasTipData, hasNodeData, addData, nData)
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2011-02-09 20:20:01 UTC (rev 825)
+++ pkg/R/methods-phylo4.R 2011-02-10 23:00:55 UTC (rev 826)
@@ -9,6 +9,7 @@
### 2.1. nNodes()
### 2.2. nodeType()
### 2.3. nodeId()
+### 2.4. nodeDepth()
### 3. Edge accessors
### 3.1. nEdges()
@@ -50,6 +51,8 @@
### 7.1. orderIndex()
### 7.2. reorder()
+### 8. Tree properties
+### 8.1. isUltrametric()
#########################################################
### Tip accessors
@@ -76,13 +79,7 @@
})
setMethod("depthTips", signature(x="phylo4"), function(x) {
- if (!hasEdgeLength(x)) {
- return(NULL)
- }
- else {
- sapply(1:nTips(x), function(i)
- sumEdgeLength(x, ancestors(x, i, "ALL")))
- }
+ nodeDepth(x, 1:nTips(x))
})
#########################################################
@@ -148,8 +145,23 @@
})
+setMethod("nodeDepth", signature(x="phylo4"),
+ function(x, node) {
+ if (!hasEdgeLength(x))
+ return(NULL)
+ else {
+ node <- getNode(x, node, missing="warn")
+ node <- node[!is.na(node)]
+ res <- sapply(node, function(n)
+ sumEdgeLength(x, ancestors(x, n, "ALL")))
+ if (length(res) == 1) {
+ res <- res[[1]]
+ names(res) <- names(node)
+ }
+ res
+ }
+})
-
#########################################################
### Edge accessors
#########################################################
@@ -629,3 +641,17 @@
})
+#########################################################
+### Tree properties
+#########################################################
+
+setMethod("isUltrametric", signature(x="phylo4"),
+ function(x, tol=.Machine$double.eps^.5) {
+ if (!hasEdgeLength(x)) {
+ stop("The tree has no edge lengths.")
+ }
+ if (identical(all.equal.numeric(var(depthTips(x)), 0, tolerance=tol), TRUE)) {
+ TRUE
+ }
+ else FALSE
+ })
Modified: pkg/R/phylo4.R
===================================================================
--- pkg/R/phylo4.R 2011-02-09 20:20:01 UTC (rev 825)
+++ pkg/R/phylo4.R 2011-02-10 23:00:55 UTC (rev 826)
@@ -26,6 +26,11 @@
standardGeneric("nodeId")
})
+## nodeDepth
+setGeneric("nodeDepth", function(x, node) {
+ standardGeneric("nodeDepth")
+})
+
## nEdges
setGeneric("nEdges", function(x) {
standardGeneric("nEdges")
@@ -153,6 +158,12 @@
## summary
setGeneric("summary")
+## isUltrametric
+setGeneric("isUltrametric", function(x, tol=.Machine$double.eps^.5) {
+ standardGeneric("isUltrametric")
+})
+
+
### ----------- phylo4d methods -----------
## tdata
Modified: pkg/R/treewalk.R
===================================================================
--- pkg/R/treewalk.R 2011-02-09 20:20:01 UTC (rev 825)
+++ pkg/R/treewalk.R 2011-02-10 23:00:55 UTC (rev 826)
@@ -148,6 +148,10 @@
isValid <- !is.na(node)
node <- as.integer(node[isValid])
+ if (length(node) == 0) {
+ return(NA)
+ }
+
if (type == "parent") {
res <- lapply(node, function(x) ancestor(phy, x))
} else {
Modified: pkg/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4.R 2011-02-09 20:20:01 UTC (rev 825)
+++ pkg/inst/unitTests/runit.methods-phylo4.R 2011-02-10 23:00:55 UTC (rev 826)
@@ -47,6 +47,7 @@
test.depthTips.phylo4 <- function() {
edgeLengthVec <- c(1.2, 1.8, 1.8, 2.1, 2.3)
+ names(edgeLengthVec) <- tipLabels(phy.alt)
checkEquals(depthTips(phy.alt), edgeLengthVec)
tmpPhy <- phy.alt
edgeLength(tmpPhy) <- NA
@@ -79,6 +80,17 @@
checkIdentical(nEdges(phy.alt), nrow(edge))
}
+test.nodeDepth.phylo4 <- function() {
+ allDepths <- c(1.2, 1.8, 1.8, 2.1, 2.3, 0.9, 1.0, 1.2, 1.6)
+ names(allDepths) <- names(getNode(phy.alt))
+ checkIdentical(nodeDepth(phy.alt), allDepths)
+ checkIdentical(nodeDepth(phy.alt, 1), allDepths[1])
+ checkIdentical(nodeDepth(phy.alt, "t1"), allDepths[1])
+ tmpPhy <- phy.alt
+ edgeLength(tmpPhy) <- NA
+ checkTrue(is.null(nodeDepth(tmpPhy)))
+}
+
test.edges.phylo4 <- function() {
checkIdentical(edges(phy.alt), edge)
checkIdentical(edges(phy.alt, drop.root=TRUE), edge[edge[,1] != 0,])
@@ -455,4 +467,13 @@
#TODO
}
+test.isUltrametric <- function() {
+ checkTrue(!isUltrametric(phy.alt))
+ tmpPhy <- as(rcoal(10), "phylo4")
+ checkTrue(isUltrametric(tmpPhy))
+ tmpPhy <- phy.alt
+ edgeLength(tmpPhy) <- NA
+ checkException(isUltrametric(tmpPhy))
+}
+
phylobase.options(op)
Modified: pkg/man/phylo4-accessors.Rd
===================================================================
--- pkg/man/phylo4-accessors.Rd 2011-02-09 20:20:01 UTC (rev 825)
+++ pkg/man/phylo4-accessors.Rd 2011-02-10 23:00:55 UTC (rev 826)
@@ -17,6 +17,9 @@
\alias{nEdges}
\alias{nEdges-methods}
\alias{nEdges,phylo4-method}
+\alias{nodeDepth}
+\alias{nodeDepth-methods}
+\alias{nodeDepth,phylo4-method}
\alias{edgeOrder}
\alias{edgeOrder,phylo4-method}
\alias{hasEdgeLength}
@@ -41,6 +44,9 @@
\alias{rootNode,phylo4-method}
\alias{rootNode<-}
\alias{rootNode<-,phylo4-method}
+\alias{isUltrametric}
+\alias{isUltrametric-methods}
+\alias{isUltrametric,phylo4-method}
\title{Methods for S4 phylogeny classes}
\description{
Generic methods for phylogenetic trees represented as S4 classes
@@ -72,11 +78,17 @@
which has the type of node (internal, tip, root) for value, and the
node number for name}
+ \item{nodeDepth}{\code{signature(object = "phylo4")}: named vector
+ which gives the distance between nodes and the root}
+
\item{isRooted}{\code{signature(object = "phylo4")}: whether tree is
rooted (i.e. has explicit root edge defined \emph{or} root node has
<= 2 descendants)}
\item{rootEdge}{\code{signature(object = "phylo4")}: root edge}
+
+ \item{isUltrametric}{\code{signature(object = "phylo4")}: whether
+ the tree is ultrametric}
}
}
@@ -93,10 +105,12 @@
\S4method{edgeLength}{phylo4}(x, node)
\S4method{edgeLength}{phylo4}(x, use.names=TRUE) <- value
\S4method{nodeType}{phylo4}(x)
+\S4method{nodeDepth}{phylo4}(x, node)
\S4method{isRooted}{phylo4}(x)
\S4method{rootEdge}{phylo4}(x)
\S4method{rootNode}{phylo4}(x)
\S4method{rootNode}{phylo4}(x) <- value
+\S4method{isUltrametric}{phylo4}(x, tol=.Machine$double.eps^0.5)
}
\arguments{
@@ -107,6 +121,8 @@
\item{use.names}{Should the names of \code{value} be used to match
edge lengths provided? }
\item{drop.root}{logical: drop root row from edge matrix?}
+ \item{tol}{tolerance in rounding error to determine whether the tree
+ is ultrametric}
\item{\dots}{additional parameters passed (currently ignored)}
}
More information about the Phylobase-commits
mailing list