[Phylobase-commits] r409 - in branches/newlabels: R inst/doc man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Dec 27 21:44:41 CET 2008
Author: bbolker
Date: 2008-12-27 21:44:41 +0100 (Sat, 27 Dec 2008)
New Revision: 409
Modified:
branches/newlabels/R/class-phylo4d.R
branches/newlabels/R/methods-phylo4.R
branches/newlabels/R/methods-phylo4d.R
branches/newlabels/R/phylo4.R
branches/newlabels/R/setAs-Methods.R
branches/newlabels/R/treePlot.R
branches/newlabels/inst/doc/phylobase.Rnw
branches/newlabels/man/prune-methods.Rd
branches/newlabels/man/subset-methods.Rd
branches/newlabels/tests/misctests.R
Log:
a fairly large set of changes implementing the new labeling
rules
Modified: branches/newlabels/R/class-phylo4d.R
===================================================================
--- branches/newlabels/R/class-phylo4d.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/R/class-phylo4d.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -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: branches/newlabels/R/methods-phylo4.R
===================================================================
--- branches/newlabels/R/methods-phylo4.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/R/methods-phylo4.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -116,10 +116,10 @@
"node", "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"))],
node = {
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: branches/newlabels/R/methods-phylo4d.R
===================================================================
--- branches/newlabels/R/methods-phylo4d.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/R/methods-phylo4d.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -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: branches/newlabels/R/phylo4.R
===================================================================
--- branches/newlabels/R/phylo4.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/R/phylo4.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -117,7 +117,7 @@
###################
## Function .genlab
###################
-## recursive function to have labels of constant length
+## (formerly) recursive function to have labels of constant length
## base = a character string
## n = number of labels
.genlab <- function(base, n) {
Modified: branches/newlabels/R/setAs-Methods.R
===================================================================
--- branches/newlabels/R/setAs-Methods.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/R/setAs-Methods.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -154,7 +154,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)
@@ -189,14 +189,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: branches/newlabels/R/treePlot.R
===================================================================
--- branches/newlabels/R/treePlot.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/R/treePlot.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -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: branches/newlabels/inst/doc/phylobase.Rnw
===================================================================
--- branches/newlabels/inst/doc/phylobase.Rnw 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/inst/doc/phylobase.Rnw 2008-12-27 20:44:41 UTC (rev 409)
@@ -126,11 +126,13 @@
<<nodelabelgeodata>>=
nodeLabels(g1)
@
+(you can also retrieve the node labels with
+\code{labels(g1,"internal")}).
A simple way to assign the node numbers as
labels (useful for various checks) is
<<>>=
-nodeLabels(g1) <- as.character(nodeId(g1))
+nodeLabels(g1) <- as.character(sort(nodeId(g1)))
head(g1,5)
@
@@ -142,10 +144,12 @@
Print tip labels:
<<tiplabelgeodata>>=
-labels(g1)
+tipLabels(g1)
@
+(\code{labels(g1)} or \code{labels(g1,"tip")} would also work.)
-Print node numbers:
+
+Print node numbers (in edge matrix order):
<<nodenumbergeodata>>=
nodeId(g1, which = 'all')
@
@@ -176,11 +180,19 @@
@
You can modify labels and other aspects
-of the tree --- for example,
+of the tree --- for example, to convert
+all the labels to lower case:
<<modlabelsgeodata>>=
-tipLabels(g1) <- tolower(labels(g1))
+tipLabels(g1) <- tolower(tipLabels(g1))
@
+You could also modify selected labels, e.g.
+to modify the labels in positions 11 and 13
+(which happen to be the only labels with uppercase letters):
+<<eval=FALSE>>=
+tipLabels(g1)[c(11,13)] <- c("platyspiza","pinaroloxias")
+@
+
\section{Trees with data}
The \code{phylo4d} class matches trees with data,
@@ -234,7 +246,7 @@
Or use \code{tdata()} to extract the data (i.e., \code{tdata(g2)}). By default, \code{tdata()} will retrieve tip data, but you can also get internal node data only (\code{tdata(tree,"node")}) or --- if the tip and node data have the same format --- all the data combined (\code{tdata(tree,"allnode")}).
-Plotting calls \code{plot.phylog} from the \code{ade4} package.
+%Plotting calls \code{plot.phylog} from the \code{ade4} package.
If you want to plot the data (e.g. for checking the input), \code{plot(tdata(g2))} will create the default plot for the data --- in this case, since it is a data frame [\textbf{this may change in future versions but should remain transparent}] this will be a \code{pairs} plot of the data.
@@ -453,19 +465,21 @@
\subsection{multiphylo4}
-\section{Hacks/backward compatibility}
+% hack removed ...
+%
+%\section{Hacks/backward compatibility}
+%
+%There is a way to hack the \verb+$+ operator so that it would provide %backward compatibility with code that is extracting internal elements %of a \code{phylo4}. The basic recipe is:
-There is a way to hack the \verb+$+ operator so that it would provide backward compatibility with code that is extracting internal elements of a \code{phylo4}. The basic recipe is:
-
-<<eval=FALSE>>=
+<<echo=FALSE,eval=FALSE>>=
setMethod("$","phylo4",function(x,name) { attr(x,name)})
@
-but this has to be hacked slightly to intercept calls to elements that might be missing. For example, \code{ape} detects whether log-likelihood, root edges, node labels, etc. are missing by testing whether they are \code{NULL}, whereas missing items are represented in \code{phylo4} by zero-length vectors in the slots (or \code{NA} for the root edge) --- so we need code like
-<<eval=FALSE>>=
+%but this has to be hacked slightly to intercept calls to elements %that might be missing. For example, \code{ape} detects whether %log-likelihood, root edges, node labels, etc. are missing by testing %whether they are \code{NULL}, whereas missing items are represented %in \code{phylo4} by zero-length vectors in the slots (or \code{NA} %for the root edge) --- so we need code like
+<<echo=FALSE,eval=FALSE>>=
if(!hasNodeLabels(x)) NULL else x at node.label
@
-to handle these cases.
+%to handle these cases.
\end{document}
Modified: branches/newlabels/man/prune-methods.Rd
===================================================================
--- branches/newlabels/man/prune-methods.Rd 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/man/prune-methods.Rd 2008-12-27 20:44:41 UTC (rev 409)
@@ -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: branches/newlabels/man/subset-methods.Rd
===================================================================
--- branches/newlabels/man/subset-methods.Rd 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/man/subset-methods.Rd 2008-12-27 20:44:41 UTC (rev 409)
@@ -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)
}
Modified: branches/newlabels/tests/misctests.R
===================================================================
--- branches/newlabels/tests/misctests.R 2008-12-27 20:42:02 UTC (rev 408)
+++ branches/newlabels/tests/misctests.R 2008-12-27 20:44:41 UTC (rev 409)
@@ -103,3 +103,32 @@
NA, 8), ncol=2,byrow=TRUE)
P2 <- phylo4(E)
+
+
+z <- as(tree.owls,"phylo4")
+
+library(phylobase)
+example("read.tree")
+z <- as(tree.owls,"phylo4")
+nodeLabels(z) <- as.character(sort(nodeId(z)))
+print(z) ## note node labels
+## the node types are matched up correctly
+## or try this (I don't know if it should work or not):
+z <- as(tree.owls,"phylo4")
+z at edge[3:4,] <- z at edge[4:3,]
+## z at tip.label[1:2] <- z at tip.label[2:1] ## DON'T REARRANGE
+## or
+set.seed(1001)
+z <- as(tree.owls,"phylo4")
+nodeLabels(z) <- as.character(sort(nodeId(z)))
+s <- sample(7)
+z at edge <- z at edge[s,]
+z at edge.length <- z at edge.length[s]
+z
+
+data(geospiza)
+g <- geospiza
+nodeLabels(g) <- as.character(sort(nodeId(g)))
+g <- reorder(g)
+g <- reorder(g,"postorder")
+head(g)
More information about the Phylobase-commits
mailing list