[Phylobase-commits] r447 - branches/fm-branch/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 15 23:48:25 CEST 2009
Author: francois
Date: 2009-07-15 23:48:24 +0200 (Wed, 15 Jul 2009)
New Revision: 447
Modified:
branches/fm-branch/R/class-phylo4.R
branches/fm-branch/R/class-phylo4d.R
branches/fm-branch/R/methods-phylo4d.R
Log:
Made error message more explicit; split part of phylo4d that was dealing with data, so it can used by tdata<-; cleaning up code of tdata
Modified: branches/fm-branch/R/class-phylo4.R
===================================================================
--- branches/fm-branch/R/class-phylo4.R 2009-07-07 23:04:13 UTC (rev 446)
+++ branches/fm-branch/R/class-phylo4.R 2009-07-15 21:48:24 UTC (rev 447)
@@ -90,7 +90,9 @@
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")
Modified: branches/fm-branch/R/class-phylo4d.R
===================================================================
--- branches/fm-branch/R/class-phylo4d.R 2009-07-07 23:04:13 UTC (rev 446)
+++ branches/fm-branch/R/class-phylo4d.R 2009-07-15 21:48:24 UTC (rev 447)
@@ -26,11 +26,9 @@
## generic
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,
- match.data=TRUE, merge.data=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, ...) {
## Make sure that data provided are a data frame
classData <- function(someData) {
@@ -53,14 +51,6 @@
tip.data <- classData(tip.data)
node.data <- classData(node.data)
- ## 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
## Replacing node labels by node numbers and formatting the data to make sure
## they have the correct dimensions
@@ -72,12 +62,11 @@
tip.data <- formatData(x, tip.data, which="tip",
match.data=match.data, ...)
- if(!is.null(node.data)) {
+ if(!is.null(node.data))
node.data <- formatData(x, node.data, which="internal",
match.data=match.data, ...)
- }
- ## Merging datasets
+ ## Merging dataset
if(!is.null(all.data)) {
tmpData <- all.data
if(!is.null(tip.data)) {
@@ -103,14 +92,14 @@
}
if(match.data) {
- res at tip.data <- tmpData[rownames(tmpData) %in% nodeId(x, "tip") ,,
+ tip.data <- tmpData[rownames(tmpData) %in% nodeId(x, "tip") ,,
drop = FALSE]
- res at node.data <- tmpData[rownames(tmpData) %in% nodeId(x, "internal") ,,
+ 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]
+ tip.data <- tmpData[1:nTips(x) ,, drop=FALSE]
+ node.data <- tmpData[-(1:nTips(x)) ,, drop=FALSE]
}
}
@@ -119,9 +108,9 @@
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%
+ tip.data <- tmpAllData[rownames(tmpAllData) %in%
nodeId(x, "tip") ,, drop=FALSE]
- res at node.data <- tmpAllData[rownames(tmpAllData) %in%
+ node.data <- tmpAllData[rownames(tmpAllData) %in%
nodeId(x, "internal") ,, drop=FALSE]
}
else {
@@ -138,14 +127,14 @@
tmpData <- cbind(tmpTipData, tmpNodeData)
if(match.data) {
- res at tip.data <- tmpData[rownames(tmpData) %in%
+ tip.data <- tmpData[rownames(tmpData) %in%
nodeId(x, "tip") ,, drop=FALSE]
- res at node.data <- tmpData[rownames(tmpData) %in%
+ 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]
+ tip.data <- tmpData[1:nTips(x) ,, drop=FALSE]
+ node.data <- tmpData[-(1:nTips(x)) ,, drop=FALSE]
}
}
}
@@ -154,11 +143,37 @@
if(is.null(tip.data)) tip.data <- data.frame(NULL)
if(is.null(node.data)) node.data <- data.frame(NULL)
- res at tip.data <- tip.data
- res at node.data <- node.data
+ tip.data <- tip.data
+ node.data <- node.data
}
}
+ return(list(tip.data=tip.data, node.data=node.data))
+}
+
+
+## first arg is a phylo4
+### phylo4d class rewrite
+setMethod("phylo4d", "phylo4",
+ function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
+ match.data=TRUE, merge.data=TRUE, ...) {
+
+ ## 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
+
+ ## taking care of the data
+ tmpData <- .phylo4Data(x, tip.data, node.data, all.data, match.data,
+ merge.data, ...)
+
+ res at tip.data <- tmpData$tip.data
+ res at node.data <- tmpData$node.data
+
return(res)
})
Modified: branches/fm-branch/R/methods-phylo4d.R
===================================================================
--- branches/fm-branch/R/methods-phylo4d.R 2009-07-07 23:04:13 UTC (rev 446)
+++ branches/fm-branch/R/methods-phylo4d.R 2009-07-15 21:48:24 UTC (rev 447)
@@ -2,75 +2,77 @@
setMethod("show", "phylo4d", function(object) printphylo4(object))
-setMethod("tdata", "phylo4d", function(x, which = c("tip",
- "internal", "allnode"), label.type=c("row.names","column"), ...) {
- which <- match.arg(which)
- label.type <- match.arg(label.type)
+setMethod("tdata", "phylo4d",
+ function(x, which = c("tip", "internal", "allnode"),
+ label.type=c("row.names","column"), ...) {
- ## FIXME: should have no labels in this case?
- if (!hasNodeLabels(x) && which=="internal" && missing(label.type)) { }
+ ## Returns data associated with the tree
+ ## Note: the function checks for unique labels. It's currently unecessary
+ ## but could be useful in the future if non-unique labels are allowed.
- if (which == "tip") {
- if (all(dim(x at tip.data)==0)) {
- return(x at tip.data)
- }
- tdata <- x at tip.data
- data.names <- tipLabels(x)
- if ( identical(label.type,"row.names") ) {
- if ( identical(data.names,unique(data.names)) ||
- !(any(is.na(data.names))) ) {
- row.names(tdata) <- data.names
+ which <- match.arg(which)
+ label.type <- match.arg(label.type)
+
+ if (which == "tip") {
+ if (all(dim(x at tip.data) == 0)) {
+ return(x at tip.data)
+ }
+ tdata <- x at tip.data
+ data.names <- tipLabels(x)
+ if ( identical(label.type, "row.names") ) {
+ if ( identical(data.names, unique(data.names)) ||
+ !(any(is.na(data.names))) ) {
+ row.names(tdata) <- data.names
}
- else {
- warning("Non-unique or missing labels found, ",
+ else {
+ warning("Non-unique or missing labels found, ",
"labels cannot be coerced to tdata row.names. ",
- "Use the label.type argument to include labels ",
- "as first column of data.")
+ "Use the label.type argument to include labels ",
+ "as first column of data.")
}
- }
- if (identical(label.type,"column")) {
- tdata <- data.frame(label=data.names,tdata)
- }
- return(tdata)
- }
+ }
+ if (identical(label.type,"column")) {
+ tdata <- data.frame(label=data.names,tdata)
+ }
+ return(tdata)
+ }
- if (which == "internal") {
- if (all(dim(x at node.data)==0)) {
- return(x at node.data)
- }
- tdata <- x at node.data
- if(hasNodeLabels(x))
- data.names <- nodeLabels(x)
- else
- data.names <- nodeId(x, "internal")
+ if (which == "internal") {
+ if (all(dim(x at node.data)==0)) {
+ return(x at node.data)
+ }
+ tdata <- x at node.data
+ if(hasNodeLabels(x))
+ data.names <- nodeLabels(x)
+ else
+ data.names <- nodeId(x, "internal")
- if ( identical(label.type,"row.names") ) {
- if ( length(data.names)>0 &&
- !any(duplicated(data.names)) &&
- !(any(is.na(data.names)))) {
- row.names(tdata) <- data.names
- } else {
- warning("Non-unique or missing labels found, ",
- "labels cannot be coerced to tdata row.names. ",
- "Use the label.type argument to include labels ",
- "as first column of data.")
- }
- }
- if (identical(label.type,"column")) {
- if (!hasNodeLabels(x)) data.names <- rep("",nNodes(x))
- tdata <- data.frame(label=data.names,tdata)
- }
- return(tdata)
- }
+ if ( identical(label.type,"row.names") ) {
+ if ( length(data.names)>0 &&
+ !any(duplicated(data.names)) &&
+ !(any(is.na(data.names)))) {
+ row.names(tdata) <- data.names
+ } else {
+ warning("Non-unique or missing labels found, ",
+ "labels cannot be coerced to tdata row.names. ",
+ "Use the label.type argument to include labels ",
+ "as first column of data.")
+ }
+ }
+ if (identical(label.type,"column")) {
+ if (!hasNodeLabels(x)) data.names <- rep("",nNodes(x))
+ tdata <- data.frame(label=data.names,tdata)
+ }
+ return(tdata)
+ }
- if (which == "allnode") {
-
- if (all(dim(x at node.data)==0)) { ## empty data
- if (!hasNodeLabels(x)) {
- nd <- character(nNodes(x))
- is.na(nd) <- TRUE
- nodedata <- data.frame(label=nd)
- } else
+ if (which == "allnode") {
+ if (all(dim(x at node.data)==0)) { ## empty data
+ if (!hasNodeLabels(x)) {
+ nd <- character(nNodes(x))
+ is.na(nd) <- TRUE
+ nodedata <- data.frame(label=nd)
+ } else
nodedata <- data.frame(label=nodeLabels(x))
}
else {
More information about the Phylobase-commits
mailing list