[Phylobase-commits] r405 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 26 21:48:45 CET 2008
Author: francois
Date: 2008-12-26 21:48:45 +0100 (Fri, 26 Dec 2008)
New Revision: 405
Modified:
pkg/DESCRIPTION
pkg/R/checkdata.R
pkg/R/methods-phylo4.R
pkg/R/methods-phylo4d.R
pkg/R/setAs-Methods.R
Log:
labels <- now changes labels for associated data as well, fixed print method by matching node names with data, enforce unique names for nodes (at least temporarily)
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2008-12-26 16:50:59 UTC (rev 404)
+++ pkg/DESCRIPTION 2008-12-26 20:48:45 UTC (rev 405)
@@ -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 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
+Collate: phylo4.R checkdata.R class-multiphylo4.R class-oldclasses.R class-phylo4.R class-phylo4d.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
Encoding: UTF-8
URL: http://phylobase.R-forge.R-project.org
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2008-12-26 16:50:59 UTC (rev 404)
+++ pkg/R/checkdata.R 2008-12-26 20:48:45 UTC (rev 405)
@@ -10,7 +10,7 @@
if (hasEdgeLength(object)) {
if (length(object at edge.length) != nedges)
return("edge lengths do not match number of edges")
- ## presumably we shouldn't allow NAs mixed
+ ## presumably we shouldn't allow NAs mixed
## with numeric branch lengths except at the root
if (sum(is.na(object at edge.length)) > 1)
return("NAs in edge lenghts")
@@ -39,11 +39,11 @@
if (!all(nDesc[1:nTips]==0))
return("nodes 1 to nTips must all be tips")
#nRoots <- sum(nAncest==0)
- ## no longer
+ ## no longer
##if (which(nAncest==0)!=nTips+1) {
## return("root node is not at position (nTips+1)")
##}
-
+
if (nRoots>0) {
if (sum(is.na(E[,1]))!=1) {
return("for a rooted tree, edge matrix must contain (exactly one) explicit root edge with ancestor==NA")
@@ -75,6 +75,13 @@
paste(phylo4_orderings,collapse=","))
}
+ ## make sure that tip and node labels are unique
+ lb <- labels(object, "all")
+ lb <- lb[nchar(lb) > 0]
+ lb <- na.omit(lb)
+ if(any(table(lb) > 1))
+ stop("All labels must be unique")
+
## all done with fatal errors. Now construct a list
## of warnings and paste them together
msg <- character(0)
@@ -171,10 +178,12 @@
if(any(nU <- tipsTable > 1)) {
nonUnique <- paste(names(tipsTable[nU]), collapse=", ")
nonUniqueMsg <- paste("Tip \'", nonUnique, "\' not unique", sep = "")
- if(non.unique.tips == "fail")
+ ## 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)
+ ## if(non.unique.tips == "warn")
+ ## warning(nonUniqueMsg)
}
}
}
@@ -283,9 +292,11 @@
if(any(nU <- nodesTable > 1)) {
nonUnique <- paste(names(nodesTable[nU]), collapse=", ")
nonUniqueMsg <- paste("Node \'", nonUnique, "\' not unique", sep = "")
- if(non.unique.nodes == "fail")
+ ## 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")
+ ## if(non.unique.nodes == "warn")
warning(nonUniqueMsg)
}
}
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2008-12-26 16:50:59 UTC (rev 404)
+++ pkg/R/methods-phylo4.R 2008-12-26 20:48:45 UTC (rev 405)
@@ -143,6 +143,62 @@
)
})
+setReplaceMethod("labels",
+ signature(object="phylo4", value="character"),
+ function(object, which = c("tip", "node", "allnode"), ..., value) {
+ which <- match.arg(which)
+ tipOrder <- order(nodeId(object, "tip"))
+ intOrder <- order(nodeId(object, "internal"))
+ ob <- switch(which,
+ ## If 'tip'
+ tip = {
+ if(length(value) != nTips(object))
+ stop("Number of tip labels does not match number of tips.")
+ else {
+ object at tip.label[tipOrder] <- value
+ if(identical(class(object), "phylo4d") &&
+ nrow(object at tip.data) > 0)
+ rownames(object at tip.data)[tipOrder] <- value
+ object
+ }
+ },
+ ## If 'node'
+ node = {
+ if(length(value) != nNodes(object))
+ stop("Number of node labels does not match number of internal nodes.")
+ else {
+ object at node.label[intOrder] <- value
+ if(identical(class(object), "phylo4d") &&
+ nrow(object at node.data) > 0) {
+ rownames(object at node.data)[intOrder] <- value
+ }
+ object
+ }
+ },
+ ## If 'allnode'
+ allnode = {
+ if(length(value) != nEdges(object))
+ stop("Number of labels does not match total number of nodes.")
+ else {
+ object at tip.label[tipOrder] <- value[1:nTips(object)]
+ if(identical(class(object), "phylo4d") &&
+ nrow(object at tip.data) > 0)
+ rownames(object at tip.data)[tipOrder] <-
+ value[1:nTips(object)]
+ object at node.label[intOrder] <- value[-(1:nTips(object))]
+ if(identical(class(object), "phylo4d") &&
+ nrow(object at node.data) > 0)
+ rownames(object at node.data)[intOrder] <-
+ value[-(1:nTips(object))]
+ object
+ }
+ })
+ if(is.character(checkval <- check_phylo4(ob)))
+ stop(checkval)
+ else
+ return(ob)
+ })
+
setMethod("nodeLabels", "phylo4", function(object) {
#x at node.label
labels(object, which="node")
@@ -275,7 +331,7 @@
print(res$degree)
cat("\n")
cat("Types of polytomy:\n")
- print(res$npolytomy)
+ print(res$polytomy)
cat("\n")
}
@@ -303,42 +359,8 @@
length(x at edge.length)>0
})
-setReplaceMethod("labels",
- signature(object="phylo4", value="character"),
- function(object, which = c("tip", "node", "allnode"), ..., value) {
- which <- match.arg(which)
- switch(which,
- ## If 'tip'
- tip = {
- if(length(value) != nTips(object))
- stop("Number of tip labels does not match number of tips.")
- else {
- object at tip.label[order(nodeId(object, "tip"))] <- value
- return(object)
- }
- },
- ## If 'node'
- node = {
- if(length(value) != nNodes(object))
- stop("Number of node labels does not match number of internal nodes.")
- else {
- #object at node.label <- character(nNodes(object))
- object at node.label[order(nodeId(object, "internal"))] <- value
- return(object)
- }
- },
- ## If 'allnode'
- allnode = {
- if(length(value) != nEdges(object))
- stop("Number of labels does not match total number of nodes.")
- else {
- object at tip.label[order(nodeId(object, "tip"))] <- value[1:nTips(object)]
- object at node.label[order(nodeId(object, "internal"))] <- value[-(1:nTips(object))]
- return(object)
- }
- })
- })
+
orderIndex <- function(phy, order = c('preorder', 'postorder')) {
## recursive functions are placed first and calls to those functions below
postOrder <- function(node) {
Modified: pkg/R/methods-phylo4d.R
===================================================================
--- pkg/R/methods-phylo4d.R 2008-12-26 16:50:59 UTC (rev 404)
+++ pkg/R/methods-phylo4d.R 2008-12-26 20:48:45 UTC (rev 405)
@@ -60,9 +60,11 @@
if (which == "allnode") {
if (all(dim(x at node.data)==0)) { ## empty data
if (!hasNodeLabels(x)) {
- nodedata <- data.frame(label=rep("",nNodes(x)))
+ nd <- character(nNodes(x))
+ is.na(nd) <- TRUE
+ nodedata <- data.frame(label=nd)
} else
- nodedata <- data.frame(label=x at node.label)
+ nodedata <- data.frame(label=nodeLabels(x))
}
else {
nodedata <- tdata(x, "node", label.type="column")
Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R 2008-12-26 16:50:59 UTC (rev 404)
+++ pkg/R/setAs-Methods.R 2008-12-26 20:48:45 UTC (rev 405)
@@ -67,15 +67,15 @@
rootpos <- which(nodeId(from, "all") == rootNode(from))
if (isRooted(from)) brlen <- brlen[-rootpos]
edgemat <- unname(from at edge[-rootpos, ])
- y <- list(edge = edgemat,
- Nnode = from at Nnode,
- tip.label = from at tip.label,
- edge.length = brlen,
- node.label = from at node.label)
+ y <- list(edge = edgemat,
+ Nnode = from at Nnode,
+ tip.label = from at tip.label,
+ edge.length = brlen,
+ node.label = from at node.label)
class(y) <- "phylo"
if (from at order != 'unknown') {
## TODO postorder != pruningwise -- though quite similar
- attr(y, 'order') <- switch(from at order, postorder = 'pruningwise',
+ attr(y, 'order') <- switch(from at order, postorder = 'pruningwise',
preorder = 'cladewise')
}
if (length(y$edge.length) == 0)
@@ -89,7 +89,7 @@
y
})
-## BMB: redundant????
+## BMB: redundant????
## setAs("phylo4d", "phylo", function(from, to) {
## y <- list(edge = from at edge, edge.length = from at edge.length,
## Nnode = from at Nnode, tip.label = from at tip.label)
@@ -184,11 +184,19 @@
})
setAs(from = "phylo4d", to = "data.frame", function(from) {
- ## TODO we need some test to ensure data and tree are in the right order
+
tree <- extractTree(from) ## as(from, "phylo4") # get tree
t_df <- as(tree, "data.frame") # convert to data.frame
+
dat <- tdata(from, "allnode", label.type="column") # get data
- tdat <- cbind(t_df, dat[ ,-1 , drop=FALSE])
- #tdat <- dat[,-1,drop=FALSE]
+ if(nrow(dat) > 0 && ncol(dat) > 1) {
+ dat <- dat[match(t_df$label, dat$label), ]
+ tdat <- cbind(t_df, dat[ ,-1 , drop=FALSE])
+ }
+ else {
+ tdat <- t_df
+ cat("No data associated with the tree\n")
+ }
+
return(tdat)
})
More information about the Phylobase-commits
mailing list