[Phylobase-commits] r451 - branches/fm-branch/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Aug 1 02:02:23 CEST 2009
Author: pdc
Date: 2009-08-01 02:02:21 +0200 (Sat, 01 Aug 2009)
New Revision: 451
Removed:
branches/fm-branch/R/checkData.R
Log:
Delete problematically named file
Deleted: branches/fm-branch/R/checkData.R
===================================================================
--- branches/fm-branch/R/checkData.R 2009-07-31 14:49:36 UTC (rev 450)
+++ branches/fm-branch/R/checkData.R 2009-08-01 00:02:21 UTC (rev 451)
@@ -1,275 +0,0 @@
-###
-### 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.")
- }
- }
- }
-}
More information about the Phylobase-commits
mailing list