[Phylobase-commits] r938 - in pkg: inst/unitTests tests/testthat
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 7 16:57:10 CEST 2014
Author: francois
Date: 2014-05-07 16:57:09 +0200 (Wed, 07 May 2014)
New Revision: 938
Added:
pkg/tests/testthat/test.class-phylo4d.R
Removed:
pkg/inst/unitTests/runit.class-phylo4d.R
Log:
moved/converted class-phylo4d tests
Deleted: pkg/inst/unitTests/runit.class-phylo4d.R
===================================================================
--- pkg/inst/unitTests/runit.class-phylo4d.R 2014-05-07 14:56:51 UTC (rev 937)
+++ pkg/inst/unitTests/runit.class-phylo4d.R 2014-05-07 14:57:09 UTC (rev 938)
@@ -1,291 +0,0 @@
-#
-# --- Test class-phylo4d.R ---
-#
-
-# create ape::phylo version of a simple tree for testing
-## require(ape) ## messes badly with edges()!
-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 <- ape::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)
-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 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)]
-
-# create data to add to phylo4 to create phylo4d, but with data rows out
-# of order
-set.seed(1)
-nid.tip.r <- sample(nid.tip)
-nid.int.r <- sample(nid.int)
-nid.all.r <- sample(c(nid.tip, nid.int))
-allDt <- data.frame(a=letters[nid.all.r], b=10*nid.all.r)
-tipDt <- data.frame(c=letters[nid.tip.r], d=10*nid.tip.r)
-nodDt <- data.frame(c=letters[nid.int.r], e=10*nid.int.r)
-## set row.names as numeric node IDs (may be changed in tests below)
-row.names(allDt) <- nid.all.r
-row.names(tipDt) <- nid.tip.r
-row.names(nodDt) <- nid.int.r
-
-#-----------------------------------------------------------------------
-
-test.phylo4d.phylo4 <- function() {
-
- ## case 1: add data matching only on row position
- row.names(allDt) <- NULL
- row.names(tipDt) <- NULL
- row.names(nodDt) <- NULL
-
- ## these should fail because row.names don't match nodes
- checkException(phylo4d(phy.alt, tip.data=tipDt, rownamesAsLabels=TRUE))
- checkException(phylo4d(phy.alt, node.data=nodDt))
-
- ## brute force: no matching; with tip data
- phyd <- phylo4d(phy.alt, tip.data=tipDt, match.data=FALSE)
- checkIdentical(phyd at data, data.frame(tipDt,
- row.names=nid.tip))
- checkIdentical(tdata(phyd, "tip"), data.frame(tipDt,
- row.names=lab.tip))
-
- ## brute force: no matching; with node data
- phyd <- phylo4d(phy.alt, node.data=nodDt, match.data=FALSE)
- checkIdentical(phyd at data, data.frame(nodDt,
- row.names=nid.int))
- checkIdentical(tdata(phyd, "internal"), data.frame(nodDt,
- row.names=lab.int))
-
- ## brute force: no matching; with all.data
- phyd <- phylo4d(phy.alt, all.data=allDt, match.data=FALSE)
- checkIdentical(phyd at data, data.frame(allDt,
- row.names=nid.all))
- checkIdentical(tdata(phyd, "all"), data.frame(allDt,
- row.names=lab.all))
-
- ## brute force: no matching; with tip & node data
- ## no merging (data names don't match)
- phyd <- phylo4d(phy.alt, tip.data=tipDt["d"], node.data=nodDt["e"],
- match.data=FALSE)
- checkIdentical(phyd at data, data.frame(rbind(data.frame(tipDt["d"],
- e=NA_real_), data.frame(d=NA_real_, nodDt["e"])),
- row.names=nid.all))
- checkIdentical(tdata(phyd, "tip"), data.frame(tipDt["d"], e=NA_real_,
- row.names=lab.tip))
- checkIdentical(tdata(phyd, "internal"), data.frame(d=NA_real_, nodDt["e"],
- row.names=lab.int))
-
- ## brute force: no matching; with tip & node data
- ## merging (common data names)
- phyd <- phylo4d(phy.alt, tip.data=tipDt["c"], node.data=nodDt["c"],
- match.data=FALSE)
- checkIdentical(phyd at data, data.frame(rbind(tipDt["c"], nodDt["c"]),
- row.names=nid.all))
- checkIdentical(tdata(phyd, "tip"), data.frame(c=factor(tipDt$c,
- levels=letters[nid.all]), row.names=lab.tip))
- checkIdentical(tdata(phyd, "internal"), data.frame(c=factor(nodDt$c,
- levels=letters[nid.all]), row.names=lab.int))
-
- ## case 2: add data matching on numeric (node ID) row.names
- row.names(allDt) <- nid.all.r
- row.names(tipDt) <- nid.tip.r
- row.names(nodDt) <- nid.int.r
-
- ## match with node numbers, tip data
- phyd <- phylo4d(phy.alt, tip.data=tipDt)
- checkIdentical(phyd at data, data.frame(tipDt[order(nid.tip.r),],
- row.names=nid.tip))
- checkIdentical(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),],
- row.names=lab.tip))
-
- ## match with node numbers, node data
- phyd <- phylo4d(phy.alt, node.data=nodDt)
- checkIdentical(phyd at data, data.frame(nodDt[order(nid.int.r),],
- row.names=nid.int))
- checkIdentical(tdata(phyd, "internal"), data.frame(nodDt[order(nid.int.r),],
- row.names=lab.int))
-
- ## match with node numbers, tip & node data, no merge
- phyd <- phylo4d(phy.alt, tip.data=tipDt["d"], node.data=nodDt["e"])
- checkIdentical(phyd at data, data.frame(rbind(data.frame(
- d=tipDt[order(nid.tip.r), "d"], e=NA_real_),
- data.frame(d=NA_real_, e=nodDt[order(nid.int.r), "e"])),
- row.names=nid.all))
- checkIdentical(tdata(phyd, "tip"), data.frame(d=tipDt[order(nid.tip.r), "d"],
- e=NA_real_, row.names=lab.tip))
- checkIdentical(tdata(phyd, "internal"), data.frame(d=NA_real_,
- e=nodDt[order(nid.int.r), "e"], row.names=lab.int))
-
- ## match with node numbers, tip & all data
- phyd <- phylo4d(phy.alt, tip.data=tipDt, all.data=allDt)
- merged <- data.frame(merge(allDt[order(nid.all.r),],
- tipDt[order(nid.tip.r),], all=TRUE, by=0)[-1])
- checkIdentical(phyd at data, data.frame(merged, row.names=nid.all))
- checkIdentical(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
-
- ## match with node numbers, node & all data
- phyd <- phylo4d(phy.alt, node.data=nodDt, all.data=allDt)
- merged <- data.frame(merge(allDt[order(nid.all.r),],
- nodDt[order(nid.int.r),], all=TRUE, by=0)[-1])
- checkIdentical(phyd at data, data.frame(merged, row.names=nid.all))
- checkIdentical(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
-
- ## match with node numbers, tip, node & all data
- phyd <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt, all.data=allDt)
- # merge alldata with common tip and node data
- m1 <- data.frame(merge(allDt, rbind(tipDt["c"], nodDt["c"]),
- all=TRUE, by=0)[-1])
- # merge distinct columns of tipdata and nodedata
- m2 <- data.frame(merge(tipDt["d"], nodDt["e"], all=TRUE, by=0)[-1])
- # ...now merge these together
- merged <- data.frame(merge(m1, m2, by=0)[-1])
- checkIdentical(phyd at data, data.frame(merged,
- row.names=nid.all))
- checkIdentical(tdata(phyd, "tip"), data.frame(merged[nid.tip,],
- row.names=lab.tip, check.names=FALSE))
- checkIdentical(tdata(phyd, "internal"), data.frame(merged[nid.int,],
- row.names=lab.int, check.names=FALSE))
- checkIdentical(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
-
- ## as above, but without merging common tip and node column
- phyd <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt,
- all.data=allDt, merge.data=FALSE)
- m3 <- data.frame(merge(tipDt, nodDt, all=TRUE, by=0,
- suffix=c(".tip", ".node"))[-1])
- merged <- data.frame(merge(allDt, m3, by=0)[-1])
- checkIdentical(phyd at data, data.frame(merged,
- row.names=nid.all))
- checkIdentical(tdata(phyd, "tip"), data.frame(merged[nid.tip,],
- row.names=lab.tip, check.names=FALSE))
- checkIdentical(tdata(phyd, "internal"), data.frame(merged[nid.int,],
- row.names=lab.int, check.names=FALSE))
- checkIdentical(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
-
- ## case 3: add data matching on character (label) row.names for tips
- row.names(tipDt) <- c(lab.tip, lab.int)[nid.tip.r]
- row.names(nodDt) <- c(lab.tip, lab.int)[nid.int.r]
-
- ## match with names, tip data
- phyd <- phylo4d(phy.alt, tip.data=tipDt)
- checkIdentical(phyd at data, data.frame(tipDt[order(nid.tip.r),],
- row.names=nid.tip))
- checkIdentical(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),],
- row.names=lab.tip))
-
- ## case 4: add data matching on mixed rowname types (for tips and
- ## for internal nodes)
- row.names(allDt)[match(nid.tip.r, nid.all.r)] <- lab.tip[nid.tip.r]
- row.names(allDt)[match(nid.int.r, nid.all.r)] <- nid.int.r
-
- ## match with names for tips and numbers for nodes with all data
- phyd <- phylo4d(phy.alt, all.data=allDt)
- checkIdentical(tdata(phyd, "all"), data.frame(allDt[match(nid.all,
- nid.all.r),], row.names=lab.all))
- checkIdentical(tdata(phyd, "tip"), data.frame(allDt[match(nid.tip,
- nid.all.r),], row.names=lab.tip))
- checkIdentical(tdata(phyd, "internal"), data.frame(allDt[match(nid.int,
- nid.all.r),], row.names=lab.int))
- checkIdentical(phyd at data, data.frame(allDt[match(nid.all, nid.all.r),],
- row.names=nid.all))
-
-}
-
-test.phylo4d.matrix <- function() {
-}
-
-# note: this method mostly does phylo4(phylo), then phylo4d(phylo4),
-# then addData methods, which are tested more thoroughly elsewhere;
-# focus here is on metadata and check.node.labels="asdata" arguments
-test.phylo4d.phylo <- function() {
- # function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
- # check.node.labels=c("keep", "drop", "asdata"), annote=list(),
- # metadata=list(), ...)
-
- # show that method basically just wraps phylo4d("phylo4")
- phyd.tr <- phylo4d(tr, tip.data=tipDt, node.data=nodDt,
- all.data=allDt, match.data=TRUE, merge.data=TRUE)
- checkTrue(class(phyd.tr)=="phylo4d")
- phyd.phy <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt,
- all.data=allDt, match.data=TRUE, merge.data=TRUE)
- # reorder for edge order consistency, then test each slot (except
- # edge labels, b/c phylo object has none)
- phyd.tr <- reorder(phyd.tr)
- phyd.phy <- reorder(phyd.phy)
- checkIdentical(edges(phyd.tr), edges(phyd.phy))
- checkIdentical(edgeLength(phyd.tr), edgeLength(phyd.phy))
- checkIdentical(nNodes(phyd.tr), nNodes(phyd.phy))
- checkIdentical(tipLabels(phyd.tr), tipLabels(phyd.phy))
- checkIdentical(nodeLabels(phyd.tr), nodeLabels(phyd.phy))
- checkIdentical(edgeOrder(phyd.tr), edgeOrder(phyd.phy))
- checkIdentical(phyd.tr at annote, phyd.phy at annote)
- # other misc checks
- checkEquals(phylo4d(phylo4(tr)), phylo4d(tr))
- checkEquals(phylo4d(phylo4(tr, check.node.labels="drop")),
- phylo4d(tr, check.node.labels="drop"))
-
- ##
- ## metadata
- ##
-
- metadata <- list(x="metadata")
- phyd <- phylo4d(tr, metadata=metadata)
- checkIdentical(metadata, phyd at metadata)
-
- ##
- ## check.node.labels
- ##
-
- # case 0: no node labels
- tr$node.label <- NULL
- phyd <- phylo4d(tr)
- checkTrue(!hasNodeLabels(phyd))
-
- # case 1: convert character labels as data
- tr$node.label <- paste("n", 1:4, sep="")
- phyd <- phylo4d(tr, check.node.labels="asdata")
- checkTrue(!hasNodeLabels(phyd))
- checkEquals(tdata(phyd, "internal")$labelValues, as.factor(tr$node.label))
-
- # case 2: convert number-like characters labels to numeric data
- tr$node.label <- as.character(1:4)
- phyd <- phylo4d(tr, check.node.labels="asdata")
- checkTrue(!hasNodeLabels(phyd))
- checkIdentical(tdata(phyd, "internal")$labelValues,
- as.numeric(tr$node.label))
-
- # case 3: convert numeric labels to numeric data
- tr$node.label <- as.numeric(1:4)
- phyd <- phylo4d(tr, check.node.labels="asdata")
- checkTrue(!hasNodeLabels(phyd))
- checkIdentical(tdata(phyd, "internal")$labelValues, tr$node.label)
-
- # case 4: non-unique labels can be converted to data
- tr$node.label <- rep(99, 4)
- phyd <- phylo4d(tr)
- checkIdentical(unname(nodeLabels(phyd)), as.character(tr$node.label))
- phyd <- phylo4d(tr, check.node.labels="asdata")
- checkTrue(!hasNodeLabels(phyd))
- checkIdentical(tdata(phyd, "internal", label.type="column")$labelValues, tr$node.label)
-}
-
-## phylo4d->phylo4d is currently unallowed
-test.phylo4d.phylo4d <- function() {
- phyd <- phylo4d(phy)
- checkException(phylo4d(phyd))
-}
-
Copied: pkg/tests/testthat/test.class-phylo4d.R (from rev 880, pkg/inst/unitTests/runit.class-phylo4d.R)
===================================================================
--- pkg/tests/testthat/test.class-phylo4d.R (rev 0)
+++ pkg/tests/testthat/test.class-phylo4d.R 2014-05-07 14:57:09 UTC (rev 938)
@@ -0,0 +1,294 @@
+#
+# --- Test class-phylo4d.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 <- ape::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)
+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 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)]
+
+# create data to add to phylo4 to create phylo4d, but with data rows out
+# of order
+set.seed(1)
+nid.tip.r <- sample(nid.tip)
+nid.int.r <- sample(nid.int)
+nid.all.r <- sample(c(nid.tip, nid.int))
+allDt <- data.frame(a=letters[nid.all.r], b=10*nid.all.r)
+tipDt <- data.frame(c=letters[nid.tip.r], d=10*nid.tip.r)
+nodDt <- data.frame(c=letters[nid.int.r], e=10*nid.int.r)
+## set row.names as numeric node IDs (may be changed in tests below)
+row.names(allDt) <- nid.all.r
+row.names(tipDt) <- nid.tip.r
+row.names(nodDt) <- nid.int.r
+
+#-----------------------------------------------------------------------
+
+context("test phylo4d class")
+
+test_that("phylo4d can be built from phylo4", {
+
+ ## case 1: add data matching only on row position
+ row.names(allDt) <- NULL
+ row.names(tipDt) <- NULL
+ row.names(nodDt) <- NULL
+
+ ## these should fail because row.names don't match nodes
+ expect_error(phylo4d(phy.alt, tip.data=tipDt, rownamesAsLabels=TRUE))
+ expect_error(phylo4d(phy.alt, node.data=nodDt))
+
+ ## brute force: no matching; with tip data
+ phyd <- phylo4d(phy.alt, tip.data=tipDt, match.data=FALSE)
+ expect_equal(phyd at data, data.frame(tipDt,
+ row.names=nid.tip))
+ expect_equal(tdata(phyd, "tip"), data.frame(tipDt,
+ row.names=lab.tip))
+
+ ## brute force: no matching; with node data
+ phyd <- phylo4d(phy.alt, node.data=nodDt, match.data=FALSE)
+ expect_equal(phyd at data, data.frame(nodDt,
+ row.names=nid.int))
+ expect_equal(tdata(phyd, "internal"), data.frame(nodDt,
+ row.names=lab.int))
+
+ ## brute force: no matching; with all.data
+ phyd <- phylo4d(phy.alt, all.data=allDt, match.data=FALSE)
+ expect_equal(phyd at data, data.frame(allDt,
+ row.names=nid.all))
+ expect_equal(tdata(phyd, "all"), data.frame(allDt,
+ row.names=lab.all))
+
+ ## brute force: no matching; with tip & node data
+ ## no merging (data names don't match)
+ phyd <- phylo4d(phy.alt, tip.data=tipDt["d"], node.data=nodDt["e"],
+ match.data=FALSE)
+ expect_equal(phyd at data, data.frame(rbind(data.frame(tipDt["d"],
+ e=NA_real_), data.frame(d=NA_real_, nodDt["e"])),
+ row.names=nid.all))
+ expect_equal(tdata(phyd, "tip"), data.frame(tipDt["d"], e=NA_real_,
+ row.names=lab.tip))
+ expect_equal(tdata(phyd, "internal"), data.frame(d=NA_real_, nodDt["e"],
+ row.names=lab.int))
+
+ ## brute force: no matching; with tip & node data
+ ## merging (common data names)
+ phyd <- phylo4d(phy.alt, tip.data=tipDt["c"], node.data=nodDt["c"],
+ match.data=FALSE)
+ expect_equal(phyd at data, data.frame(rbind(tipDt["c"], nodDt["c"]),
+ row.names=nid.all))
+ expect_equal(tdata(phyd, "tip"), data.frame(c=factor(tipDt$c,
+ levels=letters[nid.all]), row.names=lab.tip))
+ expect_equal(tdata(phyd, "internal"), data.frame(c=factor(nodDt$c,
+ levels=letters[nid.all]), row.names=lab.int))
+
+ ## case 2: add data matching on numeric (node ID) row.names
+ row.names(allDt) <- nid.all.r
+ row.names(tipDt) <- nid.tip.r
+ row.names(nodDt) <- nid.int.r
+
+ ## match with node numbers, tip data
+ phyd <- phylo4d(phy.alt, tip.data=tipDt)
+ expect_equal(phyd at data, data.frame(tipDt[order(nid.tip.r),],
+ row.names=nid.tip))
+ expect_equal(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),],
+ row.names=lab.tip))
+
+ ## match with node numbers, node data
+ phyd <- phylo4d(phy.alt, node.data=nodDt)
+ expect_equal(phyd at data, data.frame(nodDt[order(nid.int.r),],
+ row.names=nid.int))
+ expect_equal(tdata(phyd, "internal"), data.frame(nodDt[order(nid.int.r),],
+ row.names=lab.int))
+
+ ## match with node numbers, tip & node data, no merge
+ phyd <- phylo4d(phy.alt, tip.data=tipDt["d"], node.data=nodDt["e"])
+ expect_equal(phyd at data, data.frame(rbind(data.frame(
+ d=tipDt[order(nid.tip.r), "d"], e=NA_real_),
+ data.frame(d=NA_real_, e=nodDt[order(nid.int.r), "e"])),
+ row.names=nid.all))
+ expect_equal(tdata(phyd, "tip"), data.frame(d=tipDt[order(nid.tip.r), "d"],
+ e=NA_real_, row.names=lab.tip))
+ expect_equal(tdata(phyd, "internal"), data.frame(d=NA_real_,
+ e=nodDt[order(nid.int.r), "e"], row.names=lab.int))
+
+ ## match with node numbers, tip & all data
+ phyd <- phylo4d(phy.alt, tip.data=tipDt, all.data=allDt)
+ merged <- data.frame(merge(allDt[order(nid.all.r),],
+ tipDt[order(nid.tip.r),], all=TRUE, by=0)[-1])
+ expect_equal(phyd at data, data.frame(merged, row.names=nid.all))
+ expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
+
+ ## match with node numbers, node & all data
+ phyd <- phylo4d(phy.alt, node.data=nodDt, all.data=allDt)
+ merged <- data.frame(merge(allDt[order(nid.all.r),],
+ nodDt[order(nid.int.r),], all=TRUE, by=0)[-1])
+ expect_equal(phyd at data, data.frame(merged, row.names=nid.all))
+ expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
+
+ ## match with node numbers, tip, node & all data
+ phyd <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt, all.data=allDt)
+ # merge alldata with common tip and node data
+ m1 <- data.frame(merge(allDt, rbind(tipDt["c"], nodDt["c"]),
+ all=TRUE, by=0)[-1])
+ # merge distinct columns of tipdata and nodedata
+ m2 <- data.frame(merge(tipDt["d"], nodDt["e"], all=TRUE, by=0)[-1])
+ # ...now merge these together
+ merged <- data.frame(merge(m1, m2, by=0)[-1])
+ expect_equal(phyd at data, data.frame(merged,
+ row.names=nid.all))
+ expect_equal(tdata(phyd, "tip"), data.frame(merged[nid.tip,],
+ row.names=lab.tip, check.names=FALSE))
+ expect_equal(tdata(phyd, "internal"), data.frame(merged[nid.int,],
+ row.names=lab.int, check.names=FALSE))
+ expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
+
+ ## as above, but without merging common tip and node column
+ phyd <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt,
+ all.data=allDt, merge.data=FALSE)
+ m3 <- data.frame(merge(tipDt, nodDt, all=TRUE, by=0,
+ suffix=c(".tip", ".node"))[-1])
+ merged <- data.frame(merge(allDt, m3, by=0)[-1])
+ expect_equal(phyd at data, data.frame(merged,
+ row.names=nid.all))
+ expect_equal(tdata(phyd, "tip"), data.frame(merged[nid.tip,],
+ row.names=lab.tip, check.names=FALSE))
+ expect_equal(tdata(phyd, "internal"), data.frame(merged[nid.int,],
+ row.names=lab.int, check.names=FALSE))
+ expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all))
+
+ ## case 3: add data matching on character (label) row.names for tips
+ row.names(tipDt) <- c(lab.tip, lab.int)[nid.tip.r]
+ row.names(nodDt) <- c(lab.tip, lab.int)[nid.int.r]
+
+ ## match with names, tip data
+ phyd <- phylo4d(phy.alt, tip.data=tipDt)
+ expect_equal(phyd at data, data.frame(tipDt[order(nid.tip.r),],
+ row.names=nid.tip))
+ expect_equal(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),],
+ row.names=lab.tip))
+
+ ## case 4: add data matching on mixed rowname types (for tips and
+ ## for internal nodes)
+ row.names(allDt)[match(nid.tip.r, nid.all.r)] <- lab.tip[nid.tip.r]
+ row.names(allDt)[match(nid.int.r, nid.all.r)] <- nid.int.r
+
+ ## match with names for tips and numbers for nodes with all data
+ phyd <- phylo4d(phy.alt, all.data=allDt)
+ expect_equal(tdata(phyd, "all"), data.frame(allDt[match(nid.all,
+ nid.all.r),], row.names=lab.all))
+ expect_equal(tdata(phyd, "tip"), data.frame(allDt[match(nid.tip,
+ nid.all.r),], row.names=lab.tip))
+ expect_equal(tdata(phyd, "internal"), data.frame(allDt[match(nid.int,
+ nid.all.r),], row.names=lab.int))
+ expect_equal(phyd at data, data.frame(allDt[match(nid.all, nid.all.r),],
+ row.names=nid.all))
+
+})
+
+## test.phylo4d.matrix <- function() {
+## }
+
+# note: this method mostly does phylo4(phylo), then phylo4d(phylo4),
+# then addData methods, which are tested more thoroughly elsewhere;
+# focus here is on metadata and check.node.labels="asdata" arguments
+
+test_that("phylo4d can be built from phylo object", {
+ # function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
+ # check.node.labels=c("keep", "drop", "asdata"), annote=list(),
+ # metadata=list(), ...)
+
+ ## show that method basically just wraps phylo4d("phylo4")
+ phyd.tr <- phylo4d(tr, tip.data=tipDt, node.data=nodDt,
+ all.data=allDt, match.data=TRUE, merge.data=TRUE)
+ expect_true(class(phyd.tr)=="phylo4d")
+ phyd.phy <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt,
+ all.data=allDt, match.data=TRUE, merge.data=TRUE)
+ # reorder for edge order consistency, then test each slot (except
+ # edge labels, b/c phylo object has none)
+ phyd.tr <- reorder(phyd.tr)
+ phyd.phy <- reorder(phyd.phy)
+ expect_equal(edges(phyd.tr), edges(phyd.phy))
+ expect_equal(edgeLength(phyd.tr), edgeLength(phyd.phy))
+ expect_equal(nNodes(phyd.tr), nNodes(phyd.phy))
+ expect_equal(tipLabels(phyd.tr), tipLabels(phyd.phy))
+ expect_equal(nodeLabels(phyd.tr), nodeLabels(phyd.phy))
+ expect_equal(edgeOrder(phyd.tr), edgeOrder(phyd.phy))
+ expect_equal(phyd.tr at annote, phyd.phy at annote)
+ # other misc checks
+ expect_equal(phylo4d(phylo4(tr)), phylo4d(tr))
+ expect_equal(phylo4d(phylo4(tr, check.node.labels="drop")),
+ phylo4d(tr, check.node.labels="drop"))
+
+ ##
+ ## metadata
+ ##
+
+ metadata <- list(x="metadata")
+ phyd <- phylo4d(tr, metadata=metadata)
+ expect_equal(metadata, phyd at metadata)
+
+ ##
+ ## check.node.labels
+ ##
+
+ # case 0: no node labels
+ tr$node.label <- NULL
+ phyd <- phylo4d(tr)
+ expect_true(!hasNodeLabels(phyd))
+
+ # case 1: convert character labels as data
+ tr$node.label <- paste("n", 1:4, sep="")
+ phyd <- phylo4d(tr, check.node.labels="asdata")
+ expect_true(!hasNodeLabels(phyd))
+ expect_equal(tdata(phyd, "internal")$labelValues, as.factor(tr$node.label))
+
+ # case 2: convert number-like characters labels to numeric data
+ tr$node.label <- as.character(1:4)
+ phyd <- phylo4d(tr, check.node.labels="asdata")
+ expect_true(!hasNodeLabels(phyd))
+ expect_equal(tdata(phyd, "internal")$labelValues,
+ as.numeric(tr$node.label))
+
+ # case 3: convert numeric labels to numeric data
+ tr$node.label <- as.numeric(1:4)
+ phyd <- phylo4d(tr, check.node.labels="asdata")
+ expect_true(!hasNodeLabels(phyd))
+ expect_equal(tdata(phyd, "internal")$labelValues, tr$node.label)
+
+ # case 4: non-unique labels can be converted to data
+ tr$node.label <- rep(99, 4)
+ phyd <- phylo4d(tr)
+ expect_equal(unname(nodeLabels(phyd)), as.character(tr$node.label))
+ phyd <- phylo4d(tr, check.node.labels="asdata")
+ expect_true(!hasNodeLabels(phyd))
+ expect_equal(tdata(phyd, "internal", label.type="column")$labelValues, tr$node.label)
+})
+
+## phylo4d->phylo4d is currently unallowed
+
+test_that("phylo4d to phylo4d throws error", {
+ phyd <- phylo4d(phy)
+ expect_error(phylo4d(phyd))
+})
+
More information about the Phylobase-commits
mailing list