[Phylobase-commits] r765 - in pkg: . R inst/unitTests man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 25 22:33:47 CET 2010
Author: francois
Date: 2010-03-25 22:33:47 +0100 (Thu, 25 Mar 2010)
New Revision: 765
Added:
pkg/man/phylo4d-dimData.Rd
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/class-phylo4d.R
pkg/R/formatData.R
pkg/R/methods-phylo4d.R
pkg/R/phylo4.R
pkg/R/phylobase.options.R
pkg/R/treewalk.R
pkg/R/zzz.R
pkg/inst/unitTests/runit.checkdata.R
pkg/inst/unitTests/runit.class-phylo4.R
pkg/inst/unitTests/runit.class-phylo4d.R
pkg/inst/unitTests/runit.formatData.R
pkg/inst/unitTests/runit.methods-phylo4.R
pkg/inst/unitTests/runit.methods-phylo4d.R
pkg/inst/unitTests/runit.phylobase.options.R
pkg/inst/unitTests/runit.readNexus.R
pkg/man/tdata.Rd
Log:
New:
* introduce non-unique labels are allowed (with warning for now).
* introduce label matching in formatData() in case of non-unique labels
* introduce nData() to retrieve the number of datasets associated with a phylo4d object
Modifications:
* phylobase.options() are now always global
* in formatData() changed the way the labels are matched to reflect changes in getNode()
* with option: check.node.labels="asdata", number-like numbers are converted as numeric or left as character otherwise
* changed default options in phylobase.options(): polytomies are allowed, objects with non-unique labels return warning
* getNode() now matches labels using regular expression instead of match to work with multiple labels
Bug fixed:
* fix bug: In formatData(), if column that contains labels is indicated by its name, it's now removed from final dataset without error
* fix bug: In formatData(), if column that contains labels is indicated by its name, get error message if this name is not found in the data provided
New unit tests:
*
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/DESCRIPTION 2010-03-25 21:33:47 UTC (rev 765)
@@ -1,8 +1,8 @@
Package: phylobase
Type: Package
Title: Base package for phylogenetic structures and comparative data
-Version: 0.5
-Date: 2009-10-30
+Version: 0.5.8
+Date: 2010-03-25
Depends: methods, grid, ape(>= 2.1), Rcpp (>= 0.7.4)
Suggests: ade4, MASS
Author: R Hackathon et al. (alphabetically: Ben Bolker, Marguerite Butler, Peter Cowan, Damien de Vienne, Thibaut Jombart, Steve Kembel, Francois Michonneau, David Orme, Brian O'Meara, Emmanuel Paradis, Jim Regetz, Derrick Zwickl)
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/NAMESPACE 2010-03-25 21:33:47 UTC (rev 765)
@@ -37,7 +37,7 @@
# tree data methods
exportMethods(tdata, "tdata<-", tipData, "tipData<-", nodeData,
- "nodeData<-", hasTipData, hasNodeData, addData)
+ "nodeData<-", hasTipData, hasNodeData, addData, nData)
# subset methods
exportMethods(subset, prune, "[")
@@ -48,7 +48,7 @@
# label methods
exportMethods(labels, "labels<-", nodeLabels, "nodeLabels<-",
tipLabels, "tipLabels<-", edgeLabels, "edgeLabels<-",
- hasNodeLabels, hasEdgeLabels)
+ hasNodeLabels, hasEdgeLabels, hasDuplicatedLabels)
#----------------------------------------------------------------------
Modified: pkg/R/class-phylo4d.R
===================================================================
--- pkg/R/class-phylo4d.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/class-phylo4d.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -134,7 +134,14 @@
x$node.label <- NULL
nlab.data[!nzchar(nlab.data)] <- NA
- nlab.data <- data.frame(labelValues=as.numeric(nlab.data))
+ ## convert number-like labels to numeric, other keep as it is
+ nlab.data.test <- gsub("[0-9]|\\.", "", nlab.data[!is.na(nlab.data)])
+ if (all(nchar(nlab.data.test) == 0 )) {
+ nlab.data <- data.frame(labelValues=as.numeric(nlab.data))
+ }
+ else {
+ nlab.data <- data.frame(labelValues=nlab.data)
+ }
tree <- phylo4(x, check.node.labels="drop", annote=annote)
res <- phylo4d(tree, tip.data=tip.data, node.data=node.data,
Modified: pkg/R/formatData.R
===================================================================
--- pkg/R/formatData.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/formatData.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -31,9 +31,16 @@
if (any(dim(dt)==0)) {
return(data.frame(row.names=ids.out))
}
-
+
label.type <- match.arg(label.type)
- stopifnot(label.column %in% 1:ncol(dt))
+ ## Make sure the column specified for the labels is appropriate
+ if (label.type == "column") {
+ if (is.numeric(label.column))
+ stopifnot(label.column %in% 1:ncol(dt))
+ else
+ stopifnot(label.column %in% names(dt))
+ }
+
missing.data <- match.arg(missing.data)
extra.data <- match.arg(extra.data)
@@ -42,18 +49,23 @@
ndNames <- switch(label.type,
rownames = rownames(dt),
column = dt[,label.column])
- ## either force matching on labels, or match on node
- ## numbers for any number-like elements and labels otherwise
if (rownamesAsLabels) {
- ids.in <- getNode(phy, as.character(ndNames), missing="OK")
- } else {
- ids.in <- as.numeric(rep(NA, length(ndNames)))
- treatAsNumber <- nchar(gsub("[0-9]", "", ndNames))==0
- ids.in[treatAsNumber] <- getNode(phy,
- as.integer(ndNames[treatAsNumber]), missing="OK")
- ids.in[!treatAsNumber] <- getNode(phy,
- as.character(ndNames[!treatAsNumber]), missing="OK")
+ ids.in <- lapply(ndNames, function(ndnm) {
+ getNode(phy, as.character(ndnm), missing="OK")
+ })
}
+ else {
+ ids.in <- lapply(ndNames, function(ndnm) {
+ if (nchar(gsub("[0-9]", "", ndnm)) == 0) {
+ getNode(phy, as.integer(ndnm), missing="OK")
+ }
+ else {
+ getNode(phy, as.character(ndnm), missing="OK")
+ }
+ })
+ }
+ ids.list <- ids.in
+ ids.in <- unlist(ids.in)
## Make sure that data are matched to appropriate nodes
if (type=="tip" && any(na.omit(ids.in) %in% nodeId(phy,
@@ -69,7 +81,7 @@
"are correct.")
}
- ## Check differences
+ ## Check differences between tree and data
mssng <- setdiff(nodeId(phy, type), ids.in)
if(length(mssng) > 0 && missing.data != "OK") {
## provide label if it exists and node number otherwise
@@ -89,15 +101,31 @@
warn = warning(msg),
fail = stop(msg))
}
+
## Format data to have correct dimensions
+ ids.list <- ids.list[!is.na(ids.list)]
dt <- dt[!is.na(ids.in), , drop=FALSE]
+ if (hasDuplicatedLabels(phy)) {
+ dtTmp <- array(, dim=c(length(ids.in[!is.na(ids.in)]), ncol(dt)),
+ dimnames=list(ids.in[!is.na(ids.in)], names(dt)))
+ dtTmp <- data.frame(dtTmp)
+ j <- 1
+ for (i in 1:length(ids.list)) {
+ for (k in 1:length(ids.list[[i]])) {
+ dtTmp[j, ] <- dt[i, , drop=FALSE]
+ j <- j + 1
+ }
+ }
+ dt <- dtTmp
+ }
rownames(dt) <- ids.in[!is.na(ids.in)]
dt.out <- dt[match(ids.out, rownames(dt)), , drop=FALSE]
rownames(dt.out) <- ids.out
- if(label.type == "column") dt.out <- dt.out[, -label.column, drop=FALSE]
+ if(label.type == "column") {
+ dt.out <- subset(dt.out, select=-eval(parse(text=label.column)))
+ }
} else {
-
## Check if too many or not enough rows in input data
expected.nrow <- length(nodeId(phy, type))
diffNr <- nrow(dt) - expected.nrow
Modified: pkg/R/methods-phylo4d.R
===================================================================
--- pkg/R/methods-phylo4d.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/methods-phylo4d.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -153,6 +153,11 @@
merge.data=merge.data, ...)
})
+### Get dimensions of the data
+setMethod("nData", signature(x="phylo4d"), function(x, ...) {
+ ncol(x at data)
+})
+
## Alternative phylo4d summary method, using phylo4 summary
## Marguerite Butler & Peter Cowan
setMethod("summary", signature(object="phylo4d"),
Modified: pkg/R/phylo4.R
===================================================================
--- pkg/R/phylo4.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/phylo4.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -185,16 +185,11 @@
standardGeneric("addData")
})
-## dimData
-## setGeneric("dimData", function(x, ...) {
-## standardGeneric("dimData")
-## })
+## nData
+setGeneric("nData", function(x, ...) {
+ standardGeneric("nData")
+})
-## ## ncolData
-## setGeneric("ncolData", function(x, ...) {
-## standardGeneric("ncolData")
-## })
-
## hasTipData
setGeneric("hasTipData", function(x) {
standardGeneric("hasTipData")
Modified: pkg/R/phylobase.options.R
===================================================================
--- pkg/R/phylobase.options.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/phylobase.options.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -21,7 +21,8 @@
current <- lapply(current, function(foo) {
foo <- match.arg(foo, c("warn", "fail", "ok"))
})
- if (sys.parent() == 0) env <- asNamespace("phylobase") else env <- parent.frame()
+ ## options are always global
+ env <- asNamespace("phylobase")
assign(".phylobase.Options", current, envir = env)
invisible(current)
}
Modified: pkg/R/treewalk.R
===================================================================
--- pkg/R/treewalk.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/treewalk.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -1,4 +1,3 @@
-
## matching node labels with node numbers ...
## e.g.
## 14 tips, 13 int nodes
@@ -20,7 +19,9 @@
## match node to tree
if (is.character(node)) {
- irval <- match(node, labels(x, type))
+ ndTmp <- paste("^", node, "$", sep="")
+ irval <- lapply(ndTmp, function(ND) grep(ND, labels(x, type)))
+ irval <- unlist(irval)
} else if (is.numeric(node) && all(floor(node) == node, na.rm=TRUE)) {
irval <- match(as.character(node), names(labels(x, type)))
} else {
@@ -293,7 +294,7 @@
## hack to return NA for tip nodes when type='ancestor'
if(length(res)==0) res <- NA
names(res) <- rep(nid, length(res))
- }
+ }
names(res) <- rep(nid, length(res))
res
})
Modified: pkg/R/zzz.R
===================================================================
--- pkg/R/zzz.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/R/zzz.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -8,8 +8,8 @@
list(retic = "warn",
singleton = "warn",
multiroot = "warn",
- poly = "warn",
- allow.duplicated.labels = "fail")
+ poly = "ok",
+ allow.duplicated.labels = "warn")
# use this with a namespace
.onLoad <- function(lib, pkg) {
Modified: pkg/inst/unitTests/runit.checkdata.R
===================================================================
--- pkg/inst/unitTests/runit.checkdata.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.checkdata.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -1,12 +1,59 @@
#
# --- Test checkdata.R ---
#
-
+
+if (Sys.getenv("RCMDCHECK") == FALSE) {
+ pth <- file.path(getwd(), "..", "inst", "nexusfiles")
+} else {
+ pth <- system.file(package="phylobase", "nexusfiles")
+}
+## co1.nex -- typical output from MrBayes. Contains 2 identical trees, the first
+## one having posterior probabilities as node labels
+co1File <- file.path(pth, "co1.nex")
+
+# 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)
+
+op <- phylobase.options()
+
checkPhylo4 <- function() {
}
checkTree <- function() {
- # function(object,warn="retic",err=NULL)
+ ## test polytomies
+ phylobase.options(poly="fail")
+ checkException(readNexus(file=co1File, check.node.labels="drop"))
+ phylobase.options(op)
+
+ ## test retic
+ phylobase.options(retic="fail")
+ edgeRetic <- rbind(edge, c(6, 3))
+ checkException(phy <- phylo4(x=edgeRetic))
+ phylobase.options(op)
+
+ ## test multiroot
+ phylobase.options(multiroot="fail")
+ edgeMultiRoot <- rbind(edge, c(7, 0))
+ checkException(phy <- phylo4(x=edgeMultiRoot))
+ phylobase.options(op)
+
+ ## test singleton
+ phylobase.options(singleton="fail")
+ edgeSingleton <- cbind(c(9,7,7,6,6,8,8,10,10,0), 1:10)
+ checkException(phylo4(x=edgeSingleton))
+ phylobase.options(op)
}
checkPhylo4Data <- function() {
Modified: pkg/inst/unitTests/runit.class-phylo4.R
===================================================================
--- pkg/inst/unitTests/runit.class-phylo4.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.class-phylo4.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -2,13 +2,15 @@
# --- Test class-phylo4.R ---
#
+op <- phylobase.options()
+
test.phylo4.matrix <- function() {
edge <- structure(c(6L, 7L, 8L, 8L, 9L, 9L, 7L, 6L, 7L, 8L, 1L, 9L,
2L, 3L, 4L, 5L), .Dim = c(8, 2))
edge.length <- c(0.2, 0.5, 0.2, 0.15, 0.1, 0.1, 0.7, 1)
tip.label <- paste("t", 1:5, sep="")
node.label <- paste("n", 1:4, sep="")
- edge.label <- paste("e", 1:8, sep="")
+ edge.label <- paste("e", 1:8, sep="")
order="preorder"
annote <- list(x="annotation")
phy <- phylo4(edge, edge.length=edge.length, tip.label=tip.label,
@@ -34,12 +36,14 @@
checkException(phylo4(edge, annote="invalid annotation"))
}
+
# note: this method mostly just wraps phylo->phylo4 coercion, which is
# tested more thoroughly in runit.setAs-methods.R; focus here is on
# annote and check.node.labels arguments
test.phylo4.phylo <- function() {
tr <- read.tree(text="(((t1:0.2,(t2:0.1,t3:0.1):0.15):0.5,t4:0.7):0.2,t5:1):0.4;")
+
##
## annote
##
@@ -75,10 +79,21 @@
# case 4: must drop non-unique labels
tr$node.label <- rep("x", 4)
+ ## with options allow.duplicated.labels="fail"
+ phylobase.options(allow.duplicated.labels="fail")
checkException(phylo4(tr))
checkException(phylo4(tr, check.node.labels="keep"))
- # test dropping node labels
+ phylobase.options(op)
+ ## test dropping node labels
phy <- phylo4(tr, check.node.labels="drop")
checkTrue(!hasNodeLabels(phy))
-
+ ## with options allow.duplicated.labels="ok"
+ phylobase.options(allow.duplicated.labels="ok")
+ phy <- phylo4(tr)
+ checkIdentical(unname(nodeLabels(phy)), tr$node.label)
+ phy <- phylo4(tr, check.node.labels="keep")
+ checkIdentical(unname(nodeLabels(phy)), tr$node.label)
+ phy <- phylo4(tr, check.node.labels="drop")
+ checkTrue(!hasNodeLabels(phy))
+ phylobase.options(op)
}
Modified: pkg/inst/unitTests/runit.class-phylo4d.R
===================================================================
--- pkg/inst/unitTests/runit.class-phylo4d.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.class-phylo4d.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -44,7 +44,7 @@
row.names(nodDt) <- nid.int.r
#-----------------------------------------------------------------------
-
+
test.phylo4d.phylo4 <- function() {
## case 1: add data matching only on row position
@@ -254,22 +254,18 @@
phyd <- phylo4d(tr)
checkTrue(!hasNodeLabels(phyd))
- # case 1: can't currently keep arbitrary character labels as data
+ # 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))
- checkTrue(all(is.na(tdata(phyd, "internal")$labelValues)))
- # the above should've produced a warning:
- opt <- options(warn=3)
- checkException(phylo4d(tr, check.node.labels="asdata"))
- options(opt)
+ 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))
+ as.numeric(tr$node.label))
# case 3: convert numeric labels to numeric data
tr$node.label <- as.numeric(1:4)
@@ -279,11 +275,11 @@
# case 4: non-unique labels can be converted to data
tr$node.label <- rep(99, 4)
- checkException(phylo4d(tr))
+ 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")$labelValues, tr$node.label)
-
+ checkIdentical(tdata(phyd, "internal", label.type="column")$labelValues, tr$node.label)
}
## phylo4d->phylo4d is currently unallowed
Modified: pkg/inst/unitTests/runit.formatData.R
===================================================================
--- pkg/inst/unitTests/runit.formatData.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.formatData.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -67,6 +67,20 @@
## error if dt is, say, a phylo4 object
checkException(formatData(phy.alt, phy.alt))
+ ## error if column number is out of range
+ checkException(formatData(phy.alt, data.frame(a=1:5,
+ lab=rev(nid.tip)), type="tip", match.data=FALSE,
+ label.type="column", label.column=3),
+ data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA,
+ 4)), row.names=nid.all))
+ ## error if column name is wrong
+ checkException(formatData(phy.alt, data.frame(a=1:5,
+ lab=rev(nid.tip)), type="tip", match.data=FALSE,
+ label.type="column", label.column="foo"),
+ data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA,
+ 4)), row.names=nid.all))
+
+
#
# matching options
#
@@ -120,6 +134,10 @@
lab=rev(lab.tip)), type="tip", match.data=TRUE,
label.type="column", label.column=2),
data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all))
+ checkIdentical(formatData(phy.alt, data.frame(a=1:5,
+ lab=rev(lab.tip)), type="tip", match.data=TRUE,
+ label.type="column", label.column="lab"),
+ data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all))
## match on label column (mixed node numbers and labels)
checkIdentical(formatData(phy.alt, data.frame(a=1:5,
lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip",
@@ -236,3 +254,208 @@
data.frame(a=c(6:9), row.names=nid.int))
}
+
+test.formatDataWithDup <- function() {
+
+ print(sys.parent())
+ print(parent.frame())
+ ## Saving default options
+ op <- phylobase.options()
+
+ ## Changing default options
+ phylobase.options(allow.duplicated.labels="ok")
+
+ ## Creating phylo4 object with duplicated labels
+ phy.dup <- phy.alt
+ tipLabels(phy.dup)[2] <- tipLabels(phy.dup)[1]
+
+ ## vector data coerced to data.frame (colname dt)
+ checkIdentical(formatData(phy.dup, 1:5),
+ formatData(phy.dup, data.frame(dt=1:5)))
+ ## list of vector data coerced to data.frame (colnames as given)
+ checkIdentical(formatData(phy.dup, list(a=1:5, b=6:10)),
+ formatData(phy.dup, data.frame(a=1:5, b=6:10)))
+ ## factor data coerced to data.frame (colname dt)
+ checkIdentical(formatData(phy.dup, factor(letters[1:5])),
+ formatData(phy.dup, data.frame(dt=letters[1:5])))
+ ## matrix data coerced to data.frame (colnames V1, V2)
+ checkIdentical(formatData(phy.dup, matrix(1:10, ncol=2)),
+ formatData(phy.dup, data.frame(V1=1:5, V2=6:10)))
+ ## matrix data coerced to data.frame (colname as given)
+ checkIdentical(formatData(phy.dup, matrix(1:10, ncol=2,
+ dimnames=list(NULL, c("a", "b")))),
+ formatData(phy.dup, data.frame(a=1:5, b=6:10)))
+ ## error if dt is, say, a phylo4 object
+ checkException(formatData(phy.dup, phy.dup))
+
+ #
+ # matching options
+ #
+
+ ## don't match (purely positional)
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ row.names=rev(nid.tip)), type="tip", match.data=FALSE),
+ data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all))
+ ## match on rownames (node numbers)
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ row.names=rev(nid.tip)), type="tip", match.data=TRUE),
+ data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all))
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ row.names=rev(nid.tip)), type="tip"), data.frame(a=c(5:1,
+ rep(NA, 4)), row.names=nid.all))
+ ## match on rownames (labels)
+ checkIdentical(formatData(phy.dup, data.frame(a=c(1,3,4,5),
+ row.names=rev(lab.tip[-2])), type="tip", match.data=TRUE),
+ data.frame(a=c(5,5,4,3,1, rep(NA, 4)), row.names=nid.all))
+ ## match on rownames (mixed node numbers and labels)
+ checkIdentical(formatData(phy.dup, data.frame(a=c(1,2,3,4,5),
+ row.names=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])),
+ type="tip", match.data=TRUE),
+ data.frame(a=c(5,4,3,2,1, rep(NA, 4)), row.names=nid.all))
+ ## but fails if rownamesAsLabels is TRUE
+ checkException(formatData(phy.dup, data.frame(a=1:5,
+ row.names=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])),
+ type="tip", match.data=TRUE, rownamesAsLabels=TRUE))
+
+ #
+ # label.type="column" and label.column=2
+ #
+
+ ## should ignore label (purely positional) and retain a label col
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ lab=rev(nid.tip)), type="tip", match.data=FALSE,
+ label.type="column", label.column=2),
+ data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA,
+ 4)), row.names=nid.all))
+ ## match on label column (node numbers)
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ lab=rev(nid.tip)), type="tip", match.data=TRUE,
+ label.type="column", label.column=2),
+ data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all))
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ lab=rev(nid.tip)), type="tip",
+ label.type="column", label.column=2),
+ data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all))
+ ## match on label column (labels)
+ checkIdentical(formatData(phy.dup, data.frame(a=1:4,
+ lab=rev(lab.tip[-2])), type="tip", match.data=TRUE,
+ label.type="column", label.column=2),
+ data.frame(a=as.integer(c(4, 4:1, rep(NA, 4))), row.names=nid.all))
+ ## match on label column (mixed node numbers and labels)
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip",
+ match.data=TRUE, label.type="column", label.column=2),
+ data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all))
+ ## but fails if rownamesAsLabels is TRUE
+ checkException(formatData(phy.dup, data.frame(a=1:5,
+ lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])),
+ type="tip", match.data=TRUE, rownamesAsLabels=TRUE,
+ label.type="column", label.column=2))
+
+ ## try to match internal nodes when type='tips'
+ checkException(formatData(phy.dup, data.frame(a=1:5, row.names=4:8),
+ type="tip"))
+ ## and vice versa
+ checkException(formatData(phy.dup, data.frame(a=6:9, row.names=1:4),
+ type="internal"))
+
+ #
+ # missing.data
+ #
+
+ ## force error conditions
+ checkException(formatData(phy.dup, data.frame(a=1:3), type="tip"))
+ checkException(formatData(phy.dup, data.frame(a=1:3), type="tip",
+ missing.data="fail"))
+ options(warn=3)
+ checkException(formatData(phy.dup, data.frame(a=1:3), type="tip",
+ missing.data="warn"))
+ options(warn=0)
+ ## missing data with matching
+ checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.tip)[-1],
+ row.names=rev(nid.tip)[-1]), type="tip", missing.data="OK"),
+ data.frame(a=c(nid.tip[-5], rep(NA, 5))))
+ checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.int)[-1],
+ row.names=rev(nid.int)[-1]), type="internal", missing.data="OK"),
+ data.frame(a=c(rep(NA, 5), nid.int[-4], NA)))
+ checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.all)[-1],
+ row.names=rev(nid.all)[-1]), type="all", missing.data="OK"),
+ data.frame(a=c(nid.all[-9], NA)))
+ ## missing data without matching
+ checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.tip)[-1]),
+ type="tip", match.data=FALSE, missing.data="OK"),
+ data.frame(a=c(rev(nid.tip)[-1], rep(NA, 5))))
+ checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.int)[-1]),
+ type="internal", match.data=FALSE, missing.data="OK"),
+ data.frame(a=c(rep(NA, 5), rev(nid.int)[-1], NA)))
+ checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.all)[-1]),
+ type="all", match.data=FALSE, missing.data="OK"),
+ data.frame(a=c(rev(nid.all)[-1], NA)))
+
+ #
+ # extra.data
+ #
+
+ ## force error conditions
+ checkException(formatData(phy.dup, data.frame(a=1:3), type="tip",
+ missing.data="fail"))
+ options(warn=3)
+ checkException(formatData(phy.dup, data.frame(a=0:5, row.names=0:5),
+ type="tip", missing="warn"))
+ checkException(formatData(phy.dup, data.frame(a=0:5, row.names=0:5),
+ type="tip"))
+ options(warn=0)
+ ## extra data with matching
+ checkIdentical(formatData(phy.dup, data.frame(a=c(0L, rev(nid.tip)),
+ row.names=c(0, rev(nid.tip))), type="tip", extra.data="OK"),
+ data.frame(a=c(nid.tip, rep(NA, 4))))
+ checkIdentical(formatData(phy.dup, data.frame(a=c(0L, rev(nid.int)),
+ row.names=c(0, rev(nid.int))), type="internal", extra.data="OK"),
+ data.frame(a=c(rep(NA, 5), nid.int)))
+ checkIdentical(formatData(phy.dup, data.frame(a=c(0L, rev(nid.all)),
+ row.names=c(0, rev(nid.all))), type="all", extra.data="OK"),
+ data.frame(a=nid.all))
+ ## extra data without matching
+ checkIdentical(formatData(phy.dup, data.frame(a=1:15),
+ type="tip", match.data=FALSE, extra.data="OK"),
+ data.frame(a=c(1:5, rep(NA, 4))))
+ checkIdentical(formatData(phy.dup, data.frame(a=1:15),
+ type="internal", match.data=FALSE, extra.data="OK"),
+ data.frame(a=c(rep(NA, 5), 1:4)))
+ checkIdentical(formatData(phy.dup, data.frame(a=1:15),
+ type="all", match.data=FALSE, extra.data="OK"),
+ data.frame(a=c(1:9)))
+
+ ## allow both extra.data and missing.data
+ checkIdentical(formatData(phy.dup, data.frame(a=0:3, row.names=0:3),
+ type="tip", extra.data="OK", missing.data="OK"),
+ data.frame(a=c(1:3, rep(NA, 6))))
+
+ #
+ # keep.all
+ #
+
+ ## keep all rows
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ row.names=nid.tip), type="tip", keep.all=TRUE),
+ data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all))
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ row.names=nid.tip), type="tip"),
+ data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all))
+ checkIdentical(formatData(phy.dup, data.frame(a=6:9,
+ row.names=nid.int), type="internal", keep.all=TRUE),
+ data.frame(a=c(rep(NA, 5), 6:9), row.names=nid.all))
+ checkIdentical(formatData(phy.dup, data.frame(a=6:9,
+ row.names=nid.int), type="internal"),
+ data.frame(a=c(rep(NA, 5), 6:9), row.names=nid.all))
+ ## only keep 'type' rows
+ checkIdentical(formatData(phy.dup, data.frame(a=1:5,
+ row.names=nid.tip), type="tip", keep.all=FALSE),
+ data.frame(a=c(1:5), row.names=nid.tip))
+ checkIdentical(formatData(phy.dup, data.frame(a=6:9,
+ row.names=nid.int), type="internal", keep.all=FALSE),
+ data.frame(a=c(6:9), row.names=nid.int))
+
+ ## restoring default options
+ phylobase.options(op)
+}
Modified: pkg/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.methods-phylo4.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -1,7 +1,7 @@
#
# --- 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)
@@ -38,6 +38,7 @@
elen <- elen[c(6:9, 1:5)]
elab <- elab[c(6:9, 1:5)]
+op <- phylobase.options()
#-----------------------------------------------------------------------
test.nTips.phylo4 <- function() {
@@ -248,8 +249,15 @@
labels(phy.alt)["9"] <- "n9"
checkIdentical(labels(phy.alt), setNames(lab.all, nid.all))
# error to produce duplicate tip or internal label
+ phylobase.options(allow.duplicated.labels="fail")
checkException(labels(phy.alt)[1] <- "t2")
checkException(labels(phy.alt)[6] <- "n7")
+ # no error in allow.duplicated.labels is ok
+ phylobase.options(allow.duplicated.labels="ok")
+ labels(phy.alt)[1] <- "t2"
+ labels(phy.alt)[6] <- "n7"
+ checkIdentical(tipLabels(phy.alt), setNames(c("t2", "t2", "t3", "t4", "t5"), nid.tip))
+ checkIdentical(nodeLabels(phy.alt), setNames(c("n7", "n7", "n8", "n9"), nid.int))
# error to add labels for nodes that don't exist
checkException(labels(phy.alt)["fake"] <- "xxx")
checkException(labels(phy.alt)[999] <- "xxx")
@@ -285,7 +293,13 @@
nodeLabels(phy.alt)["9"] <- "n9"
checkIdentical(labels(phy.alt), setNames(lab.all, nid.all))
# error to produce duplicate internal label
+ phylobase.options(allow.duplicated.labels="fail")
checkException(nodeLabels(phy.alt)["6"] <- "n7")
+ phylobase.options(op)
+ phylobase.options(allow.duplicated.labels="ok")
+ nodeLabels(phy.alt)["6"] <- "n7"
+ checkIdentical(nodeLabels(phy.alt), setNames(c("n7", "n7", "n8", "n9"), nid.int))
+ phylobase.options(op)
# error to add labels for nodes that don't exist
checkException(nodeLabels(phy.alt)["fake"] <- "xxx")
checkException(nodeLabels(phy.alt)[999] <- "xxx")
@@ -313,7 +327,13 @@
tipLabels(phy.alt)["5"] <- "t5"
checkIdentical(labels(phy.alt), setNames(lab.all, nid.all))
# error to produce duplicate tip or internal label
+ phylobase.options(allow.duplicated.labels="fail")
checkException(tipLabels(phy.alt)[1] <- "t2")
+ phylobase.options(op)
+ phylobase.options(allow.duplicated.labels="ok")
+ tipLabels(phy.alt)[1] <- "t2"
+ checkIdentical(tipLabels(phy.alt), setNames(c("t2", "t2", "t3", "t4", "t5"), nid.tip))
+ phylobase.options(op)
# error to add labels for nodes that don't exist
checkException(tipLabels(phy.alt)["fake"] <- "xxx")
checkException(tipLabels(phy.alt)[999] <- "xxx")
@@ -427,4 +447,4 @@
#TODO
}
-
+phylobase.options(op)
Modified: pkg/inst/unitTests/runit.methods-phylo4d.R
===================================================================
--- pkg/inst/unitTests/runit.methods-phylo4d.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.methods-phylo4d.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -161,6 +161,11 @@
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, ...)
Modified: pkg/inst/unitTests/runit.phylobase.options.R
===================================================================
--- pkg/inst/unitTests/runit.phylobase.options.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.phylobase.options.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -1,4 +1,8 @@
+###
+### phylobase.options
+###
+
op <- phylobase.options()
test.phylobase.options <- function() {
@@ -6,17 +10,15 @@
checkException(phylobase.options(retic="test"))
no <- phylobase.options(retic="f")
checkIdentical(no$retic, "fail")
+ phylobase.options(op)
## test multiple args
- phylobase.options(op)
no <- phylobase.options(retic="f", poly="f")
checkIdentical(no$retic, "fail")
checkIdentical(no$poly, "fail")
+ phylobase.options(op)
## check some failures
checkException(phylobase.options(1))
checkException(phylobase.options("foobar"="foo"))
-
}
-
-phylobase.options(op)
Modified: pkg/inst/unitTests/runit.readNexus.R
===================================================================
--- pkg/inst/unitTests/runit.readNexus.R 2010-03-23 18:30:03 UTC (rev 764)
+++ pkg/inst/unitTests/runit.readNexus.R 2010-03-25 21:33:47 UTC (rev 765)
@@ -45,6 +45,7 @@
stopifnot(file.exists(treeDiscCont))
stopifnot(file.exists(ExContDataFile))
+op <- phylobase.options()
test.readNexus <- function() {
## function (file, simplify=TRUE, type=c("all", "tree", "data"),
@@ -94,7 +95,14 @@
checkIdentical(as(co1, "data.frame")$labelValues, lVco1) # check label values
## Check option check.node.labels
+ phylobase.options(allow.duplicated.labels="fail")
checkException(readNexus(file=co1File, check.node.labels="keep")) # fail because labels aren't unique
+ phylobase.options(op)
+ phylobase.options(allow.duplicated.labels="ok")
+ co1 <- readNexus(file=co1File, check.node.labels="keep", simplify=TRUE)
+ checkIdentical(nodeLabels(co1), setNames(c(NA, "0.93", "0.88", "0.99", "1.00", "0.76", "1.00", "1.00"),
+ 11:18))
+ phylobase.options(op)
co1 <- readNexus(file=co1File, check.node.labels="drop", simplify=TRUE)
checkIdentical(labels(co1), labCo1) # check labels
checkIdentical(edgeLength(co1), eLco1) # check edge lengths
@@ -174,9 +182,6 @@
## Tree + Data
trDt1 <- readNexus(file=treeDiscDt, type="all", return.labels=FALSE,
levels.uniform=FALSE)
- str(trDt1)
- print(labels(trDt1))
- print(labTr)
checkIdentical(labels(trDt1), labTr) # check labels
checkIdentical(edgeLength(trDt1), eTr) # check edge lengths
checkIdentical(nodeType(trDt1), nTtr) # check node types
Added: pkg/man/phylo4d-dimData.Rd
===================================================================
--- pkg/man/phylo4d-dimData.Rd (rev 0)
+++ pkg/man/phylo4d-dimData.Rd 2010-03-25 21:33:47 UTC (rev 765)
@@ -0,0 +1,37 @@
+\name{nData}
+\alias{nData}
+\alias{nData,phylo4d-method}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 765
More information about the Phylobase-commits
mailing list