[Phylobase-commits] r467 - in pkg: . R data inst/doc man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Aug 18 19:13:40 CEST 2009
Author: pdc
Date: 2009-08-18 19:13:35 +0200 (Tue, 18 Aug 2009)
New Revision: 467
Added:
pkg/RUnit-tests/
Modified:
pkg/DESCRIPTION
pkg/R/checkdata.R
pkg/R/class-phylo4.R
pkg/R/class-phylo4d.R
pkg/R/methods-phylo4.R
pkg/R/methods-phylo4d.R
pkg/R/phylo4.R
pkg/R/prune.R
pkg/R/setAs-Methods.R
pkg/R/treewalk.R
pkg/data/geospiza.rda
pkg/inst/doc/phylobase.Rnw
pkg/inst/doc/phylobase.pdf
pkg/man/as-methods.Rd
pkg/man/check.phylo4.Rd
pkg/man/check.phylo4d.Rd
pkg/man/phylo4d-class.Rd
pkg/man/phylo4d.Rd
pkg/man/prune-methods.Rd
pkg/man/subset-methods.Rd
pkg/tests/misctests.R
pkg/tests/testprune.R
Log:
Merge of fm-branch into main, labels are now stored with a more robust internal key
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2009-08-18 16:38:03 UTC (rev 466)
+++ pkg/DESCRIPTION 2009-08-18 17:13:35 UTC (rev 467)
@@ -1,7 +1,7 @@
Package: phylobase
Type: Package
Title: Base package for phylogenetic structures and comparative data
-Version: 0.4
+Version: 0.4.1
Date: 2009-04-21
Depends: methods, grid, ape(>= 2.1)
Suggests: ade4, MASS, gridBase
@@ -9,6 +9,6 @@
Maintainer: Ben Bolker <bolker at ufl.edu>
Description: Provides a base S4 class for comparative methods, incorporating one or more trees and trait data
License: GPL
-Collate: phylo4.R checkdata.R class-multiphylo4.R class-oldclasses.R class-phylo4.R class-phylo4d.R class-phylomats.R methods-multiphylo4.R methods-oldclasses.R methods-phylo4.R methods-phylo4d.R setAs-Methods.R pdata.R subset.R prune.R treePlot.R identify.R treestruc.R treewalk.R readNexus.R tbind.R zzz.R printphylo-deprecated.R
+Collate: phylo4.R checkData-deprecated.R checkdata.R class-multiphylo4.R class-oldclasses.R class-phylo4.R class-phylo4d.R class-phylomats.R methods-multiphylo4.R methods-oldclasses.R methods-phylo4.R methods-phylo4d.R setAs-Methods.R pdata.R subset.R prune.R treePlot.R identify.R treestruc.R treewalk.R readNexus.R tbind.R zzz.R printphylo-deprecated.R updatePhylo4.R
Encoding: UTF-8
URL: http://phylobase.R-forge.R-project.org
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2009-08-18 16:38:03 UTC (rev 466)
+++ pkg/R/checkdata.R 2009-08-18 17:13:35 UTC (rev 467)
@@ -70,6 +70,56 @@
paste(phylo4_orderings,collapse=","))
}
+ ## make sure that nodes and edges have internal names
+ ## and that they match the nodes
+ if(is.null(names(object at tip.label))) {
+ if(length(object at tip.label) == nTips(object)) {
+ stop("It seems that you have an old version of a phylo4 object. ",
+ "Try to use the function updatePhylo4().")
+ }
+ else
+ stop("Your object doesn't have internal node names and the number of ",
+ "tip labels doesn't match the number tips.")
+ }
+ else {
+ if(!all(names(object at tip.label) %in% nodeId(object, "tip")))
+ stop("Internal names for tips don't match tip ID numbers")
+ }
+
+ if(is.null(names(object at node.label))) {
+ if(length(object at node.label) == nNodes(object)) {
+ stop("It seems that you have an old version of a phylo4 object. ",
+ "Try to use the function updatePhylo4().")
+ }
+ else
+ stop("Your object doesn't have internal node names and the number of ",
+ "node labels doesn't match the number nodes.")
+ }
+ else {
+ if(!all(names(object at node.label) %in% nodeId(object, "internal")))
+ stop("Internal names for tips don't match tip ID numbers")
+ }
+
+ if(hasEdgeLength(object)) {
+ if(is.null(names(object at edge.length))) {
+ warning("It seems that you have an old version of a phylo4 object. ",
+ "Try to use the function updatePhylo4().")
+ }
+ else {
+ tEdgLbl <- paste(object at edge[,1], object at edge[,2], sep="-")
+ if(!all(names(object at edge.length) %in% tEdgLbl))
+ stop("There is something wrong with your internal edge length ",
+ "labels.")
+ }
+ }
+
+ ## make sure that edgeLength has correct length and is numerical
+ if(hasEdgeLength(object)) {
+ if(length(object at edge.length) != nedges)
+ stop("The number of edge lengths is different from the number of edges.")
+ if(!is.numeric(object at edge.length)) stop("Edge lengths are not numeric.")
+ }
+
## make sure that tip and node labels are unique
lb <- labels(object, "allnode")
lb <- lb[nchar(lb) > 0]
@@ -97,320 +147,112 @@
return(TRUE)
}
-checkData <- function(object,
- label.type=c("row.names","column"),
- label.column=1,
- use.tip.names=TRUE,
- missing.tip.data=c("fail","OK","warn"),
- extra.tip.data=c("fail","OK","warn"),
- default.tip.names=c("warn","OK","fail"),
- use.node.names=FALSE,
- missing.node.data=c("OK","warn","fail"),
- extra.node.data=c("OK","warn","fail"),
- default.node.names=c("warn","OK","fail"),
- non.unique.tips=c("warn", "OK", "fail"),
- non.unique.nodes=c("warn", "OK", "fail"),
- ...)
-{
+formatData <- function(phy, dt, which=c("tip", "internal", "all"),
+ match.data=TRUE, label.type=c("rownames", "column"),
+ label.column=1, missing.data=c("fail", "warn", "OK"),
+ extra.data=c("warn", "OK", "fail")
+ ) {
- ## name matching default: use row.names of data frame
+ which <- match.arg(which)
label.type <- match.arg(label.type)
- if (identical(label.type, "row.names")) {
- tip.names <- row.names(object at tip.data)
- node.names <- row.names(object at node.data)
- }
- else {
- tip.names <- object at tip.data[,label.column]
- node.names <- object at node.data[,label.column]
- }
+ stopifnot(label.column %in% 1:ncol(dt))
+ missing.data <- match.arg(missing.data)
+ extra.data <- match.arg(extra.data)
- ## tip default: use names, require names, must match exactly
- missing.tip.data <- match.arg(missing.tip.data)
- extra.tip.data <- match.arg(extra.tip.data)
- default.tip.names <- match.arg(default.tip.names)
+ nr <- switch(which,
+ tip = nTips(phy),
+ internal = nNodes(phy),
+ all = nTips(phy)+nNodes(phy))
- ## node default: don't use node names, don't require names, do not need to match exactly
- missing.node.data <- match.arg(missing.node.data)
- extra.node.data <- match.arg(extra.node.data)
- default.node.names <- match.arg(default.node.names)
+ tmpDt <- array(, dim=c(nr, ncol(dt)),
+ dimnames=list(nodeId(phy, which), colnames(dt)))
+ tmpDt <- data.frame(tmpDt)
- ## non unique tip default: by default if some tip names are non-unique they
- ## all get associated the same value and this is done with a warning. Other
- ## options are: association of data without warning and require uniqueness of tips.
- non.unique.tips <- match.arg(non.unique.tips)
+ if(match.data) {
+ ## Replace node labels by node numbers
+ ndNames <- switch(label.type,
+ rownames = rownames(dt),
+ column = dt[,label.column])
+ ndDt <- lapply(ndNames, function(nd) {
+ if(nchar(gsub("[0-9]", "", nd)) == 0)
+ getNode(phy, as.integer(nd), missing="OK")
+ else getNode(phy, nd, missing="OK")
+ })
+ ndDt <- unlist(ndDt)
- ## for each set of data, check for names, missing and extra data and take appropriate actions
+ ## Make sure that data are matched to appropriate nodes
+ if(which != "all") {
+ switch(which,
+ tip = {
+ if(any(names(ndDt) %in% labels(phy, "internal")))
+ stop("You are trying to match tip data to internal ",
+ "nodes. Make sure that your data identifiers ",
+ "are correct.")
+ },
+ internal = {
+ if(any(names(ndDt) %in% labels(phy, "tip")))
+ stop("You are trying to match node data to tip ",
+ "nodes. Make sure that your data identifiers ",
+ "are correct.")
+ })
+ }
- ## tip data checks
- ## if tip.data exist
- if (!all(dim(object at tip.data)==0)) {
- ## if we want to use tip.names
- if (use.tip.names) {
+ ## Check differences
+ extra <- names(ndDt[is.na(ndDt)])
+ mssng <- nodeId(phy, which)[! nodeId(phy, which) %in% ndDt]
- ## check for default names
- if (all(tip.names == 1:length(tip.names))) {
- ## no tip.names
- if (default.tip.names == "fail") {
- stop("Tip data have default names and may not match tree tip labels. ",
- "Consider using the use.tip.names=FALSE option.")
- }
- else if (default.tip.names == "warn") {
- warning("Tip data have default names and may not match tree tip labels. ",
- "Consider using the use.tip.names=FALSE option.")
- }
- }
+ if(length(mssng) > 0 && missing.data != "OK") {
+ msg <- "The following nodes are not found in the dataset: "
- ## check tip names
- ## check for missing or extra tip data (relative to tree taxa)
- if (setequal(tip.names, object at tip.label)) {
- if(length(tip.names) == nTips(object)) {
- ## names are perfect match - ok
- return(TRUE)
- }
- else {
- ## Some tips are non-unique
- tipsTable <- table(tipLabels(object))
- if(any(nU <- tipsTable > 1)) {
- nonUnique <- paste(names(tipsTable[nU]), collapse=", ")
- nonUniqueMsg <- paste("Tip \'", nonUnique, "\' not unique", sep = "")
- ## TODO - When labels will be matched on node numbers
- ## then we will be able to allow non-unique labels
- ## if(non.unique.tips == "fail")
- stop(nonUniqueMsg)
- ## if(non.unique.tips == "warn")
- ## warning(nonUniqueMsg)
- }
- }
- }
- else {
- ## we know the tree taxa and tip.data taxa are not a perfect match
- ## if tip.data taxa are subset of tree taxa, check missing.tip.data arg and act accordingly
- tips.in.rownames <- object at tip.label %in% tip.names
- rownames.in.tips <- tip.names %in% object at tip.label
- missing.data.names <- object at tip.label[!tips.in.rownames]
- missing.data.name.msg <- if (length(missing.data.names)==0) "" else {
- paste("\n(missing data names: ",
- paste(missing.data.names,collapse=","),")",sep="")
- }
- extra.data.names <- tip.names[!rownames.in.tips]
- extra.data.name.msg <- if (length(extra.data.names)==0) "" else {
- paste("\n(extra data names: ",
- paste(extra.data.names,collapse=","),")",sep="")
- }
- if (!all(tips.in.rownames)) {
- ## we know it's not an exact match - we have missing.tip.data - take action
- if (!any(tips.in.rownames)) {
- errmsg <- paste("No matches between tip data names and tree tip labels.",
- missing.data.name.msg,extra.data.name.msg)
- if (missing.tip.data == "fail") {
- stop(errmsg)
- }
- else if (missing.tip.data == "warn") {
- warning(errmsg)
- }
- }
- else
- {
- errmsg <- paste("Tip data names are a subset of tree tip labels",
- missing.data.name.msg,
- extra.data.name.msg)
- if (missing.tip.data == "fail") {
- stop(errmsg)
- }
+ ## provides label if it exists and node number otherwise
+ mssng <- sapply(mssng, function(m) {
+ m <- getNode(phy, m)
+ if (is.na(names(m)) || is.null(names(m)))
+ m
+ else
+ names(m)
+ })
- else if (missing.tip.data == "warn") {
- warning(errmsg)
- }
- }
- ##else ok
- }
-
- ##if tree taxa are subset of tip.data, check extra.tip arg and act accordingly
- if (!all(tip.names %in% object at tip.label)) {
- ##we know it's not an exact match - we have extra.tip.data - take action
- ##fail
- errmsg <- paste("Tip data names are a superset of tree tip labels",
- missing.data.name.msg,
- extra.data.name.msg)
- if (extra.tip.data == "fail") {
- stop(errmsg)
- }
- ##warn
- else if (extra.tip.data == "warn") {
- warning(errmsg)
- }
- ##else ok
- }
-
- return(TRUE)
- }
+ msg <- paste(msg, paste(mssng, collapse=", "))
+ switch(missing.data,
+ warn = warning(msg),
+ fail = stop(msg))
}
- else
- {
- ##don't use tip names or attempt to sort - but check to make sure dimensions match
- if (!(nTips(object)==dim(object at tip.data)[1])) {
- stop("Ignoring tip data names. Number of tip data do not match number of tree tips.")
- }
- }
- }
- ## node data checks
- ## if node.data exist
- if (!all(dim(object at node.data)==0)) {
- ## if we want to use node.names
- if (use.node.names) {
+ if(length(extra) > 0 && extra.data != "OK") {
+ msg <- "The following names are not found in the tree: "
+ msg <- paste(msg, paste(extra, collapse=", "))
+ switch(extra.data,
+ warn = warning(msg),
+ fail = stop(msg))
- ## check for default names
- if (all(node.names == 1:length(node.names))
- || all(node.names == (nTips(object)+1):nEdges(object))) {
- ## no node.names
- if (default.node.names == "fail") {
- stop("Node data have default names and may not match tree node labels. ",
- "Consider using the use.node.names=FALSE option.")
- }
- else if (default.node.names == "warn") {
- warning("Node data have default names and may not match tree node labels. ",
- "Consider using the use.node.names=FALSE option.")
- }
- }
-
- ## check node names
- ## check for missing or extra node data (relative to tree taxa)
- if (setequal(node.names, object at node.label)) {
- if(length(node.names) == nNodes(object)) {
- ## names are perfect match - ok
- return(TRUE)
- }
- else {
- ## Some nodes are non-unique
- nodesTable <- table(nodeLabels(object))
- if(any(nU <- nodesTable > 1)) {
- nonUnique <- paste(names(nodesTable[nU]), collapse=", ")
- nonUniqueMsg <- paste("Node \'", nonUnique, "\' not unique", sep = "")
- ## TODO - When labels will be matched on node numbers
- ## then we will be able to allow non-unique labels
- ## if(non.unique.nodes == "fail")
- stop(nonUniqueMsg)
- ## if(non.unique.nodes == "warn")
- warning(nonUniqueMsg)
- }
- }
- }
- else {
- ## we know the tree taxa and node.data taxa are not a perfect match
- ## if node.data taxa are subset of tree taxa, check missing.node.data arg and act accordingly
- nodes.in.rownames <- object at node.label %in% node.names
- rownames.in.nodes <- node.names %in% object at node.label
- missing.data.names <- object at node.label[!nodes.in.rownames]
- missing.data.name.msg <- if (length(missing.data.names)==0) "" else {
- paste("\n(missing data names: ",
- paste(missing.data.names,collapse=","),")",sep="")
- }
- extra.data.names <- node.names[!rownames.in.nodes]
- extra.data.name.msg <- if (length(extra.data.names)==0) "" else {
- paste("\n(extra data names: ",
- paste(extra.data.names,collapse=","),")",sep="")
- }
- if (!all(nodes.in.rownames)) {
- ## we know it's not an exact match - we have missing.node.data - take action
- if (!any(nodes.in.rownames)) {
- errmsg <- paste("No matches between node data names and tree node labels.",
- missing.data.name.msg,extra.data.name.msg)
- if (missing.node.data == "fail") {
- stop(errmsg)
- }
- else if (missing.node.data == "warn") {
- warning(errmsg)
- }
- }
- else
- {
- errmsg <- paste("Node data names are a subset of tree node labels",
- missing.data.name.msg,
- extra.data.name.msg)
- if (missing.node.data == "fail") {
- stop(errmsg)
- }
-
- else if (missing.node.data == "warn") {
- warning(errmsg)
- }
- }
- ##else ok
- }
-
- ##if tree taxa are subset of node.data, check extra.node arg and act accordingly
- if (!all(node.names %in% object at node.label)) {
- ##we know it's not an exact match - we have extra.node.data - take action
- ##fail
- errmsg <- paste("Node data names are a superset of tree node labels",
- missing.data.name.msg,
- extra.data.name.msg)
- if (extra.node.data == "fail") {
- stop(errmsg)
- }
- ##warn
- else if (extra.node.data == "warn") {
- warning(errmsg)
- }
- ##else ok
- }
-
- return(TRUE)
- }
}
- else
- {
- ##don't use node names or attempt to sort - but check to make sure dimensions match
- if (!(nNodes(object)==dim(object at node.data)[1])) {
- stop("Ignoring node data names. Number of node data do not match number of tree nodes.")
- }
- }
+ ## Format data to have correct dimensions
+ dt <- dt[!is.na(ndDt) ,, drop=FALSE]
+ rownames(dt) <- ndDt[!is.na(ndDt)]
+ if(label.type == "column") dt <- dt[, -label.column]
+ tmpDt[match(rownames(dt), rownames(tmpDt)), ] <- dt
}
-}
-
-attachData <- function(object,
- label.type=c("row.names","column"),
- label.column=1,
- use.tip.names=TRUE,
- use.node.names=FALSE,
- ...)
-{
-
- ## assumes data have already been checked by checkData!
- ## name matching default: use row.names of data frame
- label.type = match.arg(label.type)
- if (identical(label.type, "row.names")) {
- tip.names <- row.names(object at tip.data)
- node.names <- row.names(object at node.data)
- }
else {
- tip.names <- object at tip.data[,label.column]
- node.names <- object at node.data[,label.column]
- }
+ ## Remove rownames in data provided
+ rownames(dt) <- NULL
-
- ## for each set of data, take appropriate actions
-
- ## tip data operations:
- ## if tip.data exist
- if (!all(dim(object at tip.data)==0)) {
- ## if we want to use tip.names
- if (use.tip.names) {
- object at tip.data <- object at tip.data[match(object at tip.label,tip.names),,drop=FALSE]
+ ## Check differences between dataset and tree
+ diffNr <- nrow(dt) - nr
+ if(diffNr > 0 && extra.data != "OK") {
+ msg <- paste("There are", diffNr, "extra rows.")
+ switch(extra.data,
+ warn = warning(msg),
+ fail = stop(msg))
}
- #tip.names <- object at tip.label
- }
-
- ## node data operations
- if (!all(dim(object at node.data)==0)) {
- ## if we want to use tip.names
- if (use.node.names) {
- object at node.data <- object at node.data[match(object at node.label,node.names),,drop=FALSE]
+ if(diffNr < 0 && missing.data != "OK") {
+ msg <- paste("There are", abs(diffNr), "missing rows.")
+ switch(missing.data,
+ warn = warning(msg),
+ fail = stop(msg))
}
- #node.names <- object at node.label
+ tmpDt <- dt[1:min(nrow(dt), nr) ,, drop = FALSE]
}
- return(object)
-
+ tmpDt
}
Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2009-08-18 16:38:03 UTC (rev 466)
+++ pkg/R/class-phylo4.R 2009-08-18 17:13:35 UTC (rev 467)
@@ -19,6 +19,79 @@
validity = checkPhylo4)
#####################
+## Labels constructor
+#####################
+
+.createLabels <- function(value, ntips, nnodes, use.names = TRUE,
+ which = c("tip", "internal", "allnode")) {
+
+ which <- match.arg(which)
+
+ ## set up final length of object to return
+ lgthRes <- switch(which, tip=ntips, internal=nnodes, allnode=ntips+nnodes)
+
+ ## create NA character vector of node labels
+ res <- character(lgthRes)
+ is.na(res) <- TRUE
+
+ ## create internal names
+ names(res) <- switch(which,
+ tip = 1:ntips,
+ internal = seq(from=ntips+1, length=lgthRes),
+ allnode = 1:(ntips+nnodes))
+
+
+ ## if no values are provided
+ if(missing(value) || is.null(value) || all(is.na(value))) {
+ ## tip labels can't be NULL
+ if(!identical(which, "internal")) {
+ tipLbl <- .genlab("T", ntips)
+ res[1:ntips] <- tipLbl
+ }
+ }
+
+ ## if labels are provided
+ else {
+ ## check that lengths match
+ if(length(value) != lgthRes)
+ stop("Number of labels does not match number of nodes.")
+
+ ## check if vector 'value' has name, and if so match with node.label names
+ if(use.names && !is.null(names(value))) {
+ if(!all(names(value) %in% names(res)))
+ stop("Names provided don't match internal labels names.")
+ res[match(names(value), names(res))] <- value
+ }
+ else
+ res[1:lgthRes] <- value
+ }
+
+ res
+}
+
+
+.createEdge <- function(value, edgeMat, type=c("lengths", "labels"), use.names=TRUE) {
+ type <- match.arg(type)
+
+ lgthRes <- nrow(edgeMat)
+ res <- switch(type, lengths=numeric(lgthRes), labels=character(lgthRes))
+ is.na(res) <- TRUE
+ names(res) <- paste(edgeMat[,1], edgeMat[,2], sep="-")
+
+ if(!(missing(value) || is.null(value) || all(is.na(value)))) {
+ if(use.names && !is.null(names(value))) {
+ if(!all(names(value) %in% names(res)))
+ stop("Names provided don't match internal edge labels names.")
+ res[match(names(value), names(res))] <- value
+ }
+ else
+ res[1:lgthRes] <- value
+ }
+
+ res
+}
+
+#####################
## phylo4 constructor
#####################
@@ -37,59 +110,30 @@
edge <- x
mode(edge) <- "integer"
#if(any(is.na(edge))) stop("NA are not allowed in edge matrix")
- if(ncol(edge) > 2) warning("the edge matrix has more than two columns")
+ if(ncol(edge) > 2)
+ warning("The edge matrix has more than two columns, ",
+ "only the first two columns are considered.")
edge <- as.matrix(edge[, 1:2])
colnames(edge) <- c("ancestor", "descendant")
- ## edge.length
- if(!is.null(edge.length)) {
- if(!is.numeric(edge.length)) stop("edge.length is not numeric")
- edge.length <- edge.length
- } else {
- edge.length <- numeric(0)
- }
-
- if(length(edge.length) > 0) {
- if(length(edge.length) != nrow(edge))
- stop("The number of edge lengths is different from the number of edges.")
- ## FM - 2009-04-19
- ## edge.length is named according to the nodes the edge links together
- ## (ancestor-descendant). This should allow more robust edge/edge.length
- ## association and limit the problems associated with reordering trees.
- names(edge.length) <- paste(edge[,1], edge[,2], sep="-")
- }
-
- ## tip.label
+ ## number of tips and number of nodes
ntips <- sum(tabulate(na.omit(edge[, 1])) == 0)
- if(is.null(tip.label)) {
- tip.label <- .genlab("T", ntips)
- } else {
- if(length(tip.label) != ntips)
- stop("the tip labels are not consistent with the number of tips")
- tip.label <- as.character(tip.label)
- }
- names(tip.label) <- seq(along=tip.label)
-
- ## node.label for internal nodes
nnodes <- length(unique(na.omit(c(edge)))) - ntips
- if(is.null(node.label)) {
- node.label <- character(0) ## empty node labels
- }
- else {
- if(length(node.label)>0 && length(node.label) != nnodes)
- stop("number of node labels is not consistent with the number of nodes")
- }
- names(node.label) <- seq(from=ntips+1, along=node.label)
+ ## edge.length
+ edge.length <- .createEdge(value=edge.length, edgeMat=edge, type="lengths", use.names=FALSE)
-
## edge.label
- if(is.null(edge.label)) {
- edge.label <- character(0)
- } else if (length(edge.label)>0 && length(edge.label) != nrow(edge))
- stop("number of edge labels is not consistent with the number of edges")
+ edge.label <- .createEdge(value=edge.label, edgeMat=edge, type="labels", use.names=FALSE)
+ ## tip.label
+ tip.label <- .createLabels(value=tip.label, ntips=ntips, nnodes=nnodes,
+ which="tip")
+ ## node.label
+ node.label <- .createLabels(node.label, ntips=ntips, nnodes=nnodes,
+ which="internal")
+
## fill in the result
res <- new("phylo4")
res at edge <- edge
@@ -103,7 +147,6 @@
## checkPhylo4 will return a character string if object is
## bad, otherwise TRUE
if (is.character(checkval <- checkPhylo4(res))) stop(checkval)
-
return(res)
})
Modified: pkg/R/class-phylo4d.R
===================================================================
--- pkg/R/class-phylo4d.R 2009-08-18 16:38:03 UTC (rev 466)
+++ pkg/R/class-phylo4d.R 2009-08-18 17:13:35 UTC (rev 467)
@@ -26,128 +26,193 @@
## generic
setGeneric("phylo4d", function(x, ...) { standardGeneric("phylo4d")} )
-## first arg is a phylo4
-setMethod("phylo4d", "phylo4",
- function(x, tip.data = NULL, node.data = NULL, all.data = NULL,
- merge.tip.node = TRUE, ...) {
+## Core part that takes care of the data
+.phylo4Data <- function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
+ match.data=TRUE, merge.data=TRUE, ...) {
- classData <- function(someData) {
- if(!is.null(someData)) {
- if(is.vector(someData)) someData <- as.data.frame(someData)
- if(!is.data.frame(someData)) {
- nmSomedata <- deparseSubstitute(someData)
- return(paste(nmSomeData, "must be a vector or a data frame"))
- }
- return(TRUE)
- }
- else return(TRUE)
- }
+ ## 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
+ }
+ }
- if(is.character(checkval <- checkPhylo4(x))) stop(checkval)
+ ## Check validity of phylo4 object
+ if(is.character(checkval <- checkPhylo4(x))) stop(checkval)
- if(is.character(checkClass <- classData(all.data))) stop(checkClass)
- if(is.character(checkClass <- classData(tip.data))) stop(checkClass)
- if(is.character(checkClass <- classData(node.data))) stop(checkClass)
+ ## Check/Transform provided data to data.frame
+ all.data <- classData(all.data)
+ tip.data <- classData(tip.data)
+ node.data <- classData(node.data)
- res <- new("phylo4d")
- res at edge <- x at edge
- res at edge.length <- x at edge.length
- res at Nnode <- x at Nnode
- res at tip.label <- x at tip.label
- res at node.label <- x at node.label
- res at edge.label <- x at edge.label
+ ## Replacing node labels by node numbers and formatting the data to make sure
+ ## they have the correct dimensions
+ if(!is.null(all.data) && all(dim(all.data) > 0))
+ all.data <- formatData(x, all.data, which="all",
+ match.data=match.data, ...)
- if(!is.null(all.data)) {
- tmpData <- all.data
- if(!is.null(tip.data)) {
- emptyNodeData <- array(, dim = c(nNodes(x), ncol(tip.data)),
- dimnames = list(nodeLabels(x), colnames(tip.data)))
- tmpTipData <- rbind(tip.data, emptyNodeData)
- ## TODO? - have a test on names between
- tmpTipData <- tmpTipData[match(rownames(all.data), rownames(tmpTipData)) ,, drop = FALSE]
- tmpData <- cbind(all.data, tmpTipData)
- }
- if(!is.null(node.data)) {
- emptyTipData <- array(, dim = c(nTips(x), ncol(node.data)),
- dimnames = list(tipLabels(x), colnames(node.data)))
- tmpNodeData <- rbind(emptyTipData, node.data)
- ## TODO? - add test
- tmpNodeData <- tmpNodeData[match(rownames(all.data), rownames(tmpNodeData)) ,, drop = FALSE]
- tmpData <- cbind(tmpData, tmpNodeData)
+ if(!is.null(tip.data) && all(dim(tip.data) > 0))
+ tip.data <- formatData(x, tip.data, which="tip",
+ match.data=match.data, ...)
- }
- if (!hasNodeLabels(x)) stop("can't match node data to labels without node labels")
- res at tip.data <- tmpData[rownames(tmpData) %in% tipLabels(x) ,, drop = FALSE]
- res at node.data <- tmpData[rownames(tmpData) %in% nodeLabels(x) ,, drop = FALSE]
- }
+ if(!is.null(node.data) && all(dim(node.data) > 0))
+ node.data <- formatData(x, node.data, which="internal",
+ match.data=match.data, ...)
- else {
- if((!is.null(tip.data) && (!is.null(node.data)))) {
- if(identical(colnames(tip.data), colnames(node.data)) && merge.tip.node) {
- tmpAllData <- rbind(tip.data, node.data)
- res at tip.data <- tmpAllData[1:nTips(x) ,, drop = FALSE]
- res at node.data <- tmpAllData[-(1:nTips(x)) ,, drop = FALSE]
- }
- else {
- emptyTipData <- array(, dim = c(nTips(x), ncol(node.data)),
- dimnames = list(tipLabels(x), colnames(node.data)))
- emptyNodeData <- array(, dim = c(nNodes(x), ncol(tip.data)),
- dimnames = list(nodeLabels(x), colnames(tip.data)))
- tmpTipData <- rbind(tip.data, emptyNodeData)
- tmpNodeData <- rbind(emptyTipData, node.data)
- tmpData <- cbind(tmpTipData, tmpNodeData)
- res at tip.data <- tmpData[1:nTips(x) ,, drop = FALSE]
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 467
More information about the Phylobase-commits
mailing list