[Phylobase-commits] r446 - in branches: . fm-branch fm-branch/R fm-branch/inst/doc fm-branch/man fm-branch/src/ncl
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 8 01:04:15 CEST 2009
Author: francois
Date: 2009-07-08 01:04:13 +0200 (Wed, 08 Jul 2009)
New Revision: 446
Added:
branches/fm-branch/
Modified:
branches/fm-branch/DESCRIPTION
branches/fm-branch/R/checkdata.R
branches/fm-branch/R/class-phylo4.R
branches/fm-branch/R/class-phylo4d.R
branches/fm-branch/R/methods-phylo4.R
branches/fm-branch/R/methods-phylo4d.R
branches/fm-branch/R/setAs-Methods.R
branches/fm-branch/inst/doc/phylobase.pdf
branches/fm-branch/man/as-methods.Rd
branches/fm-branch/src/ncl/configure.ac
Log:
Creating branch for phylo4d rewrite.
Copied: branches/fm-branch (from rev 445, pkg)
Property changes on: branches/fm-branch
___________________________________________________________________
Name: svn:mergeinfo
+
Modified: branches/fm-branch/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2009-06-25 21:49:54 UTC (rev 445)
+++ branches/fm-branch/DESCRIPTION 2009-07-07 23:04:13 UTC (rev 446)
@@ -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.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 checkData.R
Encoding: UTF-8
URL: http://phylobase.R-forge.R-project.org
Modified: branches/fm-branch/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2009-06-25 21:49:54 UTC (rev 445)
+++ branches/fm-branch/R/checkdata.R 2009-07-07 23:04:13 UTC (rev 446)
@@ -70,6 +70,49 @@
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 tip and node labels are unique
lb <- labels(object, "allnode")
lb <- lb[nchar(lb) > 0]
@@ -97,278 +140,104 @@
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("warn", "OK", "fail"),
+ 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)
+
+ ## 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.")
+ })
+ }
- ## for each set of data, check for names, missing and extra data and take appropriate actions
+ ## Check differences
+ extra <- names(ndDt[is.na(ndDt)])
+ mssng <- labels(phy, which)[! labels(phy, which) %in% names(ndDt)]
- ## 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) {
+ if(length(mssng) > 0 && missing.data != "OK") {
+ msg <- "The following nodes are not found in the dataset: "
+ msg <- paste(msg, paste(mssng, collapse=", "))
+ switch(missing.data,
+ warn = warning(msg),
+ fail = stop(msg))
+ }
- ## 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(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 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)
- }
-
- 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)
- }
}
- 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.")
- }
- }
+ ## 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
}
-
- ## 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) {
-
- ## 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 {
+ ## 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))
}
- 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.")
- }
- }
+ if(diffNr < 0 && missing.data != "OK") {
+ msg <- paste("There are", abs(diffNr), "missing rows.")
+ switch(missing.data,
+ warn = warning(msg),
+ fail = stop(msg))
+ }
+ tmpDt <- dt[1:min(nrow(dt), nr) ,, drop = FALSE]
}
+
+ tmpDt
}
+
attachData <- function(object,
label.type=c("row.names","column"),
label.column=1,
Modified: branches/fm-branch/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2009-06-25 21:49:54 UTC (rev 445)
+++ branches/fm-branch/R/class-phylo4.R 2009-07-07 23:04:13 UTC (rev 446)
@@ -19,6 +19,59 @@
validity = checkPhylo4)
#####################
+## Labels constructor
+#####################
+
+.createLabels <- function(value, ntips, nnodes, use.names = TRUE,
+ which = c("tip", "internal")) {
+
+ 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
+ names(res) <- switch(which,
+ tip = 1:ntips,
+ internal = seq(from=ntips+1, length=lgthRes),
+ allnode = 1:(ntips+nnodes))
+
+
+ ## if value is NULL
+ if(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 not only numbers
+ ##if(length(grep("[a-zA-Z]", value)) == 0)
+ ## stop("Labels need to contain characters. ",
+ ## "They can't just be numerical values")
+
+ ## 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
+}
+
+#####################
## phylo4 constructor
#####################
@@ -59,51 +112,34 @@
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)
+ ## tip.label
+ tip.label <- .createLabels(value=tip.label, ntips=ntips, nnodes=nnodes,
+ which="tip")
-
## 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")
-
## fill in the result
res <- new("phylo4")
res at edge <- edge
res at edge.length <- edge.length
res at Nnode <- nnodes
res at tip.label <- tip.label
- res at node.label <- node.label
+ res at node.label <- .createLabels(node.label, ntips=ntips, nnodes=nnodes,
+ which="internal")
res at edge.label <- edge.label
res at order <- order
## checkPhylo4 will return a character string if object is
## bad, otherwise TRUE
if (is.character(checkval <- checkPhylo4(res))) stop(checkval)
-
return(res)
})
Modified: branches/fm-branch/R/class-phylo4d.R
===================================================================
--- pkg/R/class-phylo4d.R 2009-06-25 21:49:54 UTC (rev 445)
+++ branches/fm-branch/R/class-phylo4d.R 2009-07-07 23:04:13 UTC (rev 446)
@@ -27,108 +27,158 @@
setGeneric("phylo4d", function(x, ...) { standardGeneric("phylo4d")} )
## first arg is a phylo4
+### phylo4d class rewrite
setMethod("phylo4d", "phylo4",
- function(x, tip.data = NULL, node.data = NULL, all.data = NULL,
- merge.tip.node = TRUE, ...) {
+ 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 <- deparseSubstitute(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
+ ## Creating new phylo4d object
+ 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
- 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)
+ ## Replacing node labels by node numbers and formatting the data to make sure
+ ## they have the correct dimensions
+ if(!is.null(all.data))
+ all.data <- formatData(x, all.data, which="all",
+ 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(tip.data))
+ tip.data <- formatData(x, tip.data, which="tip",
+ 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]
- res at node.data <- tmpData[-(1:nTips(x)) ,, drop = FALSE]
- }
- }
- else {
- ## at this point provide NULL data frame for empty arguments
- if(is.null(tip.data)) tip.data <- data.frame(NULL)
- if(is.null(node.data)) node.data <- data.frame(NULL)
+ if(!is.null(node.data)) {
+ node.data <- formatData(x, node.data, which="internal",
+ match.data=match.data, ...)
+ }
- res at tip.data <- tip.data
- res at node.data <- node.data
- }
- }
+ ## Merging datasets
+ if(!is.null(all.data)) {
+ tmpData <- all.data
+ if(!is.null(tip.data)) {
+ emptyNodeData <- array(, dim = c(nNodes(x), ncol(tip.data)),
+ dimnames = list(nodeId(x, "internal"),
+ colnames(tip.data)))
+ tmpTipData <- rbind(tip.data, emptyNodeData)
- checkData(res, ...)
- res <- attachData(res,...)
- return(res)
+ 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(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)
+ }
+ if(match.data) {
+ res at tip.data <- tmpData[rownames(tmpData) %in% nodeId(x, "tip") ,,
+ drop = FALSE]
+ res at node.data <- tmpData[rownames(tmpData) %in% nodeId(x, "internal") ,,
+ drop = FALSE]
+ }
+ else {
+ res at tip.data <- tmpData[1:nTips(x) ,, drop=FALSE]
+ res at node.data <- tmpData[-(1:nTips(x)) ,, drop=FALSE]
+ }
+
+ }
+
+ else {
+ if(!is.null(tip.data) && !is.null(node.data)) {
+ if(identical(colnames(tip.data), colnames(node.data)) && merge.data) {
+ tmpAllData <- rbind(tip.data, node.data)
+ res at tip.data <- tmpAllData[rownames(tmpAllData) %in%
+ nodeId(x, "tip") ,, drop=FALSE]
+ res at 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]
+
+ tmpData <- cbind(tmpTipData, tmpNodeData)
+
+ if(match.data) {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 446
More information about the Phylobase-commits
mailing list