[Phylobase-commits] r229 - branches/pdcgsoc/misc
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 4 09:47:23 CEST 2008
Author: pdc
Date: 2008-08-04 09:47:23 +0200 (Mon, 04 Aug 2008)
New Revision: 229
Modified:
branches/pdcgsoc/misc/temp.R
Log:
abstract the tree plotting as a separate function
also actually address the label-tree spacing issue use a layout w/ 2 col one of which corresponds to the widest label. This ensures there will always be enough space for the labels regardless of how the plot is resized. The drawback is that if the widest label belongs to a tip that doesn't reach 1, then excess white space can occur.
Modified: branches/pdcgsoc/misc/temp.R
===================================================================
--- branches/pdcgsoc/misc/temp.R 2008-08-03 07:45:51 UTC (rev 228)
+++ branches/pdcgsoc/misc/temp.R 2008-08-04 07:47:23 UTC (rev 229)
@@ -7,7 +7,7 @@
tip.order = NULL,
plot.data = FALSE,
rot = 0,
- tip.plot.fun = function() {grid.lines(1:10/10, rnorm(10, sd = .2, mean = .5))},
+ tip.plot.fun = 'bubbles',
edge.color = 'black', ## TODO colors for branhes and nodes seperately?
node.color = 'black',
tip.color = 'black',
@@ -22,120 +22,139 @@
xxyy <- phyloXXYY(phy, tip.order)
## because we may reoder the tip, we need to update the phy objec
phy <- xxyy$phy
- segs <- segs(phy, XXYY = xxyy)
}
- if(show.tip.label) {
- labwd <- stringWidth(phy at tip.label)
- xrs <- max(unit(xxyy$xx[phy at edge[, 2] %in% tindex], 'npc') + labwd)
+
+ if(plot.data) {
+ phyplotlayout <- grid.layout(nrow = 1, ncol = 2,
+ widths = unit(c(1, 1), c('null', 'null'), list(NULL, NULL))
+ )
} else {
- xrs <- unit(1, 'null', NULL)
+ phyplotlayout <- grid.layout(nrow = 1, ncol = 1)
}
-
- eindex <- match(phy at edge[,2], phy.orig at edge[,2])
+ ## TODO handle showing data and labels better
+ grid.newpage()
+ pushViewport(viewport(
+ x = 0.5, y = 0.5,
+ width = 0.9, height = 0.9,
+ # rotataion set here
+ layout = phyplotlayout, name = 'phyplotlayout', angle = -rot))
+ pushViewport(viewport(layout.pos.col = 1))
+ tree.plot(xxyy, show.tip.label, edge.color, node.color, tip.color, edge.width, rot)
+ upViewport()
+ ## TODO handle better show label | data
+ if (plot.data) {
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
+ if(length(tip.color) != Ntips) {
+ tip.color <- rep(tip.color, length.out = Ntips)
+ }
+ if (tip.plot.fun == 'bubbles') {
+ pushViewport(viewport(layout.pos.col = 2))
+ phylobubbles(xxyy)
+ popViewport()
+ } else {
+ ## datalayout <- grid.layout(
+ ## nrow = Ntips,
+ ## ncol = 1,
+ ## respect = TRUE)
+ pushViewport(viewport(
+ ## layout = datalayout,
+ layout.pos.col = 2,
+ name = 'data_plots'))
+ ## TODO should plots float at tips, or only along edge?
+ for(i in xxyy$yy[which(phy at edge[, 2] <= Ntips)]) {
+ pushViewport(viewport(
+ y = i,
+ height = unit(1, 'snpc'),
+ width = unit(1, 'snpc'),
+ name = paste('data_plot', i),
+ just = "left"))
+ # tip.plot.fun()
+ popViewport()
+ }
+ popViewport()
+ }
+ }
+}
+
+tree.plot <- function(xxyy, show.tip.label, edge.color,
+ node.color, tip.color, edge.width, rot)
+{
+
+ # TODO switch to phylobase abstractions
+ phy <- xxyy$phy
+ Nedges <- nrow(phy at edge)
+ Ntips <- length(phy at tip.label)
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
+ eindex <- match(phy at edge[,2], xxyy$phy.orig at edge[,2])
+ segs <- segs(phy, XXYY = xxyy)
+
## TODO check that colors are valid?
## TODO edge colors are required to be in the order of edge matrix
if(length(edge.color) != Nedges) {
edge.color <- rep(edge.color, length.out = Nedges)
}
edge.color <- edge.color[eindex]
-
+
## TODO check that colors are valid?
nindex <- sort(eindex[phy at edge[, 2] > Ntips], index.return = TRUE)$ix
if(length(node.color) != length(nindex)) {
node.color <- rep(node.color, length.out = length(nindex))
}
node.color <- node.color[nindex]
-
- ## initialize canvas
- # call appropriate plot type
- ## grid calls Peter GSOC
- grid.newpage()
- if(plot.data) {
+
+ if(show.tip.label) {
+ labw <- max(stringWidth(phy at tip.label))
+ # print(convertUnit(labw, 'inches'))
treelayout <- grid.layout(nrow = 1, ncol = 2,
- widths = unit(c(1, 1), c('null', 'null'), list(NULL, NULL))
+ widths = unit.c(unit(1, 'null', NULL), labw)
)
- ## TODO handle showing data and labels better
- ## TODO find the best way to get max label width
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
+ if(length(tip.color) != Ntips) {
+ tip.color <- rep(tip.color, length.out = Ntips)
+ }
} else {
- treelayout <- grid.layout(nrow = 1, ncol = 1,
- widths = unit(1, 'null', NULL)
- )
+ treelayout <- grid.layout(nrow = 1, ncol = 1)
}
-
+ # grid.show.layout(treelayout)
pushViewport(viewport(
x = 0.5, y = 0.5,
- width = 0.8, height = 0.8,
+ width = 1, height = 1,
# rotataion set here
layout = treelayout, name = 'treelayout', angle = -rot))
-
- ## TODO handle better show label | data
- if (show.tip.label | plot.data) {
- tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
- if(length(tip.color) != Ntips) {
- tip.color <- rep(tip.color, length.out = Ntips)
- }
-
- }
- if (plot.data) {
- ## datalayout <- grid.layout(
- ## nrow = Ntips,
- ## ncol = 1,
- ## respect = TRUE)
- pushViewport(viewport(
- ## layout = datalayout,
- layout.pos.col = 2,
- name = 'data_plots'))
- ## TODO should plots float at tips, or only along edge?
- for(i in xxyy$yy[which(phy at edge[, 2] <= Ntips)]) {
- pushViewport(viewport(
- y = i,
- height = unit(1, 'snpc'),
- width = unit(1, 'snpc'),
- name = paste('data_plot', i),
- just = "left"))
- tip.plot.fun()
- popViewport()
- }
- popViewport()
- }
-
pushViewport(viewport(
layout = treelayout, layout.pos.col = 1,
- # trickery to space labels properly
- # set the scale to 0 to an amount greater than one
- # as scaled by the tip location and label widths
- # then actually plot the tree in as native
- # since x data range 0-1 space is left for the widest label
- xscale = c(0, convertUnit(xrs * 1.02, 'npc')),
name = 'tree'))
vseg <- grid.segments( # draws vertical lines
x0 = segs$v0x, y0 = segs$v0y,
x1 = segs$v1x, y1 = segs$v1y,
- default.units = "native",
name = "vert", gp = gpar(col = node.color, lwd = 1))
hseg <- grid.segments( # draws horizontal lines
x0 = segs$h0x, y0 = segs$h0y,
x1 = segs$h1x, y1 = segs$h1y,
- default.units = "native",
name = "horz", gp = gpar(col = edge.color, lwd = 1))
+ upViewport()
if(show.tip.label) {
+ pushViewport(viewport(
+ layout = treelayout, layout.pos.col = 1,
+ ))
labtext <- grid.text(
phy at tip.label[tindex],
x = xxyy$xx[phy at edge[, 2] %in% tindex] + 0.02,
## TODO yuck!!
y = xxyy$yy[phy at edge[, 2] %in% tindex],
- default.units = "native",
+ default.units = 'npc',
rot = rot, just = 'left', gp = gpar(col = tip.color[tindex])
)
+ upViewport()
}
- popViewport()
- grobTree(vseg, hseg, labtext)
+ # grobTree(vseg, hseg, labtext)
}
phyloXXYY <- function(phy, tip.order = NULL) {
## initalize the output
Nedges <- nrow(phy at edge)
+ phy.orig <- phy
Ntips <- length(phy at tip.label)
xxyy = list(
yy = rep(NA, Nedges),
@@ -197,7 +216,8 @@
xxyy <- calc.node.xy(Ntips + 1, phy, xxyy)
## scale the x values
xxyy$xx <- xxyy$xx / max(xxyy$xx)
- c(xxyy, phy = list(phy))
+ # TODO return an index vector instead of a second phy object
+ c(xxyy, phy = list(phy), phy.orig = list(phy.orig))
}
segs <- function(phy, XXYY) {
@@ -266,7 +286,6 @@
naxs <- xpos[apply(traits, 2, function(x) any(is.na(x)))]
traits[is.na(traits)] <- 0
- grid.newpage()
bublayout <- grid.layout(nrow = 2, ncol = 2,
widths = unit(c(1, 1), c('null', 'strwidth'),
list(NULL, phy at tip.label)),
@@ -275,7 +294,7 @@
)
pushViewport(viewport(
x = 0.5, y = 0.5,
- width = 0.8, height = 0.8,
+ width = 1, height = 1,
layout = bublayout, name = 'bublayout'))
pushViewport(viewport(
name = 'bubble_plots',
@@ -320,18 +339,18 @@
# p1 <- treePlot(
# geospiza,
# plot.data = TRUE,
-# show.tip.label = TRUE,
+# show.tip.label = FALSE,
# # edge.color = rainbow(nrow(geospiza at edge)),
# tip.color = c('red', 'black', 'blue')
# )
tree1 <- as(rtree(10), 'phylo4')
-tree1 at tip.label <- replicate(10, paste(sample(LETTERS, 14), collapse = ""))
+tree1 at tip.label <- replicate(10, paste(sample(LETTERS, sample(2:20, 1)), collapse = ""))
p2 <- treePlot(
- tree1 #, plot.data = TRUE
+ tree1, #, plot.data = TRUE
)
# pushViewport(viewport(
# width = unit(1, 'grobwidth', list(p2))
-# ))
\ No newline at end of file
+# ))
More information about the Phylobase-commits
mailing list