[Phylobase-commits] r604 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Aug 28 01:06:16 CEST 2009
Author: francois
Date: 2009-08-28 01:06:16 +0200 (Fri, 28 Aug 2009)
New Revision: 604
Added:
pkg/R/formatData.R
Modified:
pkg/R/checkdata.R
pkg/R/class-phylo4.R
pkg/R/methods-phylo4d.R
pkg/R/phylo4.R
Log:
put formatData on its own page, removed unnecessary ..., added signature in description of some phylo4d methods
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2009-08-27 23:05:00 UTC (rev 603)
+++ pkg/R/checkdata.R 2009-08-27 23:06:16 UTC (rev 604)
@@ -203,121 +203,3 @@
return(TRUE)
}
-
-
-
-formatData <- function(phy, dt, type=c("tip", "internal", "all"),
- match.data=TRUE, rownamesAsLabels=FALSE,
- label.type=c("rownames", "column"),
- label.column=1, missing.data=c("fail", "warn", "OK"),
- extra.data=c("warn", "OK", "fail")
- ) {
-
- type <- match.arg(type)
- label.type <- match.arg(label.type)
- stopifnot(label.column %in% 1:ncol(dt))
- missing.data <- match.arg(missing.data)
- extra.data <- match.arg(extra.data)
-
- nr <- switch(type,
- tip = nTips(phy),
- internal = nNodes(phy),
- all = nTips(phy)+nNodes(phy))
-
- tmpDt <- array(, dim=c(nr, ncol(dt)),
- dimnames=list(nodeId(phy, type), colnames(dt)))
- tmpDt <- data.frame(tmpDt)
-
- 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 && !rownamesAsLabels)
- 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(type != "all") {
- switch(type,
- 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 ",
- "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 ",
- "nodes. Make sure that your data identifiers ",
- "are correct.")
- })
- }
-
- ## Check differences
- extra <- names(ndDt[is.na(ndDt)])
- mssng <- nodeId(phy, type)[! nodeId(phy, type) %in% ndDt]
-
- if(length(mssng) > 0 && missing.data != "OK") {
- msg <- "The following nodes are not found in the dataset: "
-
- ## 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)
- })
-
- msg <- paste(msg, paste(mssng, collapse=", "))
- switch(missing.data,
- warn = warning(msg),
- fail = stop(msg))
- }
-
- 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))
-
- }
- ## 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[,] <- dt[match(rownames(tmpDt), rownames(dt)) ,, drop=FALSE]
- }
- else {
- ## Remove rownames in data provided
- rownames(dt) <- NULL
-
- ## Tips before internal nodes for all.data
- if (type == "all")
- rownames(tmpDt) <- 1:nr
-
- ## 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))
- }
- 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
-}
Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2009-08-27 23:05:00 UTC (rev 603)
+++ pkg/R/class-phylo4.R 2009-08-27 23:06:16 UTC (rev 604)
@@ -106,7 +106,7 @@
## first arg is a matrix
setMethod("phylo4", "matrix",
function(x, edge.length = NULL, tip.label = NULL, node.label = NULL,
- edge.label = NULL, order="unknown", annote = list(), ...) {
+ edge.label = NULL, order="unknown", annote = list()) {
## edge
edge <- x
Added: pkg/R/formatData.R
===================================================================
--- pkg/R/formatData.R (rev 0)
+++ pkg/R/formatData.R 2009-08-27 23:06:16 UTC (rev 604)
@@ -0,0 +1,115 @@
+formatData <- function(phy, dt, type=c("tip", "internal", "all"),
+ match.data=TRUE, rownamesAsLabels=FALSE,
+ label.type=c("rownames", "column"),
+ label.column=1, missing.data=c("fail", "warn", "OK"),
+ extra.data=c("warn", "OK", "fail")
+ ) {
+
+ type <- match.arg(type)
+ label.type <- match.arg(label.type)
+ stopifnot(label.column %in% 1:ncol(dt))
+ missing.data <- match.arg(missing.data)
+ extra.data <- match.arg(extra.data)
+
+ nr <- switch(type,
+ tip = nTips(phy),
+ internal = nNodes(phy),
+ all = nTips(phy)+nNodes(phy))
+
+ tmpDt <- array(, dim=c(nr, ncol(dt)),
+ dimnames=list(nodeId(phy, type), colnames(dt)))
+ tmpDt <- data.frame(tmpDt)
+
+ 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 && !rownamesAsLabels)
+ 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(type != "all") {
+ switch(type,
+ 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 ",
+ "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 ",
+ "nodes. Make sure that your data identifiers ",
+ "are correct.")
+ })
+ }
+
+ ## Check differences
+ extra <- names(ndDt[is.na(ndDt)])
+ mssng <- nodeId(phy, type)[! nodeId(phy, type) %in% ndDt]
+
+ if(length(mssng) > 0 && missing.data != "OK") {
+ msg <- "The following nodes are not found in the dataset: "
+
+ ## 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)
+ })
+
+ msg <- paste(msg, paste(mssng, collapse=", "))
+ switch(missing.data,
+ warn = warning(msg),
+ fail = stop(msg))
+ }
+
+ 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))
+
+ }
+ ## 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[,] <- dt[match(rownames(tmpDt), rownames(dt)) ,, drop=FALSE]
+ }
+ else {
+ ## Remove rownames in data provided
+ rownames(dt) <- NULL
+
+ ## Tips before internal nodes for all.data
+ if (type == "all")
+ rownames(tmpDt) <- 1:nr
+
+ ## 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))
+ }
+ 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
+}
Modified: pkg/R/methods-phylo4d.R
===================================================================
--- pkg/R/methods-phylo4d.R 2009-08-27 23:05:00 UTC (rev 603)
+++ pkg/R/methods-phylo4d.R 2009-08-27 23:06:16 UTC (rev 604)
@@ -114,10 +114,11 @@
tdata
})
-setReplaceMethod("tdata", "phylo4d",
- function(object, type = c("tip", "internal", "allnode"), ...,
+setReplaceMethod("tdata", signature(x="phylo4d", value="ANY"),
+ function(x, type = c("tip", "internal", "allnode"), ...,
value) {
type <- match.arg(type)
+ object <- x
## Removes existing data, just keeps the tree (as a phylo4d)
object <- extractTree(object)
@@ -230,14 +231,16 @@
invisible(res)
})
-setMethod("hasNodeData", "phylo4d", function(x) {
- nrow(x at node.data) > 0
-})
-setMethod("hasTipData", "phylo4d", function(x) {
+setMethod("hasTipData", signature(x="phylo4d"), function(x) {
nrow(x at tip.data) > 0
})
+setMethod("hasNodeData", signature(x="phylo4d"), function(x) {
+ nrow(x at node.data) > 0
+})
+
+
## FIXME: doesn't deal with missing node data
## (don't even know how that should be done in this case)
setMethod("na.omit", "phylo4d", function(object, ...) {
Modified: pkg/R/phylo4.R
===================================================================
--- pkg/R/phylo4.R 2009-08-27 23:05:00 UTC (rev 603)
+++ pkg/R/phylo4.R 2009-08-27 23:06:16 UTC (rev 604)
@@ -106,7 +106,7 @@
standardGeneric("tdata")
})
-setGeneric("tdata<-", function(object, ..., value) {
+setGeneric("tdata<-", function(x, ..., value) {
standardGeneric("tdata<-")
})
More information about the Phylobase-commits
mailing list