[Phylobase-commits] r449 - branches/fm-branch/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 17 17:25:39 CEST 2009
Author: francois
Date: 2009-07-17 17:25:35 +0200 (Fri, 17 Jul 2009)
New Revision: 449
Added:
branches/fm-branch/R/checkData.R
branches/fm-branch/R/updatePhylo4.R
Log:
added new files that were missing since creation of branch
Added: branches/fm-branch/R/checkData.R
===================================================================
--- branches/fm-branch/R/checkData.R (rev 0)
+++ branches/fm-branch/R/checkData.R 2009-07-17 15:25:35 UTC (rev 449)
@@ -0,0 +1,275 @@
+###
+### Deprecated code, phylo4d constructor now uses formatData
+###
+
+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"),
+ ...)
+{
+
+ ## 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]
+ }
+
+ ## 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)
+
+ ## 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)
+
+ ## 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)
+
+ ## for each set of data, check for names, missing and extra data and take appropriate actions
+
+ ## 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 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.")
+ }
+ }
+
+ ## 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.")
+ }
+ }
+ }
+
+ ## 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
+ {
+ ##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.")
+ }
+ }
+ }
+}
Added: branches/fm-branch/R/updatePhylo4.R
===================================================================
--- branches/fm-branch/R/updatePhylo4.R (rev 0)
+++ branches/fm-branch/R/updatePhylo4.R 2009-07-17 15:25:35 UTC (rev 449)
@@ -0,0 +1,26 @@
+updatePhylo4 <- function(phy, ...) {
+ ## Add internal names for tip labels
+ if(is.null(names(phy at tip.label))) {
+ if(length(phy at tip.label == nTips(phy))) {
+ names(phy at tip.label) <- nodeId(phy, "tip")
+ }
+ else stop("You have a problem with your tip labels")
+ }
+
+ ## Add internal names for node labels
+ if(is.null(names(phy at node.label))) {
+ if(length(phy at node.label) == nNodes(phy)) {
+ names(phy at node.label) <- nodeId(phy, "internal")
+ }
+ else stop("You have a problem with your node labels.")
+ }
+
+ ## Add internal names for edge lengths
+ if(hasEdgeLength(phy) && is.null(names(phy at edge.length))) {
+ names(phy at edge.length) <- paste(phy at edge[,1], phy at edge[,2], sep="-")
+ }
+
+ if(is.character(msg <- checkPhylo4(phy))) stop(msg)
+ else return(phy)
+
+}
Property changes on: branches/fm-branch/R/updatePhylo4.R
___________________________________________________________________
Name: svn:executable
+ *
More information about the Phylobase-commits
mailing list