[Phylobase-commits] r858 - in pkg: . inst/unitTests tests tests/testthat
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Mar 10 05:10:30 CET 2014
Author: francois
Date: 2014-03-10 05:10:29 +0100 (Mon, 10 Mar 2014)
New Revision: 858
Added:
pkg/tests/test-all.R
pkg/tests/testthat/
pkg/tests/testthat/test.badnex.R
pkg/tests/testthat/test.methods-phylo4.R
pkg/tests/testthat/test.treewalk.R
Removed:
pkg/inst/unitTests/runit.badnex.R
pkg/inst/unitTests/runit.methods-phylo4d.R
pkg/inst/unitTests/runit.treewalk.R
Modified:
pkg/DESCRIPTION
Log:
starting to switch unit tests to testthat.
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2014-03-09 23:31:00 UTC (rev 857)
+++ pkg/DESCRIPTION 2014-03-10 04:10:29 UTC (rev 858)
@@ -1,13 +1,14 @@
Package: phylobase
Type: Package
Title: Base package for phylogenetic structures and comparative data
-Version: 0.6.6
-Date: 2014-02-11
+Version: 0.6.7
+Date: 2014-03-10
Depends:
methods,
grid,
ape(>= 2.1),
- Rcpp (>= 0.11.0)
+ Rcpp (>= 0.11.0),
+ testthat (>= 0.8.1)
Imports: ade4
LinkingTo: Rcpp
Suggests:
Deleted: pkg/inst/unitTests/runit.badnex.R
===================================================================
--- pkg/inst/unitTests/runit.badnex.R 2014-03-09 23:31:00 UTC (rev 857)
+++ pkg/inst/unitTests/runit.badnex.R 2014-03-10 04:10:29 UTC (rev 858)
@@ -1,16 +0,0 @@
-#
-# --- Test badnex.R ---
-#
-
-if (Sys.getenv("RCMDCHECK") == FALSE) {
- pth <- file.path(getwd(), "..", "inst", "nexusfiles")
-} else {
- pth <- system.file(package="phylobase", "nexusfiles")
-}
-
-badFile <- file.path(pth, "badnex.nex")
-
-test.checkTree <- function() {
- checkException(readNexus(file=badFile))
-}
-
Deleted: pkg/inst/unitTests/runit.methods-phylo4d.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4d.R 2014-03-09 23:31:00 UTC (rev 857)
+++ pkg/inst/unitTests/runit.methods-phylo4d.R 2014-03-10 04:10:29 UTC (rev 858)
@@ -1,188 +0,0 @@
-#
-# --- Test methods-phylo4d.R ---
-#
-
-# create phylo4 object with a full complement of valid slots
-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
-nid.int <- 6:9
-nid.all <- c(nid.tip, nid.int)
-lab.tip <- paste("t", nid.tip, sep="")
-lab.int <- paste("n", nid.int, sep="")
-lab.all <- c(lab.tip, lab.int)
-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 create phylo4d by adding data (with node IDs as row.names)
-allDt <- data.frame(a=letters[nid.all], b=10*nid.all)
-tipDt <- data.frame(c=letters[nid.tip], d=10*nid.tip)
-nodDt <- data.frame(c=letters[nid.int], e=10*nid.int)
-row.names(allDt) <- nid.all
-row.names(tipDt) <- nid.tip
-row.names(nodDt) <- nid.int
-phyd <- phylo4d(phy, tip.data=tipDt, node.data=nodDt, all.data=allDt,
- match.data=TRUE, merge.data=TRUE)
-
-# create altered version such that each slot is out of order with
-# respect to all others; methods should be able to handle this
-phyd.alt <- phyd
-phyd.alt at label <- rev(phyd at label)
-phyd.alt at edge <- phyd at edge[c(6:9, 1:5), ]
-phyd.alt at edge.length <- phyd at edge.length[c(7:9, 1:6)]
-phyd.alt at edge.label <- phyd at edge.label[c(8:9, 1:7)]
-nid.tip.r <- c(2,5,4,3,1)
-nid.int.r <- c(8,7,9,6)
-nid.all.r <- c(nid.tip.r, nid.int.r)
-phyd.alt at data <- phyd at data[rank(nid.all.r), ]
-
-# for comparisons, manually create expected "all" trait data.frame
-m1 <- merge(allDt, rbind(tipDt["c"], nodDt["c"]), by=0, all=TRUE)
-m2 <- merge(tipDt["d"], nodDt["e"], by=0, all=TRUE)
-eAllDt <- merge(m1, m2, by="Row.names", all=TRUE)[-1]
-row.names(eAllDt) <- lab.all
-
-# for comparisons, manually create expected "tip" trait data.frame
-m1 <- merge(allDt, rbind(tipDt["c"], nodDt["c"]), by=0, all=TRUE)
-m2 <- merge(tipDt["d"], nodDt["e"], by=0, all=TRUE)
-eTipDt <- merge(m1, m2, by="Row.names", all=TRUE)[nid.tip, -1]
-row.names(eTipDt) <- lab.tip
-
-# manually create expected tip trait data.frame
-m1 <- merge(allDt, rbind(tipDt["c"], nodDt["c"]), by=0, all=TRUE)
-m2 <- merge(tipDt["d"], nodDt["e"], by=0, all=TRUE)
-eNodDt <- merge(m1, m2, by="Row.names", all=TRUE)[nid.int, -1]
-row.names(eNodDt) <- lab.int
-
-#-----------------------------------------------------------------------
-
-test.tdata.phylo4d <- function() {
- # function(x, type=c("tip", "internal", "allnode"),
- # label.type=c("row.names","column"), empty.columns=TRUE, ...)
-
- # check basic tdata usage
- checkIdentical(tdata(phyd.alt, type="tip"), eTipDt)
- checkIdentical(tdata(phyd.alt, type="internal"), eNodDt)
- checkIdentical(tdata(phyd.alt, type="all"), eAllDt)
-
- # label.type="row.names"
- tmpDt <- data.frame(eAllDt[nid.tip, -5, ], row.names=lab.tip)
- checkIdentical(tdata(phyd.alt, type="tip", label.type="row.names",
- empty.columns=FALSE), data.frame(tmpDt[nid.tip,], row.names=lab.tip))
- # label.type="column"
- tmpDt <- data.frame(label=lab.tip, eAllDt[nid.tip, -5, ],
- row.names=as.character(nid.tip))
- checkIdentical(tdata(phyd.alt, type="tip", label.type="column",
- empty.columns=FALSE), tmpDt)
-
- # keep empty.columns
- checkIdentical(tdata(phyd.alt, type="tip", empty.columns=TRUE),
- eAllDt[nid.tip,])
-
- #
- # misc tests
- #
-
- # check with other tree orderings
- phyd.pre <- reorder(phyd.alt, "preorder")
- checkIdentical(tdata(phyd.pre, "all", empty.columns=FALSE), eAllDt)
- phyd.post <- reorder(phyd.alt, "postorder")
- checkIdentical(tdata(phyd.post, "all", empty.columns=FALSE), eAllDt)
-
-}
-
-## currently just basic tests of tdata replacement; using out-of-order
-## data, but only with default args (e.g. row.name-nodeID matching)
-## ... formatData unit tests should be sufficient for the rest
-test.Replace.tdata.phylo4d <- function() {
-
- ## replace data, labels are row names
- tdata(phyd.alt, "all") <- allDt[rank(nid.all.r), , drop=FALSE]
- checkIdentical(tdata(phyd.alt, type="all"), data.frame(allDt,
- row.names=lab.all))
-
- ## replace data with empty data frame
- tdata(phyd.alt) <- data.frame()
- checkIdentical(tdata(phyd.alt), data.frame(row.names=lab.all))
-
- ## same as first test, but leaving out default 'all' type
- tdata(phyd.alt) <- allDt[rank(nid.all.r), , drop=FALSE]
- checkIdentical(tdata(phyd.alt), data.frame(allDt,
- row.names=lab.all))
-
-}
-
-test.tipData.phylo4d <- function() {
- # label.type="row.names"
- checkIdentical(tipData(phyd.alt, label.type="row.names",
- empty.columns=FALSE), eTipDt[-5])
- # label.type="column"
- tmpDt <- data.frame(label=lab.tip, eTipDt[-5],
- row.names=as.character(nid.tip))
- checkIdentical(tipData(phyd.alt, label.type="column",
- empty.columns=FALSE), tmpDt)
-
- # keep empty.columns
- checkIdentical(tipData(phyd.alt), eTipDt)
-}
-
-test.Replace.tipData.phylo4d <- function() {
- ## replace data with tip data only, clearing all data
- tipData(phyd.alt, clear.all=TRUE) <- tipDt[rank(nid.tip.r), ,
- drop=FALSE]
- checkIdentical(tipData(phyd.alt), data.frame(tipDt,
- row.names=lab.tip))
-}
-
-test.nodeData.phylo4d <- function() {
-
- # label.type="row.names"
- checkIdentical(nodeData(phyd.alt, label.type="row.names",
- empty.columns=FALSE), eNodDt[-4])
-
- # label.type="column"
- tmpDt <- data.frame(label=lab.int, eNodDt[-4],
- row.names=as.character(nid.int))
- checkIdentical(nodeData(phyd.alt, label.type="column",
- empty.columns=FALSE), tmpDt)
-
- # keep empty.columns
- checkIdentical(nodeData(phyd.alt), eNodDt)
-}
-
-test.Replace.nodeData.phylo4d <- function() {
- ## replace data with internal data only, clearing all data
- nodeData(phyd.alt, clear.all=TRUE) <- nodDt[rank(nid.int.r), ,
- drop=FALSE]
- checkIdentical(nodeData(phyd.alt), data.frame(nodDt,
- row.names=lab.int))
-}
-
-
-test.nData <- function() {
- checkIdentical(nData(phyd.alt), ncol(eAllDt))
-}
-
-test.addData.phylo4d <- function() {
- # function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
- # pos=c("after", "before"), merge.data=TRUE, match.data=TRUE, ...)
-}
-
-test.addData.phylo4 <- function() {
- # function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
- # pos=c("after", "before"), merge.data=TRUE, match.data=TRUE, ...)
-}
-
-test.summary.phylo4d <- function() {
-}
-
-test.hasNodeData.phylo4d <- function() {
-}
-
-test.na.omit.phylo4d <- function() {
- # function(object, ...)
-}
-
Deleted: pkg/inst/unitTests/runit.treewalk.R
===================================================================
--- pkg/inst/unitTests/runit.treewalk.R 2014-03-09 23:31:00 UTC (rev 857)
+++ pkg/inst/unitTests/runit.treewalk.R 2014-03-10 04:10:29 UTC (rev 858)
@@ -1,237 +0,0 @@
-#
-# --- Test treewalk.R ---
-#
-
-# Create sample phylo4 tree for testing
-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;")
-phytr <- as(tr, "phylo4")
-
-# create phylo4 object with a full complement of valid slots
-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
-nid.int <- 6:9
-nid.all <- c(nid.tip, nid.int)
-lab.tip <- paste("t", nid.tip, sep="")
-lab.int <- paste("n", nid.int, sep="")
-lab.all <- c(lab.tip, lab.int)
-eid <- paste(ancestor, descendant, sep="-")
-elen <- descendant/10
-elab <- paste("e", eid, 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 label <- rev(phy at 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)]
-descendant <- descendant[c(6:9, 1:5)]
-edge <- cbind(ancestor, descendant)
-eid <- eid[c(6:9, 1:5)]
-elen <- elen[c(6:9, 1:5)]
-elab <- elab[c(6:9, 1:5)]
-
-#-----------------------------------------------------------------------
-
-test.getNode <- function() {
-# Note: we're not explicitly testing missing="warn" condition below;
-# however, if "OK" and "fail" both work as expected, then so must "warn"
- # node only has valid characters
- checkEquals(getNode(phytr, "spA"), c(spA=1))
- checkEquals(getNode(phytr, c("spA", "spC")), c(spA=1, spC=3))
-
- # node only has valid integers
- ans <- 4
- names(ans) <- "spD"
- checkEquals(getNode(phytr, 4), ans)
- ans <- c(4,6)
- names(ans) <- c("spD", NA)
- checkEquals(getNode(phytr, c(4,6)), ans)
-
- # node includes only missing characters (names), but missing=OK
- ans <- rep(NA_integer_, 2) # return values should be NA
- names(ans) <- rep(NA, 2) # return values should have NA names
- checkEquals(getNode(phytr, c("xxx", "yyy"), missing="OK"), ans)
- # now missing = "fail"
- checkException(getNode(phytr, c("xxx", "yyy"), missing="fail"))
-
- # node includes only missing numbers (IDs), but missing=OK
- ans <- rep(NA_integer_, 3) # return values should be NA
- names(ans) <- rep(NA, 3) # return values should have NA names
- checkEquals(getNode(phytr, c(-9, 0, 50), missing="OK"), ans)
- # now missing = "fail"
- checkException(getNode(phytr, c(-9, 0, 50), missing="fail"), ans)
-
- # node includes NAs, but missing = "OK"
- checkTrue(is.na(getNode(phytr, NA_integer_, missing="OK")))
- checkTrue(is.na(getNode(phytr, NA_character_, missing="OK")))
-
- # node includes mixture of valid values and NAs
- ans <- c(2, NA)
- names(ans) <- c("spB", NA)
- checkEquals(getNode(phytr, c("spB", NA), missing="OK"), ans)
- checkEquals(getNode(phytr, c(2, NA), missing="OK"), ans)
-
- # node is neither integer-like nor character
- checkException(getNode(phytr, 1.5))
-
- # check that tip labeled as "0" works
- phyTmp <- phytr
- tipLabels(phyTmp)[1] <- "0"
- ans <- 1
- names(ans) <- "0"
- checkEquals(getNode(phyTmp, "0"), ans)
-}
-
-test.ancestor <- function() {
- # function(phy,node)
-}
-
-test.children <- function() {
- # function(phy,node)
-}
-
-test.descendants <- function() {
- # function (phy, node, type=c("tips","children","all"))
- phytr <- phylo4(read.tree(text="((t3,t4),(t1,(t2,t5)));"))
-
- # node = tip
- checkIdentical(descendants(phytr, 5),
- setNames(5L, "t5"))
- checkIdentical(descendants(phytr, 5, "tips"),
- setNames(5L, "t5"))
- checkIdentical(descendants(phytr, 5, "children"),
- setNames(integer(0), character(0)))
- checkIdentical(descendants(phytr, 5, "all"),
- setNames(5L, "t5"))
-
- # node = internal
- checkIdentical(descendants(phytr, 8),
- setNames(c(3L, 4L, 5L), c("t1", "t2", "t5")))
- checkIdentical(descendants(phytr, 8, "tips"),
- setNames(c(3L, 4L, 5L), c("t1", "t2", "t5")))
- checkIdentical(descendants(phytr, 8, "children"),
- setNames(c(3L, 9L), c("t1", NA)))
- checkIdentical(descendants(phytr, 8, "all"),
- setNames(c(3L, 9L, 4L, 5L), c("t1", NA, "t2", "t5")))
-}
-
-test.siblings <- function() {
- # function(phy, node, include.self=FALSE)
-}
-
-test.ancestors <- function() {
- # function (phy, node, type=c("all","parent","ALL"))
-}
-
-test.MRCA <- function() {
- # function(phy, ...)
-}
-
-test.shortestPath <- function() {
- # function(phy, node1, node2)
-}
-
-test.getEdge <- function() {
- # function(phy, node, type=c("descendant", "ancestor"),
- # missing=c("warn", "OK", "fail"))
-
- #
- # nodes as descendants
- #
-
- # node only has valid descendants, as characters
- checkIdentical(getEdge(phy.alt, "t1"), setNames("7-1", 1))
- checkIdentical(getEdge(phy.alt, c("t1", "t3")), setNames(c("7-1",
- "8-3"), c(1,3)))
-
- # node only has valid descendants, as integers
- checkIdentical(getEdge(phy.alt, 1), setNames("7-1", 1))
- checkIdentical(getEdge(phy.alt, c(1,3)), setNames(c("7-1",
- "8-3"), c(1,3)))
-
- # node includes only missing characters (labels), but missing=OK
- checkIdentical(getEdge(phy.alt, c("x", "y", "z"), missing="OK"),
- setNames(rep(NA, 3), rep(NA, 3)))
- # now missing = "fail"
- checkException(getEdge(phy.alt, c("x", "y", "z"), missing="fail"))
-
- # node includes only missing numbers (IDs), but missing=OK
- checkIdentical(getEdge(phy.alt, c(-9, 0, 50), missing="OK"),
- setNames(rep(NA, 3), rep(NA, 3)))
- # now missing = "fail"
- checkException(getEdge(phy, c(-9, 0, 50), missing="fail"))
-
- # node includes NAs, but missing = "OK"
- checkTrue(is.na(getEdge(phy, NA_integer_, missing="OK")))
- checkTrue(is.na(getEdge(phy, NA_character_, missing="OK")))
-
- # node includes mixture of valid values and NAs
- checkIdentical(getEdge(phy, c("t3", NA), missing="OK"),
- setNames(c("8-3", NA), c(3, NA)))
- checkIdentical(getEdge(phy, c(3, NA), missing="OK"),
- setNames(c("8-3", NA), c(3, NA)))
-
- # node is neither integer-like nor character
- checkException(getEdge(phy, 1.5))
-
- #
- # nodes as ancestors
- #
-
- # node only has valid ancestors, as characters
- checkIdentical(getEdge(phy.alt, "n6", type="ancestor"),
- setNames(c("6-7", "6-8"), c(6, 6)))
- checkIdentical(getEdge(phy.alt, c("n6", "n8"), type="ancestor"),
- setNames(c("6-7", "6-8", "8-9", "8-3"), c(6, 6, 8, 8)))
-
- # node only has valid ancestors, as integers
- checkIdentical(getEdge(phy.alt, 6, type="ancestor"),
- setNames(c("6-7", "6-8"), c(6, 6)))
- checkIdentical(getEdge(phy.alt, c(6, 8), type="ancestor"),
- setNames(c("6-7", "6-8", "8-9", "8-3"), c(6, 6, 8, 8)))
-
- # node includes only missing characters (labels), but missing=OK
- checkIdentical(getEdge(phy.alt, c("x", "y", "z"), type="ancestor",
- missing="OK"), setNames(rep(NA, 3), rep(NA, 3)))
- # node includes only tips (labels), but missing=OK
- checkIdentical(getEdge(phy.alt, c("t1", "t3"), type="ancestor",
- missing="OK"), setNames(rep(NA, 2), c(1, 3)))
- # now missing = "fail"
- checkException(getEdge(phy.alt, c("x", "y", "z"), missing="fail"))
- checkException(getEdge(phy.alt, c("t1", "t3"), type="ancestor",
- missing="fail"))
-
- # node includes only missing numbers (IDs), but missing=OK
- checkIdentical(getEdge(phy.alt, c(-9, 0, 50), type="ancestor",
- missing="OK"), setNames(rep(NA, 3), rep(NA, 3)))
- # node includes only tips (labels), but missing=OK
- checkIdentical(getEdge(phy.alt, c(1, 3), type="ancestor",
- missing="OK"), setNames(rep(NA, 2), c(1, 3)))
- # now missing = "fail"
- checkException(getEdge(phy.alt, c(-9, 0, 50), missing="fail"))
- checkException(getEdge(phy.alt, c(1, 3), type="ancestor",
- missing="fail"))
-
- # node includes NAs, but missing = "OK"
- checkTrue(is.na(getEdge(phy.alt, NA_integer_, type="ancestor",
- missing="OK")))
- checkTrue(is.na(getEdge(phy.alt, NA_character_, type="ancestor",
- missing="OK")))
-
- # node includes mixture of valid values and NAs
- checkIdentical(getEdge(phy.alt, c("t3", "n8", NA), type="ancestor",
- missing="OK"), setNames(c(NA, "8-9", "8-3", NA), c(3, 8, 8, NA)))
- checkIdentical(getEdge(phy.alt, c(3, 8, NA), type="ancestor",
- missing="OK"), setNames(c(NA, "8-9", "8-3", NA), c(3, 8, 8, NA)))
-
-}
-
-
Added: pkg/tests/test-all.R
===================================================================
--- pkg/tests/test-all.R (rev 0)
+++ pkg/tests/test-all.R 2014-03-10 04:10:29 UTC (rev 858)
@@ -0,0 +1,2 @@
+
+test_check("phylobase")
Added: pkg/tests/testthat/test.badnex.R
===================================================================
--- pkg/tests/testthat/test.badnex.R (rev 0)
+++ pkg/tests/testthat/test.badnex.R 2014-03-10 04:10:29 UTC (rev 858)
@@ -0,0 +1,15 @@
+#
+# --- Test badnex.R ---
+#
+
+test_that("Malformed Nexus File should not work.", {
+ if (Sys.getenv("RCMDCHECK") == FALSE) {
+ pth <- file.path(getwd(), "..", "inst", "nexusfiles")
+ } else {
+ pth <- system.file(package="phylobase", "nexusfiles")
+ }
+ badFile <- file.path(pth, "badnex.nex")
+ expect_error(readNexus(file=badFile))
+})
+
+
Added: pkg/tests/testthat/test.methods-phylo4.R
===================================================================
--- pkg/tests/testthat/test.methods-phylo4.R (rev 0)
+++ pkg/tests/testthat/test.methods-phylo4.R 2014-03-10 04:10:29 UTC (rev 858)
@@ -0,0 +1,550 @@
+##
+## --- Test methods-phylo4.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,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
+nid.int <- 6:9
+nid.all <- c(nid.tip, nid.int)
+lab.tip <- paste("t", nid.tip, sep="")
+lab.int <- paste("n", nid.int, sep="")
+lab.all <- c(lab.tip, lab.int)
+eid <- paste(ancestor, descendant, sep="-")
+elen <- descendant/10
+elab <- paste("e", eid, 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 label <- rev(phy at 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)]
+descendant <- descendant[c(6:9, 1:5)]
+edge <- cbind(ancestor, descendant)
+eid <- eid[c(6:9, 1:5)]
+elen <- elen[c(6:9, 1:5)]
+elab <- elab[c(6:9, 1:5)]
+
+op <- phylobase.options()
+#-----------------------------------------------------------------------
+
+context("nTips, depthTips, nNodes, nodeType")
+
+test_that("nTips works correctly",
+ expect_that(nTips(phy.alt), equals(length(nid.tip)))
+)
+
+test_that("depthTips works when there are edge lengths", {
+ edgeLengthVec <- c(1.2, 1.8, 1.8, 2.1, 2.3)
+ names(edgeLengthVec) <- tipLabels(phy.alt)
+ expect_that(depthTips(phy.alt), equals(edgeLengthVec))
+})
+
+test_that("depthTips works when there are no edge lengths", {
+ tmpPhy <- phy.alt
+ edgeLength(tmpPhy) <- NA
+ expect_true(is.null(depthTips(tmpPhy)))
+})
+
+test_that("nTips works on ape objects",
+ ## nTips phylo
+ expect_equal(nTips(tr), 5))
+
+test.nEdges.phylo4 <- function() {
+ expect_identical(nEdges(phy.alt), nrow(edge))
+}
+
+test_that("nNodes works as expected",
+ expect_equal(nNodes(phy.alt), length(nid.int)))
+
+test_that("nodeType works as expected",
+ expect_identical(nodeType(phy.alt),
+ setNames(c(rep("tip", length(nid.tip)),
+ "root",
+ rep("internal", length(nid.int)-1)),
+ c(nid.tip, nid.int))))
+
+context("nodeId")
+test_that("nodeId works without arguments",
+ expect_identical(nodeId(phy.alt), c(nid.tip, nid.int)))
+test_that("nodeId works with argument all",
+ expect_identical(nodeId(phy.alt, "all"), c(nid.tip, nid.int)))
+test_that("nodeId works with argument tip",
+ expect_identical(nodeId(phy.alt, "tip"), nid.tip))
+test_that("nodeId works with argument internal",
+ expect_identical(nodeId(phy.alt, "internal"), nid.int))
+test_that("nodeId works woth argument root",
+ expect_identical(nodeId(phy.alt, "root"), nid.int[1]))
+
+
+context("nodeDepth")
+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))
+test_that("nodeDepth works without arguments", {
+ expect_identical(nodeDepth(phy.alt), allDepths)
+})
+
+test_that("nodeDepth works with numeric argument", {
+ expect_identical(nodeDepth(phy.alt, 1), allDepths[1])
+})
+
+test_that("nodeDepth works with character argument", {
+ expect_identical(nodeDepth(phy.alt, "t1"), allDepths[1])
+})
+
+test_that("nodeDepth works with no branch length", {
+ tmpPhy <- phy.alt
+ edgeLength(tmpPhy) <- NA
+ expect_true(is.null(nodeDepth(tmpPhy)))
+})
+
+context("edges")
+test_that("edges works", expect_identical(edges(phy.alt), edge))
+test_that("edges work with drop.root=TRUE option",
+ expect_identical(edges(phy.alt, drop.root=TRUE),
+ edge[edge[,1] != 0,]))
+
+context("edge order")
+test_that("edgeOrder works as expected", {
+ expect_identical(edgeOrder(phy.alt), "unknown")
+ expect_identical(edgeOrder(reorder(phy.alt, "preorder")), "preorder")
+ expect_identical(edgeOrder(reorder(phy.alt, "postorder")), "postorder")
+})
+
+context("edgeId")
+test_that("edgeId works with no argument",
+ expect_identical(edgeId(phy.alt), eid))
+test_that("edgeId works with argument all",
+ expect_identical(edgeId(phy.alt, "all"), eid))
+test_that("edgeId works with argument tip",
+ expect_identical(edgeId(phy.alt, "tip"), eid[descendant %in% nid.tip]))
+test_that("edgeId works with argument internal",
+ expect_identical(edgeId(phy.alt, "internal"), eid[!descendant %in% nid.tip]))
+test_that("edgeId works with argument root",
+ expect_identical(edgeId(phy.alt, "root"), eid[ancestor == 0]))
+
+context("hasEdgeLength")
+test_that("hasEdgeLength works when edge lengths are present",
+ expect_true(hasEdgeLength(phy.alt)))
+test_that("hasEdgeLength works when no edge lengths are present", {
+ phy.alt at edge.length <- NA_real_
+ expect_true(!hasEdgeLength(phy.alt))
+})
+
+
+context("edgeLength")
+test_that("default works (all edge lengths)",
+ expect_identical(edgeLength(phy.alt), setNames(elen, eid)))
+test_that("one edge length, by label",
+ expect_equal(edgeLength(phy.alt, "t1"), c(`7-1`=0.1)))
+test_that("one edge length, by node ID",
+ expect_equal(edgeLength(phy.alt, 1), c(`7-1`=0.1)))
+test_that("non-existent edge, by label", {
+ ans <- structure(NA_real_, .Names = NA_character_)
+ expect_equal(suppressWarnings(edgeLength(phy.alt, "xxx")), ans)
+})
+test_that("non-existent edge, by number", {
+ ans <- structure(NA_real_, .Names = NA_character_)
+ expect_equal(suppressWarnings(edgeLength(phy.alt, 999)), ans)
+})
+test_that("wrong number of edge lengths", {
+ phy.tmp1 <- phy.alt
+ phy.tmp1 at edge.length <- phy.alt at edge.length[-1]
+ expect_true(nzchar(checkPhylo4(phy.tmp1)))
+ phy.tmp1 <- phy.alt
+ phy.tmp1 at edge.length <- c(phy.alt at edge.length, 1)
+ expect_true(nzchar(checkPhylo4(phy.tmp1)))
+})
+test_that("negative edge lengths", {
+ phy.tmp1 <- phy.alt
+ phy.tmp1 at edge.length[3] <- -1
+ expect_true(nzchar(checkPhylo4(phy.tmp1)))
+})
+test_that("edge incorrectly labeled", {
+ phy.tmp1 <- phy.alt
+ names(phy.tmp1 at edge.length)[1] <- "9-10"
+ expect_true(nzchar(checkPhylo4(phy.tmp1)))
+})
+
+context("edgeLength <-")
+emptyVec <- numeric()
+attributes(emptyVec) <- list(names=character(0))
+test_that("dropping all should produce empty slot", {
+ edgeLength(phy.alt) <- numeric()
+ expect_identical(edgeLength(phy.alt), setNames(rep(NA_real_, 9), edgeId(phy.alt, "all")))
+ expect_identical(phy.alt at edge.length, emptyVec)
+ edgeLength(phy.alt) <- NA_real_
+ expect_identical(edgeLength(phy.alt), setNames(rep(NA_real_, 9), edgeId(phy.alt, "all")))
+ expect_identical(phy.alt at edge.length, emptyVec)
+})
+test_that("vector with reversed names, get matched by default (complete replacement)", {
+ edgeLength(phy.alt) <- numeric()
+ revElen <- setNames(elen, rev(eid))
+ edgeLength(phy.alt) <- revElen
+ expect_identical(edgeLength(phy.alt), revElen[edgeId(phy.alt, "all")])
+})
+test_that("vector with reversed names, but specify no matching (complete replacement)", {
+ edgeLength(phy.alt) <- numeric()
+ revElen <- setNames(elen, rev(eid))
+ edgeLength(phy.alt, use.names=FALSE) <- revElen
+ elen1 <- elen
+ expect_identical(edgeLength(phy.alt), setNames(elen1, edgeId(phy.alt, "all")))
+})
+test_that("vector with no names, should match to edgeId order (complete replacement)", {
+ edgeLength(phy.alt) <- numeric()
+ edgeLength(phy.alt) <- elen
+ elen2 <- elen
+ expect_identical(edgeLength(phy.alt), setNames(elen2, edgeId(phy.alt, "all")))
+})
+test_that("recycling applies if fewer the nEdges elements are supplied, \
+ (duplicate edge length are okay), (complete replacement)", {
+ edgeLength(phy.alt) <- 1
+ expect_identical(edgeLength(phy.alt), setNames(rep(1, 9), edgeId(phy.alt, "all")))
+})
+edgeLength(phy.alt) <- elen
+test_that("replace an edge length using numeric index (partial replacement)", {
+ edgeLength(phy.alt)[9] <- 83
+ expect_identical(edgeLength(phy.alt), setNames(c(elen[1:8], 83), edgeId(phy.alt, "all")))
+})
+test_that("back again, now using character index (partial replacement)", {
+ edgeLength(phy.alt)["8-3"] <- 0.3
+ elen3 <- elen
+ expect_identical(edgeLength(phy.alt), setNames(elen3, edgeId(phy.alt, "all")))
+})
+test_that("error to add length for edges that don't exist (partial replacement)", {
+ expect_error(edgeLength(phy.alt)["fake"] <- 999)
+ expect_error(edgeLength(phy.alt)[999] <- 999)
+})
+test_that("NAs permitted only for root edge (or for *all* edges)", {
+ edgeLength(phy.alt)[edgeId(phy.alt, "root")] <- NA
+ expect_identical(edgeLength(phy.alt), setNames(c(NA, elen[2:9]), edgeId(phy.alt, "all")))
+ edgeLength(phy.alt) <- elen
+ expect_error(edgeLength(phy.alt)["8-3"] <- NA)
+})
+
+
+## TODO sumEdgeLength.phylo4 ## function(phy, node)
+
+context("isRooted")
+test_that("isRooted works as expected",
+ expect_true(isRooted(phy.alt)))
+
+context("rootNode")
+test_that("rootNode works as expected",
+ expect_identical(rootNode(phy.alt), nid.int[1]))
+
+context("rootNode <-")
+test_that("rootNode <- is not yet implemented",
+ expect_error(rootNode(phy.alt) <- 7))
+
+context("labels")
+test_that("labels works as expected with no argument",
+ expect_identical(labels(phy.alt),
+ setNames(c(lab.tip, lab.int), c(nid.tip, nid.int))))
+test_that("labels works as expected with argument all",
+ expect_identical(labels(phy.alt, "all"),
+ setNames(c(lab.tip, lab.int), c(nid.tip, nid.int))))
+test_that("labels works as expected with argument tip",
+ expect_identical(labels(phy.alt, "tip"), setNames(lab.tip, nid.tip)))
+test_that("labels works as expected with argument internal",
+ expect_identical(labels(phy.alt, "internal"), setNames(lab.int, nid.int)))
+
+
+context("labels <-")
+test_that("dropping all should produce default tip labels, no internal labels", {
+ labels(phy.alt) <- character()
+ expect_identical(labels(phy.alt),
+ setNames(c(paste("T", 1:5, sep=""), rep(NA, 4)), nid.all))
+})
+
+## #
+## # complete replacement
+## #
+
+## with names, not used
+test_that("vector with reversed names, but names not used (all) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt) <- setNames(lab.all, rev(nid.all))
+ expect_identical(labels(phy.alt), setNames(lab.all, nid.all))
+})
+test_that("vector with reversed names, but names not used (tips) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, "tip") <- setNames(lab.tip, rev(nid.tip))
+ expect_identical(tipLabels(phy.alt), setNames(lab.tip, nid.tip))
+})
+test_that("vector with reversed names, but names not used (internal) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, "internal") <- setNames(lab.int, rev(nid.int))
+ expect_identical(nodeLabels(phy.alt), setNames(lab.int, nid.int))
+})
+
+## with names, used
+test_that("vector with reversed names, but names used (all) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, use.names=TRUE) <- setNames(lab.all, rev(nid.all))
+ expect_identical(labels(phy.alt), setNames(rev(lab.all), nid.all))
+})
+test_that("vector with reversed names, but names used (tips) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, "tip", use.names=TRUE) <- setNames(lab.tip, rev(nid.tip))
+ expect_identical(tipLabels(phy.alt), setNames(rev(lab.tip), nid.tip))
+})
+test_that("vector with reversed names, but names used (internal) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, "internal", use.names=TRUE) <- setNames(lab.int, rev(nid.int))
+ expect_identical(nodeLabels(phy.alt), setNames(rev(lab.int), nid.int))
+})
+## no names
+test_that("vector with no names, should match to nodeId order (all) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt) <- lab.all
+ expect_identical(labels(phy.alt), setNames(lab.all, nid.all))
+})
+test_that("vector with no names, should match to nodeId order (all) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, type="tip") <- lab.tip
+ expect_identical(tipLabels(phy.alt), setNames(lab.tip, nid.tip))
+})
+test_that("vector with no names, should match to nodeId order (all) - complete replacement", {
+ labels(phy.alt) <- character()
+ labels(phy.alt, type="internal") <- lab.int
+ expect_identical(nodeLabels(phy.alt), setNames(lab.int, nid.int))
+})
+
+## partial replacement
+labels(phy.alt) <- lab.all
+test_that("replace a tip using numeric index", {
+ labels(phy.alt)[5] <- "t5a"
+ expect_identical(tipLabels(phy.alt), setNames(c(lab.tip[1:4], "t5a"), nid.tip))
+})
+test_that("and back again, now using character index", {
+ labels(phy.alt)["5"] <- "t5"
+ expect_identical(labels(phy.alt), setNames(lab.all, nid.all))
+})
+test_that("replace an internal node using numeric index", {
+ labels(phy.alt)[9] <- "n9a"
+ expect_identical(nodeLabels(phy.alt), setNames(c(lab.int[1:3], "n9a"), nid.int))
+})
+test_that("and back again, now using character index", {
+ labels(phy.alt)["9"] <- "n9"
+ expect_identical(labels(phy.alt), setNames(lab.all, nid.all))
+})
+test_that("error to produce duplicate tip or internal label", {
+ phylobase.options(allow.duplicated.labels="fail")
+ expect_error(labels(phy.alt)[1] <- "t2")
+ expect_error(labels(phy.alt)[6] <- "n7")
+})
+test_that("no error in allow.duplicated.labels is ok", {
+ phylobase.options(allow.duplicated.labels="ok")
+ labels(phy.alt)[1] <- "t2"
+ labels(phy.alt)[6] <- "n7"
+ expect_identical(tipLabels(phy.alt), setNames(c("t2", "t2", "t3", "t4", "t5"), nid.tip))
+ expect_identical(nodeLabels(phy.alt), setNames(c("n7", "n7", "n8", "n9"), nid.int))
+})
+test_that("error to add labels for nodes that don't exist", {
+ expect_error(labels(phy.alt)["fake"] <- "xxx")
+ expect_error(labels(phy.alt)[999] <- "xxx")
+})
+
+context("nodeLabels")
+test_that("nodeLabels works as expected",
+ expect_identical(nodeLabels(phy.alt), setNames(lab.int, nid.int)))
+
+context("hasNodeLabels")
+test_that("hasNodeLabels works as expected", {
+ expect_true(hasNodeLabels(phy.alt))
+ nodeLabels(phy.alt) <- NA_character_
+ expect_true(!hasNodeLabels(phy.alt))
+})
+
+context("nodeLabels <-")
+test_that("dropping all should produce no internal labels", {
+ nodeLabels(phy.alt) <- character()
+ expect_true(!any(nid.int %in% names(phy.alt at label)))
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 858
More information about the Phylobase-commits
mailing list