[Phylobase-commits] r415 - in pkg: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Dec 31 20:27:51 CET 2008
Author: bbolker
Date: 2008-12-31 20:27:51 +0100 (Wed, 31 Dec 2008)
New Revision: 415
Modified:
pkg/R/class-phylo4.R
pkg/R/class-phylo4d.R
pkg/R/methods-phylo4.R
pkg/R/methods-phylo4d.R
pkg/R/setAs-Methods.R
pkg/R/treePlot.R
pkg/man/prune-methods.Rd
pkg/man/subset-methods.Rd
Log:
change convention to leave node data and labels in nodeId order,
even when edge matrix changes order; a few trivial typo fixes as well
Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/R/class-phylo4.R 2008-12-31 19:27:51 UTC (rev 415)
@@ -49,7 +49,7 @@
if(length(tip.label) != ntips) stop("the tip labels are not consistent with the number of tips")
tip.label <- as.character(tip.label)
}
-
+ names(tip.label) <- seq(along=tip.label)
## node.label for internal nodes
nnodes <- length(unique(na.omit(c(edge)))) - ntips
## if(is.null(node.label)) {
@@ -61,6 +61,7 @@
## is.na(node.label) <- TRUE ## ???
} else if (length(node.label)>0 && length(node.label) != nnodes)
stop("number of node labels is not consistent with the number of nodes")
+ names(node.label) <- seq(along=node.label)
## edge.label
## an edge is named by the descendant
if(is.null(edge.label)) {
Modified: pkg/R/class-phylo4d.R
===================================================================
--- pkg/R/class-phylo4d.R 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/R/class-phylo4d.R 2008-12-31 19:27:51 UTC (rev 415)
@@ -27,7 +27,7 @@
setGeneric("phylo4d", function(x, ...) { standardGeneric("phylo4d")} )
## first arg is a phylo4
-setMethod("phylo4d", c("phylo4"),
+setMethod("phylo4d", "phylo4",
function(x, tip.data = NULL, node.data = NULL, all.data = NULL,
merge.tip.node = TRUE, ...) {
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/R/methods-phylo4.R 2008-12-31 19:27:51 UTC (rev 415)
@@ -116,10 +116,10 @@
"internal", "allnode"), ...) {
which <- match.arg(which)
switch(which,
- tip = object at tip.label[order(nodeId(object,"tip"))],
+ tip = object at tip.label, ## [order(nodeId(object,"tip"))],
internal = {
if (hasNodeLabels(object)) {
- object at node.label[order(nodeId(object))]
+ object at node.label ## [order(nodeId(object))]
}
else
{
@@ -137,8 +137,8 @@
}
## lorder <- match(object at edge[,2],
## c(nodeId(object,"tip"),nodeId(object)))
- lorder <- order(c(nodeId(object,"tip"),nodeId(object)))
- c(object at tip.label,nl)[lorder]
+ ## lorder <- order(c(nodeId(object,"tip"),nodeId(object)))
+ c(object at tip.label,nl) ## [lorder]
}
)
})
@@ -260,7 +260,6 @@
setMethod("show", "phylo4", function(object) printphylo4(object))
##
-
#################
## summary phylo4
#################
@@ -359,7 +358,45 @@
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
+ object at node.label <- value
+ return(object)
+ }
+ },
+ ## If 'allnode'
+ allnode = {
+ if(length(value) != nNodes(object)+nTips(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))]
+ object at tip.label <- value[1:nTips(object)]
+ object at node.label <- value[-(1:nTips(object))]
+ return(object)
+ }
+ })
+ })
orderIndex <- function(phy, order = c('preorder', 'postorder')) {
## recursive functions are placed first and calls to those functions below
Modified: pkg/R/methods-phylo4d.R
===================================================================
--- pkg/R/methods-phylo4d.R 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/R/methods-phylo4d.R 2008-12-31 19:27:51 UTC (rev 415)
@@ -76,11 +76,12 @@
tipdata <- tdata(x, "tip", label.type="column")
}
- data.names <- c(as.character(nodedata$label),as.character(tipdata$label))
- tipdata$label <- (x at Nnode+1):(x at Nnode+length(x at tip.label))
- nodedata$label <- 1:x at Nnode
+ data.names <- c(as.character(tipdata$label),
+ as.character(nodedata$label))
+ tipdata$label <- sort(nodeId(x,"tip"))
+ nodedata$label <- sort(nodeId(x,"internal"))
## FIXME - kludgy merge and subsequent cleanup - make robust
- tdata <- merge(nodedata,tipdata, all=TRUE,sort=FALSE)[,-1,drop=FALSE]
+ tdata <- merge(tipdata, nodedata, all=TRUE,sort=FALSE)[,-1,drop=FALSE]
tdata <- data.frame(label=data.names,tdata)
if ( identical(label.type,"row.names") ) {
@@ -185,8 +186,9 @@
index <- orderIndex(x, order)
x at order <- order
x at edge <- x at edge[index, ]
- x at tip.data <- x at tip.data[index[index <= nTips(x)], , drop = FALSE]
- x at node.data <- x at node.data[index[index > nTips(x)], , drop = FALSE]
+ ## don't reorder data!
+ ## x at tip.data <- x at tip.data[index[index <= nTips(x)], , drop = FALSE]
+ ## x at node.data <- x at node.data[index[index > nTips(x)], , drop = FALSE]
if(hasEdgeLabels(x)) { x at edge.label <- x at edge.label[index] }
if(hasEdgeLength(x)) { x at edge.length <- x at edge.length[index] }
x
Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/R/setAs-Methods.R 2008-12-31 19:27:51 UTC (rev 415)
@@ -157,7 +157,7 @@
## beware: they cannot be NULL
## there are always tip labels (or check_phylo4 complains)
## there may not be node labels (character(0))
- label <- labels(x,which="all")[node]
+ label <- labels(x,which="all")[nodeId(x,"all")]
node.type <- nodeType(x)[node]
d <- data.frame(label, node, ancestor, branch.length,
node.type)
@@ -192,14 +192,16 @@
t_df <- as(tree, "data.frame") # convert to data.frame
dat <- tdata(from, "allnode", label.type="column") # get data
- 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")
- }
-
+ ## reorder data to edge matrix order, drop labels (first column)
+ dat2 <- dat[nodeId(from,"all"),-1,drop=FALSE]
+ tdat <- cbind(t_df, dat2)
+## 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)
})
Modified: pkg/R/treePlot.R
===================================================================
--- pkg/R/treePlot.R 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/R/treePlot.R 2008-12-31 19:27:51 UTC (rev 415)
@@ -151,7 +151,8 @@
angle = -rot
))
#grid.rect()
- vals = t(tdata(phy, which = 'tip')[i, ])
+ tvals <- tdata(phy, which = 'tip')[nodeId(phy,'tip'),,drop=FALSE]
+ vals = t(tvals[i, ])
if (!all(is.na(vals))) tip.plot.fun(vals,tmin,tmax,...)
upViewport()
}
@@ -187,7 +188,7 @@
angle = -rot
))
#grid.rect()
- vals = tdata(phy)[,i]
+ vals = tdata(phy)[nodeId(phy,'tip'),i,drop=FALSE]
if (!all(is.na(vals))) tip.plot.fun(vals, tmin, tmax, ...)
upViewport()
}
@@ -326,14 +327,14 @@
## TODO perhaps we want to use match here?
## 0, 1, length.out = Ntips)
# } else {
- ## reoder the phylo and assign even y spacing to the tips
+ ## reorder the phylo and assign even y spacing to the tips
phy <- reorder(phy, 'postorder')
xxyy$yy[phy at edge[, 2] <= Ntips] <- seq(
0, 1, length.out = Ntips
)
# }
- ## a recurvise preorder traversal
+ ## a recursive preorder traversal
## node -- initalized to be root, is the starting point for the traversal
## phy -- the phylogeny
## xxyy -- the list initalized below that holds the output
@@ -425,7 +426,7 @@
# tip y coordinates
tys <- XXYY$yy[phy at edge[, 2] <= nTips(phy)]
- tipdata <- tdata(phy, which = "tip")
+ tipdata <- tdata(phy, which = "tip")[nodeId(phy,"tip"),,drop=FALSE]
nVars <- ncol(tipdata) # number of bubble columns
maxr <- ifelse(ncol(tipdata) > nTips(phy), 1 / ncol(tipdata), 1 / nTips(phy))
Modified: pkg/man/prune-methods.Rd
===================================================================
--- pkg/man/prune-methods.Rd 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/man/prune-methods.Rd 2008-12-31 19:27:51 UTC (rev 415)
@@ -50,9 +50,9 @@
The argument \code{tip} can be either character or numeric. In the
first case, it gives the labels of the tips to be deleted; in the
second case the numbers of these labels in the vector
- \code{phy$tip.label} are given
+ \code{tipLabels(phy)} are given
- If \code{trim.internal = FALSE}, the new tips are given \code{"NA"} as
+ If \code{trim.internal = FALSE}, the new tips are given \code{NA} as
labels, unless there are node labels in the tree in which case they
are used
@@ -69,7 +69,8 @@
\value{
an object of class \code{"phylo4"}
}
-\author{Emmanuel Paradis \email{Emmanuel.Paradis at mpl.ird.fr}}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis at mpl.ird.fr}
+(original ape version)}
\examples{
require(ape)
data(bird.families)
@@ -86,11 +87,11 @@
"Pycnonotidae", "Hypocoliidae", "Cisticolidae", "Zosteropidae",
"Sylviidae", "Alaudidae", "Nectariniidae", "Melanocharitidae",
"Paramythiidae","Passeridae", "Fringillidae")
-plot(as(prune(bird.families, tip),"phylo"))
-plot(as(prune(bird.families, tip, trim.internal = FALSE),"phylo"))
+plot(prune(bird.families, tip),cex=0.5)
+plot(prune(bird.families, tip, trim.internal = FALSE),cex=0.5)
data(bird.orders)
-plot(as(prune(bird.orders, 6:23, subtree = TRUE),"phylo"))
-plot(as(prune(bird.orders, c(1:5, 20:23), subtree = TRUE), "phylo"))
+plot(prune(bird.orders, 6:23, subtree = TRUE))
+plot(prune(bird.orders, c(1:5, 20:23), subtree = TRUE))
### Examples of the use of `root.edge'
tr <- as(ape::read.tree(text = "(A:1,(B:1,(C:1,(D:1,E:1):1):1):1):1;"),"phylo4")
@@ -102,8 +103,10 @@
## Dropping tips on phylo4d objects
r1 <- rcoal(5)
d <- data.frame(a=1:5,row.names=paste("t",1:5,sep=""))
-phylo4d(r1,tip.data=d,node.data=data.frame(a=6:9))
-prune(r1,1)
+r2 <- phylo4d(r1,tip.data=d,node.data=data.frame(a=6:9))
+r2 <- phylo4d(as(r1,"phylo4"),tip.data=d,node.data=data.frame(a=6:9))
+nodeLabels(r2) <- as.character(sort(nodeId(r2)))
+r3 <- prune(r2,1)
}
\keyword{manip}
\keyword{methods}
Modified: pkg/man/subset-methods.Rd
===================================================================
--- pkg/man/subset-methods.Rd 2008-12-31 19:20:47 UTC (rev 414)
+++ pkg/man/subset-methods.Rd 2008-12-31 19:27:51 UTC (rev 415)
@@ -72,6 +72,7 @@
## "subset" examples
g1 <- as(geospiza,"phylo4")
+nodeLabels(g1) <- as.character(sort(nodeId(g1)))
plot(subset(g1,tips.exclude="scandens"))
plot(subset(g1,mrca=c("scandens","fortis","pauper")))
plot(subset(g1,node.subtree=18))
@@ -79,7 +80,7 @@
## "[" examples
plot(g1,show.node.label=TRUE)
plot(g1[c(1:6,14)],show.node.label=TRUE)
-
+nodeLabels(geospiza) <- as.character(sort(nodeId(geospiza)))
plot(geospiza[c(1:6,14)],show.node.label=TRUE)
plot(geospiza[c(1:6,14),3:5],show.node.label=TRUE)
}
More information about the Phylobase-commits
mailing list