[Phylobase-commits] r349 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 19 22:30:21 CET 2008
Author: pdc
Date: 2008-12-19 22:30:21 +0100 (Fri, 19 Dec 2008)
New Revision: 349
Modified:
pkg/R/treePlot.R
Log:
many small tweaks to work with new explicit root
Modified: pkg/R/treePlot.R
===================================================================
--- pkg/R/treePlot.R 2008-12-19 21:29:14 UTC (rev 348)
+++ pkg/R/treePlot.R 2008-12-19 21:30:21 UTC (rev 349)
@@ -1,10 +1,10 @@
-`treePlot` <- function(x,
+`treePlot` <- function(phy,
type = c('phylogram', 'cladogram', 'fan'),
show.tip.label = TRUE,
show.node.label = FALSE,
tip.order = NULL,
- plot.data = is(x, 'phylo4d'),
+ plot.data = is(phy, 'phylo4d'),
rot = 0,
tip.plot.fun = 'bubbles',
plot.at.tip = TRUE,
@@ -19,21 +19,22 @@
{
## TODO three dimensional histogram as example, compute values on full dataset
## then generate phylo4d object with summary data and plot
- if (!inherits(x, 'phylo4')) stop('treePlot requires a phylo4 or phylo4d object')
- if (!isRooted(x)) stop("treePlot function requires a rooted tree.")
+ ## TODO factors not handled in data plots
+ if (!inherits(phy, 'phylo4')) stop('treePlot requires a phylo4 or phylo4d object')
+ if (!isRooted(phy)) stop("treePlot function requires a rooted tree.")
width <- height <- (1 - margin) ## TODO: do these have to be hard-coded?
type <- match.arg(type)
- Nedges <- nEdges(x)
- Ntips <- nTips(x)
+ Nedges <- nEdges(phy)
+ Ntips <- nTips(phy)
## TODO remove the false cladogram option?
- if(is.null(edgeLength(x)) || type == 'cladogram') {
- x at edge.length <- rep(1, Nedges)
+ if(is.null(edgeLength(phy)) || type == 'cladogram') {
+ phy at edge.length <- rep(1, Nedges)
}
- xxyy <- phyloXXYY(x, tip.order)
- x <- xxyy$x
- tindex <- x at edge[x at edge[, 2] <= Ntips, 2]
+ xxyy <- phyloXXYY(phy, tip.order)
+ phy <- xxyy$phy
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
if(type == 'cladogram') {
- xxyy$xx[x at edge[, 2] <= Ntips] <- 1
+ xxyy$xx[phy at edge[, 2] <= Ntips] <- 1
}
## general function for pushing tree subplots
@@ -69,13 +70,13 @@
# TODO should return something useful
return(invisible())
} else {
- tmin <- min(tdata(x, which = 'tip'), na.rm = TRUE)
- tmax <- max(tdata(x, which = 'tip'), na.rm = TRUE)
+ tmin <- min(tdata(phy, which = 'tip'), na.rm = TRUE)
+ tmax <- max(tdata(phy, which = 'tip'), na.rm = TRUE)
if(!is.function(tip.plot.fun)) {
if(tip.plot.fun == "bubbles") {
# use phylobubbles as default
if(rot != 0) {stop("Rotation of bubble plots not yet implemented")}
- dlabwdth <- max(stringWidth(colnames(x at tip.data))) * 1.2
+ dlabwdth <- max(stringWidth(colnames(phy at tip.data))) * 1.2
phyplotlayout <- grid.layout(nrow = 2, ncol = 2,
heights = unit.c(unit(1, 'null'), dlabwdth),
widths = unit(c(1, 1), c('null', 'null'), list(NULL, NULL)))
@@ -108,14 +109,14 @@
plot) you need install the "gridBase" package')
}
plot.new()
- tmin <- min(tdata(x, which = 'tip'), na.rm = TRUE)
- tmax <- max(tdata(x, which = 'tip'), na.rm = TRUE)
+ tmin <- min(tdata(phy, which = 'tip'), na.rm = TRUE)
+ tmax <- max(tdata(phy, which = 'tip'), na.rm = TRUE)
tip.plot.fun <- function(x,tmin,tmax,...) {
# par(omi = c(0,0,0,0))
suppressWarnings(par(plt = gridPLT(), new = TRUE))
- if(!all(is.na(x))) {
+ if(!all(is.na(phy))) {
# hack, set the plotting region to the grid fig region
- dens <- density(x, na.rm = TRUE)
+ dens <- density(phy, na.rm = TRUE)
plot.density(dens, xlim = c(tmin, tmax), axes = FALSE,
mar = c(0,0,0,0), main = "", xlab = "", ylab = "", ...)
}
@@ -140,7 +141,7 @@
hc <- convertY(unit(1/Ntips, 'snpc'), 'npc')
for(i in 1:Ntips) {
pushViewport(viewport(
- y = xxyy$yy[x at edge[, 2] == i],
+ y = xxyy$yy[phy at edge[, 2] == i],
x = 1 + 1/(2 * Ntips), # xxyy$xx[phy at edge[, 2] == i],
height = hc,
width = hc,
@@ -150,7 +151,7 @@
angle = -rot
))
#grid.rect()
- vals = t(tdata(x, which = 'tip')[i, ])
+ vals = t(tdata(phy, which = 'tip')[i, ])
if (!all(is.na(vals))) tip.plot.fun(vals,tmin,tmax,...)
upViewport()
}
@@ -160,7 +161,7 @@
} else { ## plot by data column
## !plot.at.tip
## stop("not implemented yet")
- nvars <- length(x at tip.data) ## FIXME
+ nvars <- length(phy at tip.data) ## FIXME
datalayout <- grid.layout(ncol = 2) ## set default widths equal for this kind of plot
## width = unit(c(1, 1/Ntips), c('null', 'null'))
# TODO this is done multiple times,
@@ -186,7 +187,7 @@
angle = -rot
))
#grid.rect()
- vals = tdata(x)[,i]
+ vals = tdata(phy)[,i]
if (!all(is.na(vals))) tip.plot.fun(vals, tmin, tmax, ...)
upViewport()
}
@@ -275,11 +276,11 @@
}
upViewport()
if(show.tip.label) {
- pushViewport(viewport(layout.pos.col = 2,
+ pushViewport(viewport(layout.pos.col = 1,
name = 'tiplabelvp'))
labtext <- grid.text(
phy at tip.label[tindex],
- x = convertUnit(laboff[tindex], 'native', valueOnly = TRUE) + 0.02,
+ x = xxyy$xx[phy at edge[, 2] %in% tindex] + convertUnit(laboff[tindex], 'native', valueOnly = TRUE) + 0.02,
y = xxyy$yy[phy at edge[, 2] %in% tindex], rot = lrot,
default.units = 'native', name = 'tiplabels',
just = 'center', gp = gpar(col = tip.color[tindex])
@@ -306,7 +307,7 @@
phyloXXYY <- function(phy, tip.order = NULL) {
## initalize the output
- Nedges <- nEdges(phy)
+ Nedges <- nrow(phy at edge) - 1 ## TODO switch to the accessor once stablized
phy.orig <- phy
Ntips <- nTips(phy)
xxyy = list(
@@ -340,7 +341,7 @@
calc.node.xy <- function(node, phy, xxyy, prevx = 0) {
## if node == root node, and there is no root edge set get descendants
## and set index to NULL index is used for indexing output
- if(any(phy at edge[, 2] == node) == FALSE) {
+ if(node == rootNode(phy)) {
decdex <- which(phy at edge[, 1] == node)
index <- NULL
## if root node start at x = 0
@@ -378,35 +379,33 @@
segs <- function(XXYY) {
phy <- XXYY$phy
- treelen <- rep(NA, nEdges(phy) + 1)
+ treelen <- rep(NA, nEdges(phy))
segs <- list(v0x = treelen, v0y = treelen, v1x = treelen, v1y = treelen,
h0x = treelen, h0y = treelen, h1x = treelen, h1y = treelen)
- troot <- nTips(phy) + 1
+ troot <- rootNode(phy)
+ ntips <- nTips(phy)
get.coor <- function(node, segs) {
- if(any(phy at edge[, 2] == node) == FALSE) {
+ if(node == troot) {
#root
decdex <- which(phy at edge[, 1] == node)
- index <- length(treelen)
+ index <- length(treelen)
segs$v0y[index] <- segs$v1y[index] <- NA
segs$v0x[index] <- segs$v1x[index] <- NA
segs$h0y[index] <- segs$h1y[index] <- NA
segs$h0x[index] <- segs$h1x[index] <- NA
- segs$v0x[decdex] <- segs$v1x[decdex] <- segs$h0x[decdex] <- 0
- segs$v0y[decdex] <- mean(XXYY$yy[decdex])
+ segs$v0x[decdex] <- segs$v1x[decdex] <- segs$h0x[decdex] <- 0
+ segs$v0y[decdex] <- mean(XXYY$yy[decdex])
} else {
#not root
index <- which(phy at edge[, 2] == node)
segs$h1x[index] <- XXYY$xx[index]
segs$h0y[index] <- segs$h1y[index] <- segs$v1y[index] <- XXYY$yy[index]
- if(!any(phy at edge[, 1] == node)) {
- return(segs)
- }
+ if(node <= ntips) { return(segs) }
decdex <- which(phy at edge[, 1] == phy at edge[index, 2])
segs$v0x[decdex] <- segs$v1x[decdex] <- segs$h0x[decdex] <- XXYY$xx[index]
segs$v0y[decdex] <- mean(XXYY$yy[decdex])
}
-
for(i in phy at edge[decdex, 2]) {
segs <- get.coor(i, segs)
}
@@ -552,5 +551,8 @@
# }
# }
#
-# setGeneric('plot', useAsDefault = treePlot)
-setMethod('treePlot', signature = c('phylo4', 'phylo4d'), treePlot)
+
+setGeneric('plot')
+setMethod('plot', signature(x='phylo4', y='missing'), function(x, y, ...) {
+ treePlot(x, ...)
+})
More information about the Phylobase-commits
mailing list