[Phylobase-commits] r638 - in pkg: R inst/unitTests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 11 23:13:31 CEST 2009
Author: regetz
Date: 2009-09-11 23:13:31 +0200 (Fri, 11 Sep 2009)
New Revision: 638
Modified:
pkg/R/setAs-Methods.R
pkg/inst/unitTests/runit.methods-phylo4.R
pkg/inst/unitTests/runit.setAs-Methods.R
Log:
in phylo4->phylo: fixed to work with unordered tip labels, plus minor
streamlining; added unit test, and rejiggered some existing test targets
Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R 2009-09-11 17:41:10 UTC (rev 637)
+++ pkg/R/setAs-Methods.R 2009-09-11 21:13:31 UTC (rev 638)
@@ -88,15 +88,8 @@
phy <- list()
- ## Edge matrix
- if (isRooted(from)) {
- ## rootnode is only node with no ancestor
- rootpos <- which(is.na(from at edge[, 1]))
- edgemat <- unname(from at edge[-rootpos, ])
- }
- else {
- edgemat <- unname(from at edge)
- }
+ ## Edge matrix (dropping root edge if it exists)
+ edgemat <- unname(edges(from, drop.root=TRUE))
storage.mode(edgemat) <- "integer"
phy$edge <- edgemat
@@ -104,8 +97,7 @@
if(hasEdgeLength(from)) {
edge.length <- edgeLength(from)
if(isRooted(from)) {
- iRoot <- match(getEdge(from, rootNode(from), type="node",
- output="allEdge"), names(edge.length))
+ iRoot <- match(edgeId(from, "root"), names(edge.length))
phy$edge.length <- unname(edge.length[-iRoot])
}
else {
@@ -114,7 +106,7 @@
}
## Tip labels
- phy$tip.label <- unname(from at tip.label)
+ phy$tip.label <- unname(tipLabels(from))
## nNodes
phy$Nnode <- as.integer(nNodes(from))
Modified: pkg/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4.R 2009-09-11 17:41:10 UTC (rev 637)
+++ pkg/inst/unitTests/runit.methods-phylo4.R 2009-09-11 21:13:31 UTC (rev 638)
@@ -2,7 +2,11 @@
# --- Test methods-phylo4.R ---
#
-# create a phylo4 object with a full complement of valid slots
+# create ape::phylo version of a simple tree for testing
+nwk <- "((t1:0.1,t2:0.2)n7:0.7,(t3:0.3,(t4:0.4,t5:0.5)n9:0.9)n8:0.8)n6:0.6;"
+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))
descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
edge <- cbind(ancestor, descendant)
@@ -15,13 +19,14 @@
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)]
+# create altered version such that each slot is out of order with
+# respect to all others; methods should be able to handle this
+phy.alt <- phy
+phy.alt at tip.label <- rev(phy at tip.label)
+phy.alt at node.label <- rev(phy at node.label)
+phy.alt at edge <- phy at edge[c(6:9, 1:5), ]
+phy.alt at edge.length <- phy at edge.length[c(7:9, 1:6)]
+phy.alt 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)]
@@ -33,75 +38,74 @@
#-----------------------------------------------------------------------
test.nTips.phylo4 <- function() {
- checkEquals(nTips(phy), length(nid.tip))
+ checkEquals(nTips(phy.alt), length(nid.tip))
}
test.nTips.ANY <- function() {
# nTips phylo
- 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(nNodes(phy), length(nid.int))
+ checkEquals(nNodes(phy.alt), length(nid.int))
}
test.nodeType.phylo4 <- function() {
- checkIdentical(nodeType(phy), setNames(c(rep("tip", length(nid.tip)),
+ checkIdentical(nodeType(phy.alt), setNames(c(rep("tip", length(nid.tip)),
"root", rep("internal", length(nid.int)-1)), c(nid.tip, nid.int)))
}
test.nodeId.phylo4 <- function() {
- 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])
+ checkIdentical(nodeId(phy.alt), c(nid.tip, nid.int))
+ checkIdentical(nodeId(phy.alt, "all"), c(nid.tip, nid.int))
+ checkIdentical(nodeId(phy.alt, "tip"), nid.tip)
+ checkIdentical(nodeId(phy.alt, "internal"), nid.int)
+ checkIdentical(nodeId(phy.alt, "root"), nid.int[1])
}
test.nEdges.phylo4 <- function() {
- checkIdentical(nEdges(phy), nrow(edge))
+ checkIdentical(nEdges(phy.alt), nrow(edge))
}
test.edges.phylo4 <- function() {
- checkIdentical(edges(phy), edge)
- checkIdentical(edges(phy, drop.root=TRUE), edge[!is.na(edge[,1]),])
+ checkIdentical(edges(phy.alt), edge)
+ checkIdentical(edges(phy.alt, drop.root=TRUE), edge[!is.na(edge[,1]),])
}
test.edgeOrder.phylo4 <- function() {
- checkIdentical(edgeOrder(phy), "unknown")
- checkIdentical(edgeOrder(reorder(phy, "preorder")), "preorder")
- checkIdentical(edgeOrder(reorder(phy, "postorder")), "postorder")
+ checkIdentical(edgeOrder(phy.alt), "unknown")
+ checkIdentical(edgeOrder(reorder(phy.alt, "preorder")), "preorder")
+ checkIdentical(edgeOrder(reorder(phy.alt, "postorder")), "postorder")
}
test.edgeId.phylo4 <- function() {
eid <- paste(ancestor, descendant, sep="-")
- checkIdentical(edgeId(phy), eid)
- checkIdentical(edgeId(phy, "all"), eid)
- checkIdentical(edgeId(phy, "tip"), eid[descendant %in% nid.tip])
- checkIdentical(edgeId(phy, "internal"), eid[!descendant %in% nid.tip])
- checkIdentical(edgeId(phy, "root"), eid[is.na(ancestor)])
+ checkIdentical(edgeId(phy.alt), eid)
+ 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)])
}
test.hasEdgeLength.phylo4 <- function() {
- checkTrue(hasEdgeLength(phy))
- phy at edge.length <- NA_real_
- checkTrue(!hasEdgeLength(phy))
+ checkTrue(hasEdgeLength(phy.alt))
+ phy.alt at edge.length <- NA_real_
+ checkTrue(!hasEdgeLength(phy.alt))
}
test.edgeLength.phylo4 <- function() {
# all edge lengths
- checkIdentical(edgeLength(phy), setNames(elen, paste(ancestor,
+ checkIdentical(edgeLength(phy.alt), setNames(elen, paste(ancestor,
descendant, sep="-")))
# one edge length, by label
- checkEquals(edgeLength(phy, "t1"), c(`7-1`=0.1))
+ checkEquals(edgeLength(phy.alt, "t1"), c(`7-1`=0.1))
# one edge length, by node ID
- checkEquals(edgeLength(phy, 1), c(`7-1`=0.1))
+ checkEquals(edgeLength(phy.alt, 1), c(`7-1`=0.1))
# non-existent edge, by label
ans <- structure(NA_real_, .Names = NA_character_)
- checkEquals(suppressWarnings(edgeLength(phy, "xxx")), ans)
+ checkEquals(suppressWarnings(edgeLength(phy.alt, "xxx")), ans)
# non-existent edge, by number
- checkEquals(suppressWarnings(edgeLength(phy, 999)), ans)
+ checkEquals(suppressWarnings(edgeLength(phy.alt, 999)), ans)
}
test.Replace.edgeLength.phylo4 <- function() {
@@ -113,11 +117,11 @@
}
test.isRooted.phylo4 <- function() {
- checkTrue(isRooted(phy))
+ checkTrue(isRooted(phy.alt))
}
test.rootNode.phylo4 <- function() {
- checkIdentical(rootNode(phy), nid.int[1])
+ checkIdentical(rootNode(phy.alt), nid.int[1])
}
test.Replace.rootNode.phylo4 <- function() {
@@ -126,12 +130,12 @@
test.labels.phylo4 <- function() {
# function(object, type = c("all", "tip", "internal"))
- checkIdentical(labels(phy), setNames(c(lab.tip, lab.int), c(nid.tip,
+ checkIdentical(labels(phy.alt), setNames(c(lab.tip, lab.int), c(nid.tip,
nid.int)))
- checkIdentical(labels(phy, "all"), setNames(c(lab.tip, lab.int),
+ checkIdentical(labels(phy.alt, "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))
+ checkIdentical(labels(phy.alt, "tip"), setNames(lab.tip, nid.tip))
+ checkIdentical(labels(phy.alt, "internal"), setNames(lab.int, nid.int))
}
test.Replace.labels.phylo4 <- function() {
@@ -139,13 +143,13 @@
}
test.hasNodeLabels.phylo4 <- function() {
- checkTrue(hasNodeLabels(phy))
- phy at node.label <- NA_character_
- checkTrue(!hasNodeLabels(phy))
+ checkTrue(hasNodeLabels(phy.alt))
+ phy.alt at node.label <- NA_character_
+ checkTrue(!hasNodeLabels(phy.alt))
}
test.nodeLabels.phylo4 <- function() {
- checkIdentical(nodeLabels(phy), setNames(lab.int, nid.int))
+ checkIdentical(nodeLabels(phy.alt), setNames(lab.int, nid.int))
}
test.Replace.nodeLabels.phylo4 <- function() {
@@ -153,7 +157,7 @@
}
test.tipLabels.phylo4 <- function() {
- checkIdentical(tipLabels(phy), setNames(lab.tip, nid.tip))
+ checkIdentical(tipLabels(phy.alt), setNames(lab.tip, nid.tip))
}
test.Replace.tipLabels.phylo4 <- function() {
@@ -161,13 +165,13 @@
}
test.hasEdgeLabels.phylo4 <- function() {
- checkTrue(hasEdgeLabels(phy))
- phy at edge.label <- NA_character_
- checkTrue(!hasEdgeLabels(phy))
+ checkTrue(hasEdgeLabels(phy.alt))
+ phy.alt at edge.label <- NA_character_
+ checkTrue(!hasEdgeLabels(phy.alt))
}
test.edgeLabels.phylo4 <- function() {
- checkIdentical(edgeLabels(phy), setNames(elab, paste(ancestor,
+ checkIdentical(edgeLabels(phy.alt), setNames(elab, paste(ancestor,
descendant, sep="-")))
}
@@ -176,16 +180,9 @@
}
## this is also the print method
-test.show.phylo4 <- function() {
- # the real work here is done in .phylo4ToDataFrame
- phy.show <- phylobase:::.phylo4ToDataFrame(phy, "pretty")
- checkIdentical(phy.show$label, c(lab.tip, lab.int))
- checkIdentical(phy.show$node, c(nid.tip, nid.int))
- checkIdentical(phy.show$ancestor, ancestor[match(c(nid.tip, nid.int),
- descendant)])
- checkIdentical(phy.show$edge.length, sort(elen))
- checkIdentical(phy.show$node.typ, factor(unname(nodeType(phy))))
-}
+## this mostly just wraps .phylo4ToDataFrame, which is tested elsewhere
+##test.show.phylo4 <- function() {
+##}
test.names.phylo4 <- function() {
#TODO?
@@ -200,22 +197,22 @@
}
test.summary.phylo4 <- function() {
- phy.sum <- summary(phy, quiet=TRUE)
- checkIdentical(phy.sum$name, "phy")
+ phy.sum <- summary(phy.alt, quiet=TRUE)
+ checkIdentical(phy.sum$name, "phy.alt")
checkIdentical(phy.sum$nb.tips, length(nid.tip))
checkIdentical(phy.sum$nb.nodes, length(nid.int))
checkIdentical(phy.sum$mean.el, mean(elen))
checkIdentical(phy.sum$var.el, var(elen))
checkIdentical(phy.sum$sumry.el, summary(elen))
# now make root edge length NA
- edgeLength(phy)[edgeId(phy, "root")] <- NA
- phy.sum2 <- summary(phy, quiet=TRUE)
- checkIdentical(phy.sum2$mean.el, mean(edgeLength(phy), na.rm=TRUE))
- checkIdentical(phy.sum2$var.el, var(edgeLength(phy), na.rm=TRUE))
- checkIdentical(phy.sum2$sumry.el, summary(na.omit(edgeLength(phy))))
+ edgeLength(phy.alt)[edgeId(phy.alt, "root")] <- NA
+ phy.sum2 <- summary(phy.alt, quiet=TRUE)
+ checkIdentical(phy.sum2$mean.el, mean(edgeLength(phy.alt), na.rm=TRUE))
+ checkIdentical(phy.sum2$var.el, var(edgeLength(phy.alt), na.rm=TRUE))
+ checkIdentical(phy.sum2$sumry.el, summary(na.omit(edgeLength(phy.alt))))
# now remove edge lengths altogether
- phy at edge.length[] <- NA
- phy.sum3 <- summary(phy, quiet=TRUE)
+ phy.alt at edge.length[] <- NA
+ phy.sum3 <- summary(phy.alt, quiet=TRUE)
checkTrue(is.null(phy.sum3$mean.el))
checkTrue(is.null(phy.sum3$var.el))
checkTrue(is.null(phy.sum3$sumry.el))
Modified: pkg/inst/unitTests/runit.setAs-Methods.R
===================================================================
--- pkg/inst/unitTests/runit.setAs-Methods.R 2009-09-11 17:41:10 UTC (rev 637)
+++ pkg/inst/unitTests/runit.setAs-Methods.R 2009-09-11 21:13:31 UTC (rev 638)
@@ -1,11 +1,35 @@
#
# --- Test setAs-Methods.R ---
#
+
+# create ape::phylo version of a simple tree for testing
+nwk <- "((t1:0.1,t2:0.2)n7:0.7,(t3:0.3,(t4:0.4,t5:0.5)n9:0.9)n8:0.8)n6:0.6;"
+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))
+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)
+
+# create altered version such that each slot is out of order with
+# respect to all others; methods should be able to handle this
+phy.alt <- phy
+phy.alt at tip.label <- rev(phy at tip.label)
+phy.alt at node.label <- rev(phy at node.label)
+phy.alt at edge <- phy at edge[c(6:9, 1:5), ]
+phy.alt at edge.length <- phy at edge.length[c(7:9, 1:6)]
+phy.alt at edge.label <- phy at edge.label[c(8:9, 1:7)]
+
+#-----------------------------------------------------------------------
-# 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")
-
test.phylo.As.phylo4 <- function() {
checkIdentical(as(tr, "phylo4"), phylo4(tr))
}
@@ -24,8 +48,7 @@
# note: checkEquals("phylo") uses all.equal.phylo()
# phylo tree in unknown order
- phy <- as(tr, "phylo4")
- checkEquals(as(phy, "phylo"), tr)
+ checkEquals(suppressWarnings(as(phy, "phylo")), tr)
# ...now check for warning for unknown order
opt <- options(warn=3)
checkException(as(phy, "phylo"))
@@ -33,13 +56,23 @@
# phylo tree in cladewise order
tr.cladewise <- reorder(tr, "cladewise")
- phy <- as(tr.cladewise, "phylo4")
- checkEquals(as(phy, "phylo"), tr.cladewise)
+ phy.c <- as(tr.cladewise, "phylo4")
+ checkEquals(as(phy.c, "phylo"), tr.cladewise)
# phylo tree in pruningwise order
tr.pruningwise <- reorder(tr, "pruningwise")
- phy <- as(tr.pruningwise, "phylo4")
- checkEquals(as(phy, "phylo"), tr.pruningwise)
+ phy.p <- as(tr.pruningwise, "phylo4")
+ checkEquals(as(phy.p, "phylo"), tr.pruningwise)
+
+ # after transforming the jumbled tree to phylo and back, edge matrix
+ # and edge slots should still be in the original order, but node slots
+ # should be back in nodeId order
+ phy.r <- reorder(phy.alt)
+ phy.roundtrip.r <- reorder(phylo4(as(phy.alt, "phylo")))
+ checkIdentical(edges(phy.roundtrip.r), edges(phy.r))
+ checkIdentical(edgeLength(phy.roundtrip.r), edgeLength(phy.r))
+ checkIdentical(labels(phy.roundtrip.r), labels(phy.r))
+
}
# this coerce method is defined implicitly
@@ -75,19 +108,20 @@
test.phylo4.As.phylog <- 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))
+ checkIdentical(phy.show$ancestor, ancestor[match(c(nid.tip, nid.int),
+ descendant)])
+ checkIdentical(phy.show$edge.length, sort(elen))
+ checkIdentical(phy.show$node.typ, factor(unname(nodeType(phy))))
+}
+
+## core functionality is already tested in test..phylo4ToDataFrame()
test.phylo4.As.data.frame <- function() {
-
# rooted tree
checkTrue(is.data.frame(as(phy, "data.frame")))
- phy.df <- structure(list(label = c("spA", "spB", "spC", "spD",
- "spE", NA, NA, NA, NA), node = 1:9, ancestor = c(8L, 9L, 9L, 7L,
- 6L, NA, 6L, 7L, 8L), edge.length = c(0.2, 0.1, 0.1, 0.7, 1, 0.4,
- 0.2, 0.5, 0.15), node.type = structure(c(3L, 3L, 3L, 3L, 3L, 2L,
- 1L, 1L, 1L), .Label = c("internal", "root", "tip"), class =
- "factor")), .Names = c("label", "node", "ancestor",
- "edge.length", "node.type"), row.names = c(NA, 9L), class =
- "data.frame")
- checkEquals(as(phy, "data.frame"), phy.df)
# unrooted tree
tru <- unroot(tr)
@@ -95,5 +129,4 @@
# should probably check that this coercion results in something
# *correct*, not just that it produces a data.frame
checkTrue(is.data.frame(as(phyu, "data.frame")))
-
}
More information about the Phylobase-commits
mailing list