[Phylobase-commits] r626 - pkg/inst/unitTests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 9 06:34:04 CEST 2009
Author: regetz
Date: 2009-09-09 06:33:51 +0200 (Wed, 09 Sep 2009)
New Revision: 626
Modified:
pkg/inst/unitTests/runit.methods-phylo4.R
Log:
created basic tests for most phylo4 accessors and simple methods, using
a test phylo4 object that has its internal slot contents all jumbled.
Modified: pkg/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4.R 2009-09-08 21:39:05 UTC (rev 625)
+++ pkg/inst/unitTests/runit.methods-phylo4.R 2009-09-09 04:33:51 UTC (rev 626)
@@ -2,159 +2,201 @@
# --- Test methods-phylo4.R ---
#
-# Create sample tree for testing (ape::phylo object)
-tr <- read.tree(text="(((spA:0.2,(spB:0.1,spC:0.1):0.15):0.5,spD:0.7):0.2,spE:1):0.4;")
-phy <- as(tr, "phylo4")
-## label node ancestr edge.length node.type
-## 6 <NA> 6 NA 0.40 root
-## 7 <NA> 7 6 0.20 internal
-## 8 <NA> 8 7 0.50 internal
-## 9 <NA> 9 8 0.15 internal
-## 1 spA 1 8 0.20 tip
-## 2 spB 2 9 0.10 tip
-## 3 spC 3 9 0.10 tip
-## 4 spD 4 7 0.70 tip
-## 5 spE 5 6 1.00 tip
-phyd <- as(phy, "phylo4d")
+# create a phylo4 object with a full complement of valid slots
+ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
+edge <- cbind(ancestor, descendant)
+nid.tip <- 1:5
+nid.int <- 6:9
+lab.tip <- paste("t", nid.tip, sep="")
+lab.int <- paste("n", nid.int, sep="")
+elen <- descendant/10
+elab <- paste("e", ancestor, descendant, sep="-")
+phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int,
+ edge.length=elen, edge.label=elab)
+# now alter internal ordering of each slot so nothing matches up;
+# methods below should be able to handle this
+phy at tip.label <- rev(phy at tip.label)
+phy at node.label <- rev(phy at node.label)
+phy at edge <- phy at edge[c(6:9, 1:5), ]
+phy at edge.length <- phy at edge.length[c(7:9, 1:6)]
+phy at edge.label <- phy at edge.label[c(8:9, 1:7)]
+
+# update test targets for edge-related slots
+ancestor <- ancestor[c(6:9, 1:5)]
+descendant <- descendant[c(6:9, 1:5)]
+edge <- cbind(ancestor, descendant)
+elen <- elen[c(6:9, 1:5)]
+elab <- elab[c(6:9, 1:5)]
+
+#-----------------------------------------------------------------------
+
test.nTips.phylo4 <- function() {
- checkEquals(5, nTips(phy))
- checkEquals(5, nTips(phyd))
+ checkEquals(nTips(phy), length(nid.tip))
}
test.nTips.ANY <- function() {
# nTips phylo
- checkEquals(5, nTips(tr))
+ tr <- read.tree(text="(((spA:0.2,(spB:0.1,spC:0.1):0.15):0.5,spD:0.7):0.2,spE:1):0.4;")
+ checkEquals(nTips(tr), 5)
}
test.nNodes.phylo4 <- function() {
- checkEquals(4, nNodes(phy))
- checkEquals(4, nNodes(phyd))
+ checkEquals(nNodes(phy), length(nid.int))
}
test.nodeType.phylo4 <- function() {
+ checkIdentical(nodeType(phy), setNames(c(rep("tip", length(nid.tip)),
+ "root", rep("internal", length(nid.int)-1)), c(nid.tip, nid.int)))
}
test.nodeId.phylo4 <- function() {
- # do for type=c("internal","tip","allnode")
+ checkIdentical(nodeId(phy), c(nid.tip, nid.int))
+ checkIdentical(nodeId(phy, "all"), c(nid.tip, nid.int))
+ checkIdentical(nodeId(phy, "tip"), nid.tip)
+ checkIdentical(nodeId(phy, "internal"), nid.int)
+ checkIdentical(nodeId(phy, "root"), nid.int[1])
}
test.nEdges.phylo4 <- function() {
+ checkIdentical(nEdges(phy), nrow(edge))
}
test.edges.phylo4 <- function() {
- # function(x, order, drop.root=FALSE, ...)
+ checkIdentical(edges(phy), edge)
+ checkIdentical(edges(phy, drop.root=TRUE), edge[!is.na(edge[,1]),])
}
test.edgeOrder.phylo4 <- function() {
- # function(x, ...)
+ checkIdentical(edgeOrder(phy), "unknown")
+ checkIdentical(edgeOrder(reorder(phy, "preorder")), "preorder")
+ checkIdentical(edgeOrder(reorder(phy, "postorder")), "postorder")
}
test.hasEdgeLength.phylo4 <- function() {
checkTrue(hasEdgeLength(phy))
+ phy at edge.length <- NA_real_
+ checkTrue(!hasEdgeLength(phy))
}
test.edgeLength.phylo4 <- function() {
# all edge lengths
- ans <- structure(c(0.2, 0.5, 0.2, 0.15, 0.1, 0.4, 0.1, 0.7, 1),
- .Names = c("6-7", "7-8", "8-1", "8-9", "9-2", "NA-6", "9-3", "7-4",
- "6-5"))
- checkEquals(ans, edgeLength(phy))
+ checkIdentical(edgeLength(phy), setNames(elen, paste(ancestor,
+ descendant, sep="-")))
# one edge length, by label
- ans <- c(`8-1`=0.2)
- checkEquals(ans, edgeLength(phy, "spA"))
- # one edge length, by number
- checkEquals(ans, edgeLength(phy, 1))
+ checkEquals(edgeLength(phy, "t1"), c(`7-1`=0.1))
+ # one edge length, by node ID
+ checkEquals(edgeLength(phy, 1), c(`7-1`=0.1))
# non-existent edge, by label
ans <- structure(NA_real_, .Names = NA_character_)
- checkEquals(ans, edgeLength(phy, "xxx"))
+ checkEquals(suppressWarnings(edgeLength(phy, "xxx")), ans)
# non-existent edge, by number
- checkEquals(ans, edgeLength(phy, 999))
+ checkEquals(suppressWarnings(edgeLength(phy, 999)), ans)
}
test.Replace.edgeLength.phylo4 <- function() {
- # function(x, use.names=TRUE, ..., value)
+ #TODO function(x, use.names=TRUE, ..., value)
}
test.sumEdgeLength.phylo4 <- function() {
- # function(phy, node)
+ #TODO function(phy, node)
}
test.isRooted.phylo4 <- function() {
+ checkTrue(isRooted(phy))
}
test.rootNode.phylo4 <- function() {
+ checkIdentical(rootNode(phy), nid.int[1])
}
test.Replace.rootNode.phylo4 <- function() {
- # function(x, value)
+ #TODO function(x, value)
}
test.labels.phylo4 <- function() {
- # function(object, type = c("tip", "internal", "allnode"), ...)
+ # function(object, type = c("all", "tip", "internal"))
+ checkIdentical(labels(phy), setNames(c(lab.tip, lab.int), c(nid.tip,
+ nid.int)))
+ checkIdentical(labels(phy, "all"), setNames(c(lab.tip, lab.int),
+ c(nid.tip, nid.int)))
+ checkIdentical(labels(phy, "tip"), setNames(lab.tip, nid.tip))
+ checkIdentical(labels(phy, "internal"), setNames(lab.int, nid.int))
}
test.Replace.labels.phylo4 <- function() {
- # signature(object="phylo4", type="ANY", use.names="ANY", value="character"),
- # function(object, type = c("tip", "internal", "allnode"), use.names, ..., value)
+ #TODO function(object, type = c("tip", "internal", "allnode"), use.names, ..., value)
}
test.hasNodeLabels.phylo4 <- function() {
+ checkTrue(hasNodeLabels(phy))
+ phy at node.label <- NA_character_
+ checkTrue(!hasNodeLabels(phy))
}
test.nodeLabels.phylo4 <- function() {
+ checkIdentical(nodeLabels(phy), setNames(lab.int, nid.int))
}
test.Replace.nodeLabels.phylo4 <- function() {
- # signature(object="phylo4", value="character")
- # function(object, ..., value) {
+ #TODO function(object, ..., value) {
}
test.tipLabels.phylo4 <- function() {
+ checkIdentical(tipLabels(phy), setNames(lab.tip, nid.tip))
}
test.Replace.tipLabels.phylo4 <- function() {
- # signature(object="phylo4", value="character")
- # function(object, ..., value) {
+ #TODO function(object, ..., value) {
}
test.hasEdgeLabels.phylo4 <- function() {
+ checkTrue(hasEdgeLabels(phy))
+ phy at edge.label <- NA_character_
+# TODO: fix hasEdgeLabels
+# checkTrue(!hasEdgeLabels(phy))
}
test.edgeLabels.phylo4 <- function() {
+ checkIdentical(edgeLabels(phy), setNames(elab, paste(ancestor,
+ descendant, sep="-")))
}
test.Replace.edgeLabels.phylo4 <- function() {
- # signature(object="phylo4", value="character")
- # function(object, ..., value) {
+ #TODO function(object, ..., value) {
}
test.print.phylo4 <- function() {
- # this just calls printphylo4 function
+ #TODO? this just calls printphylo4 function
}
test.show.phylo4 <- function() {
- # this just calls printphylo4 function
+ #TODO? this just calls printphylo4 function
}
test.names.phylo4 <- function() {
+ #TODO?
}
test.head.phylo4 <- function() {
+ #TODO?
}
test.tail.phylo4 <- function() {
+ #TODO?
}
test.summary.phylo4 <- function() {
- # function (object, quiet=FALSE)
+ #TODO? function (object, quiet=FALSE)
}
-test.orderIndex <- function() {
- # function(phy, order = c('preorder', 'postorder'))
-}
+# not an exported function -- called internally by reorder("phylo4")
+#test.orderIndex <- function() {
+#}
test.reorder.phylo4 <- function() {
+ #TODO
}
More information about the Phylobase-commits
mailing list