[Phylobase-commits] r666 - in branches/slot-mods: R data inst/unitTests man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Sep 26 01:35:56 CEST 2009
Author: regetz
Date: 2009-09-26 01:35:55 +0200 (Sat, 26 Sep 2009)
New Revision: 666
Modified:
branches/slot-mods/R/checkdata.R
branches/slot-mods/R/class-phylo4d.R
branches/slot-mods/R/formatData.R
branches/slot-mods/R/methods-phylo4d.R
branches/slot-mods/R/prune.R
branches/slot-mods/R/setAs-Methods.R
branches/slot-mods/R/subset.R
branches/slot-mods/R/tbind.R
branches/slot-mods/R/treePlot.R
branches/slot-mods/data/geospiza.rda
branches/slot-mods/inst/unitTests/runit.class-phylo4d.R
branches/slot-mods/inst/unitTests/runit.methods-phylo4d.R
branches/slot-mods/inst/unitTests/runit.subset.R
branches/slot-mods/man/addData.Rd
branches/slot-mods/man/phylo4d-class.Rd
branches/slot-mods/man/phylo4d-hasData.Rd
branches/slot-mods/man/phylo4d.Rd
branches/slot-mods/tests/misctests.R
branches/slot-mods/tests/misctests.Rout.save
branches/slot-mods/tests/phylo4dtests.R
branches/slot-mods/tests/phylo4dtests.Rout.save
branches/slot-mods/tests/phylosubtest.R
Log:
Unified tip.data and node.data into a single slot. Updated class
definition, associated methods, documentation, tests, and geospiza.rda.
Fixed a few minor issues that cropped up as part of this modification.
Modified: branches/slot-mods/R/checkdata.R
===================================================================
--- branches/slot-mods/R/checkdata.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/checkdata.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -164,24 +164,23 @@
## These are just some basic tests to make sure that the user does not
## alter the object in a significant way
- ntips <- nTips(object)
- nnodes <- nNodes(object)
+# JR: I don't think this part is necessary. All that matters is that all
+# rows in the data have names corresponding to (valid) node numbers
+# ntips <- nTips(object)
+# nnodes <- nNodes(object)
+#
+# ## Check dimensions
+# if (nrow(object at tip.data) > 0 && nrow(object at tip.data) != ntips)
+# stop("The number of tip data does not match the number ",
+# "of tips in the tree")
+# if (nrow(object at node.data) > 0 && nrow(object at node.data) != nnodes)
+# stop("The number of node data does not match the number ",
+# "of internal nodes in the tree")
- ## Check dimensions
- if (nrow(object at tip.data) > 0 && nrow(object at tip.data) != ntips)
- stop("The number of tip data does not match the number ",
- "of tips in the tree")
- if (nrow(object at node.data) > 0 && nrow(object at node.data) != nnodes)
- stop("The number of node data does not match the number ",
- "of internal nodes in the tree")
-
## Check rownames
- if (nrow(object at tip.data) > 0 &&
- !all(rownames(object at tip.data) %in% nodeId(object, "tip")))
- stop("The row names of tip data do not match the tip numbers")
- if (nrow(object at node.data) > 0 &&
- !all(rownames(object at node.data) %in% nodeId(object, "internal")))
- stop("The row names of node data do not match the node numbers")
+ if (nrow(object at data) > 0 &&
+ !all(row.names(object at data) %in% nodeId(object, "all")))
+ stop("The row names of tree data do not match the node numbers")
return(TRUE)
}
Modified: branches/slot-mods/R/class-phylo4d.R
===================================================================
--- branches/slot-mods/R/class-phylo4d.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/class-phylo4d.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -2,12 +2,11 @@
## phylo4d class
## extend: phylo with data
setClass("phylo4d",
- representation(tip.data="data.frame",
- node.data="data.frame",
+ representation(data="data.frame",
metadata = "list"),
- prototype = list( tip.data = data.frame(NULL),
- node.data = data.frame(NULL),
+ prototype = list(
+ data = data.frame(NULL),
metadata = list()),
validity = checkPhylo4,
@@ -30,122 +29,59 @@
rownamesAsLabels=FALSE,
...) {
- ## Make sure that data provided are a data frame
- classData <- function(someData) {
- if(!is.null(someData)) {
- if(is.vector(someData))
- someData <- as.data.frame(someData)
- if(!is.data.frame(someData)) {
- nmSomeData <- substitute(someData)
- stop(paste(nmSomeData, "must be a vector or a data frame"))
- }
- someData
- }
- }
-
## Check validity of phylo4 object
if(is.character(checkval <- checkPhylo4(x))) stop(checkval)
- ## Check/Transform provided data to data.frame
- all.data <- classData(all.data)
- tip.data <- classData(tip.data)
- node.data <- classData(node.data)
+ ## apply formatData to ensure data have node number rownames and
+ ## correct dimensions
+ all.data <- formatData(phy=x, dt=all.data, type="all",
+ match.data=match.data, rownamesAsLabels=rownamesAsLabels, ...)
+ tip.data <- formatData(phy=x, dt=tip.data, type="tip",
+ match.data=match.data, rownamesAsLabels=rownamesAsLabels, ...)
+ node.data <- formatData(phy=x, dt=node.data, type="internal",
+ match.data=match.data, rownamesAsLabels=rownamesAsLabels, ...)
- is.empty <- function(x) { is.null(x) || all(dim(x)==0) }
+ # don't allow all.data columns of same name as tip.data or node.data
+ colnamesTipOrNode <- union(names(tip.data), names(node.data))
+ if (any(names(all.data) %in% colnamesTipOrNode)) {
+ stop("all.data column names must be distinct from ",
+ "tip.data and node.data column names")
+ }
- ## Replacing node labels by node numbers and formatting the data to make sure
- ## they have the correct dimensions
- if(!is.empty(all.data))
- all.data <- formatData(phy=x, dt=all.data, type="all",
- match.data=match.data,
- rownamesAsLabels=rownamesAsLabels, ...)
-
- if(!is.empty(tip.data))
- tip.data <- formatData(phy=x, dt=tip.data, type="tip",
- match.data=match.data,
- rownamesAsLabels=rownamesAsLabels, ...)
-
- if(!is.empty(node.data))
- node.data <- formatData(phy=x, dt=node.data, type="internal",
- match.data=match.data,
- rownamesAsLabels=rownamesAsLabels, ...)
-
- ## Merging dataset
- if(!is.empty(all.data)) {
- tmpData <- all.data
- if(!is.empty(tip.data)) {
- emptyNodeData <- array(, dim = c(nNodes(x), ncol(tip.data)),
- dimnames = list(nodeId(x, "internal"),
- colnames(tip.data)))
- tmpTipData <- rbind(tip.data, emptyNodeData)
-
- tmpTipData <- tmpTipData[match(rownames(all.data),
- rownames(tmpTipData)) ,,
- drop = FALSE]
- tmpData <- cbind(all.data, tmpTipData)
- }
- if(!is.empty(node.data)) {
- emptyTipData <- array(, dim = c(nTips(x), ncol(node.data)),
- dimnames = list(nodeId(x, "tip"),
- colnames(node.data)))
- tmpNodeData <- rbind(emptyTipData, node.data)
- tmpNodeData <- tmpNodeData[match(rownames(all.data),
- rownames(tmpNodeData)) ,,
- drop = FALSE]
- tmpData <- cbind(tmpData, tmpNodeData)
- }
-
- tip.data <- tmpData[rownames(tmpData) %in% nodeId(x, "tip") ,,
- drop = FALSE]
- node.data <- tmpData[rownames(tmpData) %in% nodeId(x, "internal") ,,
- drop = FALSE]
+ ## identify common columns to merge if merging, or rename otherwise
+ colnamesToMerge <- intersect(names(tip.data), names(node.data))
+ if (merge.data==FALSE) {
+ names(tip.data)[names(tip.data) %in% colnamesToMerge] <-
+ paste(colnamesToMerge, "tip", sep=".")
+ names(node.data)[names(node.data) %in% colnamesToMerge] <-
+ paste(colnamesToMerge, "node", sep=".")
+ colnamesToMerge <- NULL
}
+ ## now separate tip.only, node.only, and common columns
+ tip.only.data <- tip.data[setdiff(names(tip.data), names(node.data))]
+ node.only.data <- node.data[setdiff(names(node.data), names(tip.data))]
+ common.data <- rbind(tip.data[colnamesToMerge], node.data[colnamesToMerge])
- else {
- if(!is.empty(tip.data) && !is.empty(node.data)) {
- if(identical(colnames(tip.data), colnames(node.data)) && merge.data) {
- tmpAllData <- rbind(tip.data, node.data)
- tip.data <- tmpAllData[rownames(tmpAllData) %in%
- nodeId(x, "tip") ,, drop=FALSE]
- node.data <- tmpAllData[rownames(tmpAllData) %in%
- nodeId(x, "internal") ,, drop=FALSE]
- }
- else {
- emptyTipData <- array(, dim = c(nTips(x), ncol(node.data)),
- dimnames = list(nodeId(x, "tip"),
- colnames(node.data)))
- emptyNodeData <- array(, dim = c(nNodes(x), ncol(tip.data)),
- dimnames = list(nodeId(x, "internal"),
- colnames(tip.data)))
- tmpTipData <- rbind(tip.data, emptyNodeData)
- tmpNodeData <- rbind(emptyTipData, node.data)
- tmpNodeData <- tmpNodeData[rownames(tmpTipData) ,, drop=FALSE]
+ ## merge data common to tips and nodes
+ all.common.data <- merge(all.data, common.data, by=0, all=TRUE,
+ sort=FALSE)
+ ## merge data that apply only to tips or nodes
+ all.separate.data <- merge(tip.only.data, node.only.data, by=0,
+ all=TRUE, sort=FALSE)
+ ## merge everything together and clean up
+ complete.data <- merge(all.common.data, all.separate.data,
+ by="Row.names", all=TRUE, sort=FALSE)
+ row.names(complete.data) <- complete.data[["Row.names"]]
+ complete.data <- subset(complete.data, select=-Row.names)
- tmpData <- cbind(tmpTipData, tmpNodeData)
-
- if(match.data) {
- tip.data <- tmpData[rownames(tmpData) %in%
- nodeId(x, "tip") ,, drop=FALSE]
- node.data <- tmpData[rownames(tmpData) %in%
- nodeId(x, "internal") ,, drop=FALSE]
- }
- else {
- tip.data <- tmpData[1:nTips(x) ,, drop=FALSE]
- node.data <- tmpData[-(1:nTips(x)) ,, drop=FALSE]
- }
- }
- }
- else {
- ## at this point provide NULL data frame for empty arguments
- if(is.empty(tip.data)) tip.data <- data.frame(NULL)
- if(is.empty(node.data)) node.data <- data.frame(NULL)
-
- tip.data <- tip.data
- node.data <- node.data
- }
+ ## drop any rows that only contain NAs
+ if (ncol(complete.data)==0) {
+ return(data.frame())
+ } else {
+ empty.rows <- as.logical(rowSums(!is.na(complete.data)))
+ return(complete.data[empty.rows, , drop=FALSE])
}
- return(list(tip.data=tip.data, node.data=node.data))
}
@@ -156,17 +92,14 @@
match.data=TRUE, merge.data=TRUE, rownamesAsLabels=FALSE,
metadata = list(),
...) {
-
- ## prepare the data
- tmpData <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data,
+ ## coerce tree to phylo4d
+ res <- as(x, "phylo4d")
+ ## add any data
+ res at data <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data,
all.data=all.data, match.data=match.data,
merge.data=merge.data,
rownamesAsLabels=rownamesAsLabels, ...)
-
- ## coerce to phylo4d and add data/metadata
- res <- as(x, "phylo4d")
- res at tip.data <- tmpData$tip.data
- res at node.data <- tmpData$node.data
+ ## add any metadata
res at metadata <- metadata
return(res)
})
Modified: branches/slot-mods/R/formatData.R
===================================================================
--- branches/slot-mods/R/formatData.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/formatData.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -5,6 +5,25 @@
extra.data=c("warn", "OK", "fail")
) {
+ ## coerce vector data to data.frame
+ if (is.vector(dt)) {
+ dt <- as.data.frame(dt)
+ }
+ ## if null, return empty data frame with node numbers as row names
+ if (is.null(dt)) {
+ return(data.frame(row.names=nodeId(phy, type)))
+ }
+ ## before proceeding, make sure that data provided are a data frame
+ if (!is.data.frame(dt)) {
+ nmSomeData <- substitute(dt)
+ stop(paste(nmSomeData, "must be a vector or a data frame"))
+ }
+ ## if null or lacking rows or columns, return a placeholder data
+ ## frame with node numbers as row names
+ if (any(dim(dt)==0)) {
+ return(data.frame(row.names=nodeId(phy, type)))
+ }
+
type <- match.arg(type)
label.type <- match.arg(label.type)
stopifnot(label.column %in% 1:ncol(dt))
@@ -40,13 +59,13 @@
tip = {
## BMB: don't bother trying to match NAs
if(any(na.omit(names(ndDt)) %in% labels(phy, "internal")))
- stop("You are trying to match tip data to internal ",
+ stop("Your tip data are being matched to internal ",
"nodes. Make sure that your data identifiers ",
"are correct.")
},
internal = {
if(any(na.omit(names(ndDt)) %in% labels(phy, "tip")))
- stop("You are trying to match node data to tip ",
+ stop("Your node data are being matched to tip ",
"nodes. Make sure that your data identifiers ",
"are correct.")
})
Modified: branches/slot-mods/R/methods-phylo4d.R
===================================================================
--- branches/slot-mods/R/methods-phylo4d.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/methods-phylo4d.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -1,5 +1,5 @@
setMethod("tdata", signature(x="phylo4d"),
- function(x, type=c("tip", "internal", "allnode"),
+ function(x, type=c("tip", "internal", "all"),
label.type=c("row.names","column"),
empty.columns=TRUE, ...) {
@@ -10,112 +10,43 @@
type <- match.arg(type)
label.type <- match.arg(label.type)
- if (type == "tip") {
- if (all(dim(x at tip.data) == 0)) {
- return(x at tip.data)
- }
- tdata <- x at tip.data
- data.names <- tipLabels(x)[match(names(tipLabels(x)), rownames(tdata))]
- if ( label.type == "row.names" ) {
- if (!any(duplicated(data.names)) &&
- !any(is.na(data.names)) ) {
- row.names(tdata) <- data.names
- }
- else {
- warning("Non-unique or missing labels found, ",
- "labels cannot be coerced to tdata row.names. ",
- "Use the label.type argument to include labels ",
- "as first column of data.")
- }
- }
- if (identical(label.type,"column")) {
- tdata <- data.frame(label=data.names, tdata)
- }
- }
+ ids <- nodeId(x, type)
+ labs <- labels(x, type)
+ ## replace any missing labels with node numbers
+ labs[is.na(labs)] <- names(labs)[is.na(labs)]
- if (type == "internal") {
- if (all(dim(x at node.data)==0)) {
- return(x at node.data)
- }
- tdata <- x at node.data
- if(hasNodeLabels(x))
- data.names <- nodeLabels(x)[match(names(nodeLabels(x)), rownames(tdata))]
- else
- data.names <- nodeId(x, "internal")
+ tdata <- x at data[match(ids, row.names(x at data)), , drop=FALSE]
+ row.names(tdata) <- ids
+ data.names <- labs[match(names(labs), rownames(tdata))]
- if ( identical(label.type, "row.names") ) {
- if ( length(data.names) > 0 &&
- !any(duplicated(data.names)) &&
- !(any(is.na(data.names)))) {
- row.names(tdata) <- data.names
- }
- else {
- warning("Non-unique or missing labels found, ",
- "labels cannot be coerced to tdata row.names. ",
- "Use the label.type argument to include labels ",
- "as first column of data.")
- }
+ if (label.type == "row.names") {
+ if (!any(duplicated(data.names)) &&
+ ## length(data.names) > 0 &&
+ !any(is.na(data.names)) ) {
+ row.names(tdata) <- data.names
}
- if (identical(label.type,"column")) {
- tdata <- data.frame(label=data.names, tdata)
- }
- }
-
- if (type == "allnode") {
- ## node data
- if (all(dim(x at node.data) == 0)) { # empty data
- if (!hasNodeLabels(x)) {
- nodedata <- data.frame(label=nodeId(x, "internal"))
- }
- else
- nodedata <- data.frame(label=nodeLabels(x))
- }
else {
- nodedata <- tdata(x, "internal", label.type="column")
+ warning("Non-unique or missing labels found, ",
+ "labels cannot be coerced to tdata row.names. ",
+ "Use the label.type argument to include labels ",
+ "as first column of data.")
}
-
- ## tip data
- if (all(dim(x at tip.data) == 0)) {
- tipdata <- data.frame(label=tipLabels(x))
- }
- else {
- tipdata <- tdata(x, "tip", label.type="column")
- }
-
- ## following lines necessary to be able to use merge on data
- ## belonging to different classes (e.g. nodeId as numeric and
- ## labels as character)
- tipdata$label <- as.character(tipdata$label)
- nodedata$label <- as.character(nodedata$label)
-
- tdata <- merge(tipdata, nodedata, all=TRUE, sort=FALSE)[,, drop=FALSE]
-
- if (identical(label.type, "row.names")) {
- if (identical(tdata$label, unique(tdata$label)) ||
- !(any(is.na(tdata$label))) ) {
- row.names(tdata) <- tdata[,1]
- tdata <- data.frame(tdata[, -1, drop=FALSE])
- }
- else {
- stop("Non-unique or missing labels found, labels cannot be ",
- "coerced to tdata row.names. Use the label.type argument ",
- "to include labels as first column of data.")
- }
- }
-
}
+ if (identical(label.type,"column")) {
+ tdata <- data.frame(label=data.names, tdata)
+ }
## remove empty columns (filled with NAs)
if(!empty.columns) {
emptyCol <- apply(tdata, 2, function(x) all(is.na(x)))
- tdata <- tdata[, !emptyCol]
+ tdata <- tdata[, !emptyCol, drop=FALSE]
}
tdata
})
setReplaceMethod("tdata", signature(x="phylo4d", value="ANY"),
- function(x, type = c("tip", "internal", "allnode"), ..., value) {
+ function(x, type = c("tip", "internal", "all"), ..., value) {
type <- match.arg(type)
object <- x
@@ -123,16 +54,11 @@
object <- extractTree(object)
object <- as(object, "phylo4d")
- tmpData <- switch(type,
+ object at data <- switch(type,
tip = .phylo4Data(object, tip.data=value, ...),
internal = .phylo4Data(object, node.data=value, ...),
- allnode = .phylo4Data(object, all.data=value, ...))
+ all = .phylo4Data(object, all.data=value, ...))
- if(all(dim(tmpData$tip.data)))
- object at tip.data <- tmpData$tip.data
- if(all(dim(tmpData$node.data)))
- object at node.data <- tmpData$node.data
-
object
})
@@ -143,39 +69,26 @@
pos <- match.arg(pos)
- tmpData <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data,
- all.data=all.data, merge.data=merge.data,
- match.data=match.data, ...)
+ new.data <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data,
+ all.data=all.data, merge.data=merge.data, match.data=match.data, ...)
- if(identical(pos, "before")) {
- if(!all(dim(tmpData$tip.data) == 0)) {
- if(all(dim(x at tip.data) > 0))
- x at tip.data <- cbind(tmpData$tip.data, x at tip.data)
- else
- x at tip.data <- tmpData$tip.data
- }
- if(!all(dim(tmpData$node.data) == 0)) {
- if(all(dim(x at tip.data) > 0))
- x at node.data <- cbind(tmpData$node.data, x at node.data)
- else
- x at node.data <- tmpData$node.data
- }
+ if (all(dim(new.data) == 0)) {
+ return(x)
}
- else {
- if(!all(dim(tmpData$tip.data) == 0)) {
- if(all(dim(x at tip.data) > 0))
- x at tip.data <- cbind(x at tip.data, tmpData$tip.data)
- else
- x at tip.data <- tmpData$tip.data
- }
+ if (all(dim(x at data) == 0)) {
+ x at data <- new.data
+ return(x)
+ }
- if(!all(dim(tmpData$node.data) == 0)) {
- if(all(dim(x at node.data) > 0))
- x at node.data <- cbind(x at node.data, tmpData$node.data)
- else
- x at node.data <- tmpData$node.data
- }
+ if (identical(pos, "after")) {
+ new.data <- merge(x at data, new.data, by=0, all=TRUE,
+ sort=FALSE, suffixes=c(".old", ".new"))
+ } else {
+ new.data <- merge(new.data, x at data, by=0, all=TRUE,
+ sort=FALSE, suffixes=c(".new", ".old"))
}
+ row.names(new.data) <- new.data[["Row.names"]]
+ x at data <- subset(new.data, select=-Row.names)
x
})
@@ -232,15 +145,24 @@
invisible(res)
})
+#setMethod("tipData", signature(x="phylo4d"),
+# function(x) {
+# nrow(x at tip.data) > 0
+#})
setMethod("hasTipData", signature(x="phylo4d"),
function(x) {
- nrow(x at tip.data) > 0
+ ncol(tdata(x, type="tip", empty.columns=FALSE)) > 0
})
+#setMethod("nodeData", signature(x="phylo4d"),
+# function(x) {
+# nrow(x at tip.data) > 0
+#})
+
setMethod("hasNodeData", signature(x="phylo4d"),
function(x) {
- nrow(x at node.data) > 0
+ ncol(tdata(x, type="internal", empty.columns=FALSE)) > 0
})
Modified: branches/slot-mods/R/prune.R
===================================================================
--- branches/slot-mods/R/prune.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/prune.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -124,7 +124,7 @@
tree <- extractTree(x)
phytr <- prune(tree, tips.exclude, trim.internal)
- ## create temporary phylo4 object with unique labels
+ ## create temporary phylo4 object with complete and unique labels
tmpLbl <- .genlab("n", nTips(x)+nNodes(x))
tmpPhy <- tree
labels(tmpPhy, "all") <- tmpLbl
@@ -133,28 +133,15 @@
## get node numbers to keep
oldLbl <- labels(tmpPhy, "all")
newLbl <- labels(tmpPhytr, "all")
- toKeep <- as.numeric(names(oldLbl[oldLbl %in% newLbl]))
- tipToKeep <- toKeep[toKeep %in% nodeId(x, "tip")]
- nodToKeep <- toKeep[toKeep %in% nodeId(x, "internal")]
+ wasKept <- oldLbl %in% newLbl
+ nodesToKeep <- as.numeric(names(oldLbl[wasKept]))
- if(!all(dim(x at tip.data) == 0)) {
- tipDt <- x at tip.data[match(tipToKeep, rownames(x at tip.data)) ,, drop=FALSE]
- tipDt <- tipDt[.chnumsort(rownames(tipDt)) ,, drop=FALSE]
- rownames(tipDt) <- 1:nTips(phytr)
- }
- else
- tipDt <- data.frame(NULL)
+ ## subset original data, and update names
+ allDt <- x at data[match(nodesToKeep, rownames(x at data)), , drop=FALSE]
+ rownames(allDt) <- match(newLbl, oldLbl[wasKept])
- if(!all(dim(x at node.data) == 0)) {
- nodDt <- x at node.data[match(nodToKeep, rownames(x at node.data)) ,, drop=FALSE]
- nodDt <- nodDt[.chnumsort(rownames(nodDt)) ,, drop=FALSE]
- rownames(nodDt) <- 1:nNodes(phytr)
- }
- else
- nodDt <- data.frame(NULL)
+ phytr <- phylo4d(phytr, all.data=allDt, match.data=TRUE)
- phytr <- phylo4d(phytr, tip.data=tipDt, node.data=nodDt, match.data=FALSE)
-
phytr
})
Modified: branches/slot-mods/R/setAs-Methods.R
===================================================================
--- branches/slot-mods/R/setAs-Methods.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/setAs-Methods.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -163,7 +163,7 @@
setAs("multiPhylo4", "multiPhylo", function(from, to) {
y <- lapply(from at phylolist, function(x) as(x, "phylo"))
names(y) <- from at tree.names
- if (nrow(from at tip.data) > 0)
+ if (hasTipData(from))
warning("discarded tip data")
class(y) <- "multiPhylo"
y
@@ -215,7 +215,7 @@
tDf$label <- as.character(tDf$label)
if (class(from) == "phylo4d") {
- dat <- tdata(from, "allnode", label.type="column") # get data
+ dat <- tdata(from, "all", label.type="column") # get data
## reorder data to edge matrix order, drop labels (first column)
if(nrow(dat) > 0 && ncol(dat) > 1) {
Modified: branches/slot-mods/R/subset.R
===================================================================
--- branches/slot-mods/R/subset.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/subset.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -97,19 +97,19 @@
setMethod("[", signature(x="phylo4d", i="ANY", j="character",
drop="missing"), function(x, i, j, ..., drop) {
if (!missing(i)) x <- x[i]
- tdata(x, type="allnode") <- tdata(x, type="allnode")[j]
+ tdata(x, type="all") <- tdata(x, type="all")[j]
return(x)
})
setMethod("[", signature(x="phylo4d", i="ANY", j="numeric",
drop="missing"), function(x, i, j, ..., drop) {
if (!missing(i)) x <- x[i]
- tdata(x, type="allnode") <- tdata(x, type="allnode")[j]
+ tdata(x, type="all") <- tdata(x, type="all")[j]
return(x)
})
setMethod("[", signature(x="phylo4d", i="ANY", j="logical",
drop="missing"), function(x, i, j, ..., drop) {
if (!missing(i)) x <- x[i]
- tdata(x, type="allnode") <- tdata(x, type="allnode")[j]
+ tdata(x, type="all") <- tdata(x, type="all")[j]
return(x)
})
## borrow from Matrix package approach of trapping invalid usage
Modified: branches/slot-mods/R/tbind.R
===================================================================
--- branches/slot-mods/R/tbind.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/tbind.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -9,7 +9,7 @@
## function to bind trees together into a multi-tree object
tbind <- function(...,checkData=TRUE) {
- L <- as.list(...)
+ L <- list(...)
namevec <- names(L)
treeclasses <- c("multiPhylo4d","multiPhylo4","phylo4","phylo4d")
tdataclasses <- c("multiPhylo4d","phylo4d")
@@ -27,14 +27,12 @@
multiPhylo4d=suppressWarnings(as("multiPhylo4",x)@phylolist))}
## decompose multi-trees into lists
treelist <- unlist(lapply(L,xfun))
- if (hasData) alldat <- lapply(L[classes %in% tdataclasses],
- "@","tip.data") ## ???
- ## or function(x) {x at tip.data}
- hasNodeData <- sapply(L[classes %in% tdataclasses],
- function(x) {!is.null(x at node.data)})
+ if (hasData) alldat <- lapply(L[classes %in% tdataclasses], tdata,
+ type="tip")
+ hasNodeData <- sapply(L[classes %in% tdataclasses], hasNodeData)
if (any(hasNodeData)) warning("internal node data discarded")
if (checkData) {
- ident <- sapply(alldat[-1],identical,y=alldat[[1]])
+ ident <- sapply(alldat,identical,y=alldat[[1]])
if (!all(ident)) stop(paste("tip data sets differ"))
} ## ?? implement code to check which ones differ (taking
## null/multiple values in original set into account)
Modified: branches/slot-mods/R/treePlot.R
===================================================================
--- branches/slot-mods/R/treePlot.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/R/treePlot.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -26,6 +26,10 @@
if (!inherits(phy, 'phylo4')) stop('treePlot requires a phylo4 or phylo4d object')
if (!isRooted(phy)) stop("treePlot function requires a rooted tree.")
+ if (plot.data && !hasTipData(phy)) {
+ warning("tree has no tip data to plot")
+ plot.data <- FALSE
+ }
if(newpage) grid.newpage()
type <- match.arg(type)
Modified: branches/slot-mods/data/geospiza.rda
===================================================================
(Binary files differ)
Modified: branches/slot-mods/inst/unitTests/runit.class-phylo4d.R
===================================================================
--- branches/slot-mods/inst/unitTests/runit.class-phylo4d.R 2009-09-23 16:47:56 UTC (rev 665)
+++ branches/slot-mods/inst/unitTests/runit.class-phylo4d.R 2009-09-25 23:35:55 UTC (rev 666)
@@ -58,53 +58,46 @@
## brute force: no matching; with tip data
phyd <- phylo4d(phy.alt, tip.data=tipDt, match.data=FALSE)
- checkEquals(phyd at tip.data, data.frame(tipDt,
+ checkIdentical(phyd at data, data.frame(tipDt,
row.names=as.character(nid.tip)))
- checkEquals(tdata(phyd, "tip"), data.frame(tipDt,
+ 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)
- checkEquals(phyd at node.data, data.frame(nodDt,
+ checkIdentical(phyd at data, data.frame(nodDt,
row.names=as.character(nid.int)))
- checkEquals(tdata(phyd, "internal"), data.frame(nodDt,
+ 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)
- # TODO: these fail b/c all.data option creates numeric row.names
- # whereas tip.data and node.data options create character row.names
- #checkEquals(phyd at tip.data, data.frame(allDt,
- # row.names=as.character(nid.all))[nid.tip,])
- #checkEquals(phyd at node.data, data.frame(allDt,
- # row.names=as.character(nid.all))[nid.int,])
- checkEquals(tdata(phyd, "all"), data.frame(allDt,
+ checkIdentical(phyd at data, data.frame(allDt,
+ row.names=as.character(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)
- checkEquals(phyd at tip.data, data.frame(tipDt["d"], e=NA_real_,
- row.names=as.character(nid.tip)))
- checkEquals(tdata(phyd, "tip"), data.frame(tipDt["d"], e=NA_real_,
+ checkIdentical(phyd at data, data.frame(rbind(data.frame(tipDt["d"],
+ e=NA_real_), data.frame(d=NA_real_, nodDt["e"])),
+ row.names=as.character(nid.all)))
+ checkIdentical(tdata(phyd, "tip"), data.frame(tipDt["d"], e=NA_real_,
row.names=lab.tip))
- checkEquals(phyd at node.data, data.frame(d=NA_real_, nodDt["e"],
- row.names=as.character(nid.int)))
- checkEquals(tdata(phyd, "internal"), data.frame(d=NA_real_, nodDt["e"],
+ 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)
- checkEquals(phyd at tip.data, data.frame(c=factor(tipDt$c,
- levels=letters[nid.all]), row.names=as.character(nid.tip)))
- checkEquals(phyd at node.data, data.frame(c=factor(nodDt$c,
- levels=letters[nid.all]), row.names=as.character(nid.int)))
- checkEquals(tdata(phyd, "tip"), data.frame(c=factor(tipDt$c,
+ checkIdentical(phyd at data, data.frame(rbind(tipDt["c"], nodDt["c"]),
+ row.names=as.character(nid.all)))
+ checkIdentical(tdata(phyd, "tip"), data.frame(c=factor(tipDt$c,
levels=letters[nid.all]), row.names=lab.tip))
- checkEquals(tdata(phyd, "internal"), data.frame(c=factor(nodDt$c,
+ 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
@@ -114,86 +107,83 @@
## match with node numbers, tip data
phyd <- phylo4d(phy.alt, tip.data=tipDt)
- checkEquals(phyd at tip.data, data.frame(tipDt[order(nid.tip.r),],
+ checkIdentical(phyd at data, data.frame(tipDt[order(nid.tip.r),],
row.names=as.character(nid.tip)))
- checkEquals(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),],
+ 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)
- checkEquals(phyd at node.data, data.frame(nodDt[order(nid.int.r),],
+ checkIdentical(phyd at data, data.frame(nodDt[order(nid.int.r),],
row.names=as.character(nid.int)))
- checkEquals(tdata(phyd, "internal"), data.frame(nodDt[order(nid.int.r),],
+ 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"])
- checkEquals(phyd at tip.data, data.frame(d=tipDt[order(nid.tip.r), "d"],
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 666
More information about the Phylobase-commits
mailing list