[Phylobase-commits] r313 - in pkg: . R inst/doc man misc
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 19 03:07:55 CET 2008
Author: pdc
Date: 2008-12-19 03:07:55 +0100 (Fri, 19 Dec 2008)
New Revision: 313
Added:
pkg/R/methods-oldclasses.R
pkg/R/treePlot.R
pkg/man/phyloXXYY.Rd
pkg/man/phylobubbles.Rd
pkg/man/reorder-methods.Rd
pkg/man/segs.Rd
pkg/man/tree.plot.Rd
pkg/man/treePlot-methods.Rd
Modified:
pkg/DESCRIPTION
pkg/R/identify.R
pkg/R/methods-phylo4.R
pkg/R/methods-phylo4d.R
pkg/R/phylo4.R
pkg/inst/doc/phylobase.pdf
pkg/man/phylo4d.Rd
pkg/misc/plottest.R
Log:
merge in new plotting function
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2008-12-19 00:51:34 UTC (rev 312)
+++ pkg/DESCRIPTION 2008-12-19 02:07:55 UTC (rev 313)
@@ -3,12 +3,12 @@
Title: Base package for phylogenetic structures and comparative data
Version: 0.4
Date: 2008-07-27
-Depends: methods, ape(>= 2.1)
-Suggests: ade4, MASS
+Depends: methods, grid, ape(>= 2.1)
+Suggests: ade4, MASS, gridBase
Author: R Hackathon (Ben Bolker, Marguerite Butler, Peter Cowan, Damien de Vienne, Thibaut Jombart, Steve Kembel, David Orme, Brian O'Meara, Emmanuel Paradis, Derrick Zwickl)
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-phylo4.R methods-phylo4d.R setAs-Methods.R pdata.R subset.R prune.R plot.R identify.R treestruc.R treewalk.R ReadWithNCL.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 plot.R treePlot.R identify.R treestruc.R treewalk.R ReadWithNCL.R tbind.R zzz.R
Encoding: UTF-8
URL: http://phylobase.R-forge.R-project.org
Modified: pkg/R/identify.R
===================================================================
--- pkg/R/identify.R 2008-12-19 00:51:34 UTC (rev 312)
+++ pkg/R/identify.R 2008-12-19 02:07:55 UTC (rev 313)
@@ -1,7 +1,5 @@
setGeneric("identify")
-## FIXME: warning on install because
-## "identify.node.R" is read before "phylo4.R"
-## (class definitions)
+
setMethod("identify","phylo4",
function(x,n=1,...) {
plot(x, ...)
Copied: pkg/R/methods-oldclasses.R (from rev 312, branches/pdcgsoc/R/methods-oldclasses.R)
===================================================================
--- pkg/R/methods-oldclasses.R (rev 0)
+++ pkg/R/methods-oldclasses.R 2008-12-19 02:07:55 UTC (rev 313)
@@ -0,0 +1,4 @@
+setMethod("reorder", signature(x = "phylo"), function(x, order = 'cladewise') {
+ x <- reorder.phylo(x, order)
+ x
+})
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2008-12-19 00:51:34 UTC (rev 312)
+++ pkg/R/methods-phylo4.R 2008-12-19 02:07:55 UTC (rev 313)
@@ -311,3 +311,27 @@
object
})
+setMethod("reorder", signature(x = 'phylo4'), function(x, order = 'cladewise') {
+ reorder.prune <- function(edge, tips, root = tips + 1) {
+ ## if(is.null(root)) {
+ ## root <- tips + 1
+ ## }
+ ## if(root <= tips) {return()}
+ index <- edge[, 1] == root
+ nextr <- edge[index, 2]
+ ## paths <- apply(as.matrix(nextr), 1, reorder, edge = edge, tips = tips)
+ nord <- NULL
+ for(i in nextr) {
+ if(i <= tips) {next()}
+ nord <- c(nord, reorder.prune(edge, tips, root = i))
+ }
+ c(nord, which(index))
+ }
+ if(order == 'pruningwise') {
+ index <- reorder.prune(x at edge, length(x at tip.label))
+ }
+ x at edge <- x at edge[index, ]
+ x at edge.label <- x at edge.label[index]
+ x at edge.length <- x at edge.length[index]
+ x
+})
Modified: pkg/R/methods-phylo4d.R
===================================================================
--- pkg/R/methods-phylo4d.R 2008-12-19 00:51:34 UTC (rev 312)
+++ pkg/R/methods-phylo4d.R 2008-12-19 02:07:55 UTC (rev 313)
@@ -158,3 +158,28 @@
temp <- rev(names(attributes(x)))[-1]
return(rev(temp))
})
+
+setMethod("reorder", signature(x = 'phylo4d'), function(x, order = 'cladewise') {
+ reorder.prune <- function(edge, tips, root = tips + 1) {
+ ## if(is.null(root)) {
+ ## root <- tips + 1
+ ## }
+ ## if(root <= tips) {return()}
+ index <- edge[, 1] == root
+ nextr <- edge[index, 2]
+ ## paths <- apply(as.matrix(nextr), 1, reorder, edge = edge, tips = tips)
+ nord <- NULL
+ for(i in nextr) {
+ if(i <= tips) {next()}
+ nord <- c(nord, reorder.prune(edge, tips, root = i))
+ }
+ c(nord, which(index))
+ }
+ if(order == 'pruningwise') {
+ index <- reorder.prune(x at edge, length(x at tip.label))
+ }
+ x at edge <- x at edge[index, ]
+ x at edge.label <- x at edge.label[index]
+ x at edge.length <- x at edge.length[index]
+ x
+})
Modified: pkg/R/phylo4.R
===================================================================
--- pkg/R/phylo4.R 2008-12-19 00:51:34 UTC (rev 312)
+++ pkg/R/phylo4.R 2008-12-19 02:07:55 UTC (rev 313)
@@ -86,6 +86,8 @@
setGeneric("na.omit")
+setGeneric("reorder")
+
###################
## Function .genlab
###################
Copied: pkg/R/treePlot.R (from rev 312, branches/pdcgsoc/R/treePlot.R)
===================================================================
--- pkg/R/treePlot.R (rev 0)
+++ pkg/R/treePlot.R 2008-12-19 02:07:55 UTC (rev 313)
@@ -0,0 +1,553 @@
+`treePlot` <- function(phy,
+ type = c('phylogram', 'cladogram', 'fan'),
+ show.tip.label = TRUE,
+ show.node.label = FALSE,
+ tip.order = NULL,
+ plot.data = is(phy, 'phylo4d'),
+ rot = 0,
+ tip.plot.fun = 'bubbles',
+ plot.at.tip = TRUE,
+ edge.color = 'black',
+ node.color = 'black', # TODO what do with node.color parameter
+ tip.color = 'black',
+ edge.width = 1, # TODO line-type modification hack
+ newpage = TRUE,
+ margin = 0.1, # here margin is a precentage of the area
+ ...
+ )
+{
+ ## TODO three dimensional histogram as example, compute values on full dataset
+ ## then generate phylo4d object with summary data and plot
+ if (!all(is(phy, 'phylo4'), is(phy, 'phylo4d'))) 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(phy)
+ Ntips <- nTips(phy)
+ ## TODO remove the false cladogram option?
+ if(is.null(edgeLength(phy)) || type == 'cladogram') {
+ phy at edge.length <- rep(1, Nedges)
+ }
+ xxyy <- phyloXXYY(phy, tip.order)
+ phy <- xxyy$phy
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
+ if(type == 'cladogram') {
+ xxyy$xx[phy at edge[, 2] <= Ntips] <- 1
+ }
+
+ ## general function for pushing tree subplots
+ pushTree <- function(row, col) {
+ pushViewport(viewport(layout.pos.row = row,
+ layout.pos.col = col,
+ name = 'treevp'))
+ tree.plot(xxyy = xxyy, type = type,
+ show.tip.label = show.tip.label,
+ show.node.label = show.node.label,
+ edge.color = edge.color, node.color = node.color,
+ tip.color = tip.color, edge.width = edge.width, rot = rot)
+ upViewport()
+ }
+
+ # TODO add symbols at the nodes, allow coloirng and sizing downViewport approach?
+ # TODO cladogram methods incorrect
+ # TODO abstract, make ultrametric? good algorithms for this?
+ # TODO for very long plots, alternative margin setting useful
+ # call plot.new so that gridBase plots work properly
+ # calls to base plot functions need to be cleared w/ par(new = T) which fails
+ # if no plot is present TODO perhpas there's a better solution than calling plot.new
+
+ ## because we may reoder the tip, we need to update the phy objec
+ if(newpage) grid.newpage()
+ if(!plot.data) {
+ phyplotlayout <- grid.layout(nrow = 1, ncol = 1)
+ pushViewport(viewport(width = width, height = height,
+ layout = phyplotlayout, angle = rot,
+ name = "phyplotlayout"))
+ pushTree(row = 1, col = 1)
+ upViewport()
+ # TODO should return something useful
+ return(invisible())
+ } else {
+ 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(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)))
+ pushViewport(viewport(width = width, height = height,
+ layout = phyplotlayout, name = 'phyplotlayout'))
+ pushViewport(viewport(layout.pos.row = 1:2, layout.pos.col = 2,
+ height = unit(1, 'npc') +
+ convertUnit(dlabwdth, 'npc'),
+ name = 'bubbleplots', default.units = 'native'))
+ bubout <- phylobubbles(xxyy, ...)
+ upViewport()
+ pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1,
+ name = 'bubblelegend'))
+ legcir <- seq(bubout$min, bubout$max, length.out = 4)
+ ## print(convertUnit(bubout$bubscale, 'npc', valueOnly = TRUE))
+ ## TODO legend currently does not resize properly
+ legcirS <- legcir * convertUnit(bubout$bubscale, 'inches', valueOnly = TRUE) / bubout$max
+ ccol <- ifelse(legcirS < 0, 'black', 'white')
+ legcirS <- unit(legcirS, 'npc')
+ grid.circle(seq(.2, .8, length.out = length(legcirS)), 0.5, legcirS, gp = gpar(fill = ccol), default.units = 'npc')
+ grid.text(as.character(signif(legcir, digits = 2)), seq(.2, .8, length.out = length(legcir)), 0.1, gp = gpar(cex = 0.75))
+ upViewport()
+ pushTree(row = 1, col = 1)
+ upViewport()
+ return(invisible())
+
+ } else if(tip.plot.fun == "density") {
+ if(!require(gridBase)) {
+ stop('To plot using base graphics (including the "density"
+ plot) you need install the "gridBase" package')
+ }
+ plot.new()
+ 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))) {
+ # hack, set the plotting region to the grid fig region
+ dens <- density(x, na.rm = TRUE)
+ plot.density(dens, xlim = c(tmin, tmax), axes = FALSE,
+ mar = c(0,0,0,0), main = "", xlab = "", ylab = "", ...)
+ }
+ }
+ }
+ } else { ## if (is.function(tip.plot.fun))
+ ## plot.at.tip <- TRUE
+ if (plot.at.tip) {
+ datalayout <- grid.layout(ncol = 2,
+ width = unit(c(1, 1/Ntips), c('null', 'null'))
+ )
+ # TODO this is done multiple times,
+ pushViewport(viewport(width = width, height = height,
+ layout = datalayout, angle = rot,
+ name = 'datalayout'))
+ pushViewport(viewport(
+ yscale = c(-0.5/Ntips, 1 + 0.5/Ntips),
+ xscale = c(0, 1 + 1/Ntips),
+ layout.pos.col = 1,
+ name = 'data_plots'))
+ ## TODO should plots float at tips, or only along edge?
+ hc <- convertY(unit(1/Ntips, 'snpc'), 'npc')
+ for(i in 1:Ntips) {
+ pushViewport(viewport(
+ y = xxyy$yy[phy at edge[, 2] == i],
+ x = 1 + 1/(2 * Ntips), # xxyy$xx[phy at edge[, 2] == i],
+ height = hc,
+ width = hc,
+ # default.units = 'native',
+ name = paste('data_plot', i),
+ just = "center",
+ angle = -rot
+ ))
+ #grid.rect()
+ vals = t(tdata(phy, which = 'tip')[i, ])
+ if (!all(is.na(vals))) tip.plot.fun(vals,tmin,tmax,...)
+ upViewport()
+ }
+ pushTree(row = 1, col = 1)
+ upViewport()
+ upViewport()
+ } else { ## plot by data column
+ ## !plot.at.tip
+ ## stop("not implemented yet")
+ 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,
+ pushViewport(viewport(width = width, height = height,
+ layout = datalayout, angle = rot,
+ name = 'datalayout'))
+ pushViewport(viewport(
+ yscale = c(-0.5/Ntips, 1 + 0.5/Ntips),
+ xscale = c(0, 1 + 1/Ntips),
+ layout.pos.col = 2,
+ name = 'data_plots'))
+ ## TODO should plots float at tips, or only along edge?
+ hc <- convertY(unit(1/nvars, 'snpc'), 'npc')
+ for(i in 1:nvars) {
+ pushViewport(viewport(
+ x = i/nvars, ## xxyy$yy[phy at edge[, 2] == i],
+ y = 0.5, ## 1 + 1/(2 * Ntips), # xxyy$xx[phy at edge[, 2] == i],
+ height = 1, ## hc,
+ width = 1/nvars, ## hc,
+ # default.units = 'native',
+ name = paste('data_plot', i),
+ just = "center",
+ angle = -rot
+ ))
+ #grid.rect()
+ vals = tdata(phy)[,i]
+ if (!all(is.na(vals))) tip.plot.fun(vals, tmin, tmax, ...)
+ upViewport()
+ }
+ upViewport()
+ pushTree(row = 1, col = 1)
+ upViewport()
+ }
+ return(invisible())
+ } ## if (is.function(tip.plot.fun))
+ }
+}
+
+tree.plot <- function(xxyy, type, show.tip.label, show.node.label, edge.color,
+ node.color, tip.color, edge.width, rot)
+{
+ # TODO switch to phylobase abstractions
+ phy <- xxyy$phy
+ Nedges <- nEdges(phy)
+ Ntips <- nTips(phy)
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
+ eindex <- match(phy at edge[,2], xxyy$phy.orig at edge[,2])
+ segs <- segs(XXYY = xxyy)
+
+ ## TODO check that colors are valid?
+ if(length(edge.color) != Nedges) {
+ edge.color <- rep(edge.color, length.out = Nedges)
+ }
+ edge.color <- edge.color[eindex]
+
+ if(length(edge.width) != Nedges) {
+ edge.width <- rep(edge.width, length.out = Nedges)
+ }
+ edge.width <- edge.width[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]
+
+ if(show.tip.label) {
+ ## calculate several lab dimesisions
+ ## labw -- a vector of string widths
+ ## adjlabw -- the max width for adjusting the size of viewports
+ ## laboff -- a vector of half string widths for
+ ## offsetting center justified labels, handy for vp rotation
+ labw <- stringWidth(phy at tip.label)
+ adjlabw <- max(labw) + unit(0.02, 'npc')
+ ## print(foo <<- adjlabw)
+ laboff <- labw * 0.5
+ treelayout <- grid.layout(nrow = 1, ncol = 2,
+ widths = unit.c(unit(1, 'null', NULL), convertUnit(adjlabw, 'inches'))
+ )
+ tindex <- phy at edge[phy at edge[, 2] <= Ntips, 2]
+ if(length(tip.color) != Ntips) {
+ tip.color <- rep(tip.color, length.out = Ntips)
+ }
+ # keep labels horizontal unless plot is upwards or downwards
+ lrot <- ifelse(rot %% 360 %in% c(90, 270), 0, -rot)
+ } else {
+ treelayout <- grid.layout(nrow = 1, ncol = 1)
+ }
+ # grid.show.layout(treelayout)
+ pushViewport(viewport(
+ x = 0.5, y = 0.5,
+ width = 1, height = 1,
+ layout = treelayout, name = 'treelayout'))
+ pushViewport(viewport(
+ layout.pos.col = 1,
+ name = 'tree'))
+ if (type == "fan") {
+ dseg <- grid.segments( # draws diag lines
+ x0 = segs$v0x, y0 = segs$v0y,
+ x1 = segs$h1x, y1 = segs$h1y,
+ name = "diag", gp = gpar(col = edge.color, lwd = edge.width))
+ } else {
+ vseg <- grid.segments( # draws vertical lines
+ x0 = segs$v0x, y0 = segs$v0y,
+ x1 = segs$v1x, y1 = segs$v1y,
+ name = "vert", gp = gpar(col = edge.color, lwd = edge.width))
+ hseg <- grid.segments( # draws horizontal lines
+ x0 = segs$h0x, y0 = segs$h0y,
+ x1 = segs$h1x, y1 = segs$h1y,
+ name = "horz", gp = gpar(col = edge.color, lwd = edge.width))
+ }
+ upViewport()
+ if(show.tip.label) {
+ pushViewport(viewport(layout.pos.col = 2,
+ name = 'tiplabelvp'))
+ labtext <- grid.text(
+ phy at tip.label[tindex],
+ x = 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])
+ )
+ upViewport()
+ }
+ # TODO probably want to be able to adjust the location of these guys
+ if(show.node.label) {
+ pushViewport(viewport(layout = treelayout, layout.pos.col = 1))
+ rty <- mean(xxyy$yy[phy at edge[, 1] == Ntips + 1], name = 'nodelabelvp')
+ labtext <- grid.text(
+ phy at node.label,
+ x = c(0, xxyy$xx[phy at edge[, 2] > Ntips][nindex]),
+ y = c(rty, xxyy$yy[phy at edge[, 2] > Ntips][nindex]),
+ default.units = 'npc', name = 'nodelabels', rot = -rot,
+ just = 'center', gp = gpar(col = node.color[nindex])
+ )
+ upViewport()
+ }
+ upViewport()
+ # grobTree(vseg, hseg, labtext)
+}
+
+
+phyloXXYY <- function(phy, tip.order = NULL) {
+ ## initalize the output
+ Nedges <- nEdges(phy)
+ phy.orig <- phy
+ Ntips <- nTips(phy)
+ xxyy = list(
+ yy = rep(NA, Nedges),
+ xx = numeric(Nedges),
+ ## record the order that nodes are visited in
+ traverse = NULL)
+ if(is.null(edgeLength(phy))) {
+ # TODO there should be an abstraction for assigning branch lengths
+ stop('Phylogeny has no branch lengths, cannot calculate x coordinates')
+ }
+
+ # TODO tip ordering should be dealt with at a higher level
+ # if(!is.null(tip.order)) {
+ # yy[which(phy at edge[, 2] == tip.order)] <- seq(
+ ## 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
+ phy <- reorder(phy, 'pruningwise')
+ xxyy$yy[phy at edge[, 2] <= Ntips] <- seq(
+ 0, 1, length.out = Ntips
+ )
+ # }
+
+ ## a recurvise 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
+ ## prevx -- the sum of ancestral branch lengths
+ 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) {
+ decdex <- which(phy at edge[, 1] == node)
+ index <- NULL
+ ## if root node start at x = 0
+ newx <- 0
+ } else {
+ ## non-root node behavior
+ ## get row in edge matrix corresponding to node, get descendants
+ index <- which(phy at edge[, 2] == node)
+ decdex <- which(phy at edge[, 1] == phy at edge[index, 2])
+ ## non-root node x location
+ newx <- xxyy$xx[index] <- phy at edge.length[index] + prevx
+ ## if the x value is already set we are at a tip and we return
+ if(!is.na(xxyy$yy[index])) { return(xxyy) }
+ }
+ for(i in phy at edge[decdex, 2]) {
+ ## for each decendant call the function again
+ xxyy <- calc.node.xy(i, phy, xxyy, newx)
+ }
+ if(!is.null(index)) {
+ ## set y value by averaging the decendants
+ xxyy$yy[index] <- mean(xxyy$yy[decdex])
+ }
+ ## TODO performance improvement here? rely on above ordering?
+ ## keep track of the nodes and order we visited them
+ xxyy$traverse <- c(xxyy$traverse, phy at edge[decdex, 2])
+ xxyy
+ }
+ ## call function for the first time
+ xxyy <- calc.node.xy(Ntips + 1, phy, xxyy)
+ ## scale the x values
+ xxyy$xx <- xxyy$xx / max(xxyy$xx)
+ # TODO return an index vector instead of a second phy object
+ c(xxyy, phy = list(phy), phy.orig = list(phy.orig))
+}
+
+segs <- function(XXYY) {
+ phy <- XXYY$phy
+ treelen <- rep(NA, nEdges(phy) + 1)
+ segs <- list(v0x = treelen, v0y = treelen, v1x = treelen, v1y = treelen,
+ h0x = treelen, h0y = treelen, h1x = treelen, h1y = treelen)
+ troot <- nTips(phy) + 1
+
+ get.coor <- function(node, segs) {
+ if(any(phy at edge[, 2] == node) == FALSE) {
+ #root
+ decdex <- which(phy at edge[, 1] == node)
+ 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])
+ } 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)
+ }
+ 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)
+ }
+ segs
+ }
+ get.coor(troot, segs)
+}
+
+phylobubbles <- function(XXYY, square = FALSE, grid = TRUE) {
+ ## TODO add legend command
+ ## tys -- tip y coordinates
+ ## nVars -- number of traits/characters
+ ## maxr -- maximum circle radius, based on nVars or nTips
+
+ phy <- XXYY$phy
+
+ # tip y coordinates
+ tys <- XXYY$yy[phy at edge[, 2] <= nTips(phy)]
+
+ tipdata <- tdata(phy, which = "tip")
+ nVars <- ncol(tipdata) # number of bubble columns
+
+ maxr <- ifelse(ncol(tipdata) > nTips(phy), 1 / ncol(tipdata), 1 / nTips(phy))
+ tipdata <- apply(tipdata, 2,
+ function(x) (maxr * x) / max(abs(x), na.rm = TRUE))
+
+ if(nVars == 1) {
+ xpos <- 0.5
+ } else {
+ xpos <- seq(0 + maxr + 0.02, 1 - maxr - 0.02, length.out = nVars)
+ }
+
+ ## rep coordinates for filling a matrix columnwise
+ xrep <- rep(xpos, each = length(tys))
+ yrep <- rep(tys, nVars)
+ ## color bubbles
+ ccol <- ifelse(tipdata < 0, 'black', 'white')
+
+ ## generate matrices of every x and y by filling the repd value columnwise
+ ## then subset for datapoints that are NA
+ naxs <- matrix(xrep, ncol = nVars)
+ nays <- matrix(yrep, ncol = nVars)
+ dnas <- is.na(tipdata)
+ naxs <- naxs[dnas]
+ nays <- nays[dnas]
+ ## set the NA points to zero so that grid.circle doesn't crash
+ tipdata[is.na(tipdata)] <- 0
+
+ ## get label widths
+ tiplabwidth <- max(stringWidth(phy at tip.label))
+ datalabwidth <- max(stringWidth(colnames(tipdata)))
+
+ ## 2x2 layout -- room at the bottom for data labels, and legend
+ bublayout <- grid.layout(nrow = 2, ncol = 2,
+ widths = unit.c(unit(1, 'null', NULL), tiplabwidth),
+ heights = unit.c(unit(1, 'null', NULL), datalabwidth * 1.2))
+ pushViewport(viewport(
+ x = 0.5, y = 0.5,
+ width = 0.95, height = 1,
+ layout = bublayout, name = 'bublayout'
+ ))
+ pushViewport(viewport(
+ name = 'bubble_plots',
+ layout = bublayout,
+ layout.pos.col = 1,
+ layout.pos.row = 1
+ ))
+ if(grid) {
+ ## draw light grey grid behind bubbles
+ grid.segments(x0 = 0, x1 = 1,
+ y0 = tys, y1 = tys, gp = gpar(col = 'grey'))
+ grid.segments(x0 = xpos, x1 = xpos,
+ y0 = 0, y1 = 1, gp = gpar(col = 'grey'))
+ }
+ if (length(naxs) > 0) {
+ ## if ther are missing values plot Xs
+ grid.points(naxs, nays, pch = 4)
+ }
+ if(square) {
+ ## alternative to circles
+ ## to keep the squares square, yet resize nicely use the square npc
+ sqedge <- unit(unlist(tipdata), 'snpc')
+ grid.rect(x = xrep, y = yrep,
+ width = sqedge,
+ height = sqedge,
+ gp=gpar(fill = ccol))
+ } else {
+ ## plot bubbles
+ grid.circle(xrep, yrep, r = unlist(tipdata), gp = gpar(fill = ccol))
+ }
+ # catch a value for scaling other output
+ bubscale <- convertUnit(unit(max(tipdata, na.rm = TRUE), 'npc'), 'inches')
+ upViewport()
+
+ ## push view ports for tip and data labels fixed locations
+ pushViewport(viewport(
+ name = 'bubble_tip_labels',
+ layout = bublayout,
+ layout.pos.col = 2,
+ layout.pos.row = 1
+ ))
+ grid.text(phy at tip.label, 0.1, tys, just = 'left')
+ upViewport()
+ pushViewport(viewport(
+ name = 'bubble_data_labels',
+ layout = bublayout,
+ layout.pos.col = 1,
+ layout.pos.row = 2
+ ))
+ grid.text(colnames(tipdata), xpos, .65, rot = 90, just = 'right')
+
+ upViewport(2)
+ # to make a nice legend, return the biggest smallest and a scaling factor
+ # translate the scale of the current vp to a fixed value
+ ## ensure the min is not a zero (or NA) that's replaced by a zero
+ ## print(convertUnit(bubscale, 'inches', valueOnly = TRUE))
+ return(list(max = max(tipdata, na.rm = TRUE),
+ min = min(tipdata[tipdata != 0], na.rm = TRUE),
+ has.na = length(naxs) > 0,
+ bubscale = bubscale))
+}
+
+setGeneric("treePlot", useAsDefault = treePlot)
+setMethod("treePlot", signature = c('phylo4', 'phylo4d'), treePlot)
+
+# gridbasefun <- function(f, naked = TRUE, scale = TRUE) {
+# function(x, tmin, tmax, ...) {
+# require(gridBase)
+# op <- par()
+# if (naked) {
+# par(ann = FALSE, mar = rep(0, 4))
+# ## this could take a bit of hacking
+# ## to work nicely in general -- too bad
+# ## par(ann=FALSE) doesn't work in general
+# ## Could set main="", xlab="", ylab="", axes=FALSE
+# ## but this will break
+# }
+# ## this must be the *last* par() call
+# suppressWarnings(par(plt = gridPLT(), new = TRUE))
+# if(!all(is.na(x))) {
+# f(x, xlim = c(tmin, tmax), ...)
+# }
+# }
+# }
+#
Modified: pkg/inst/doc/phylobase.pdf
===================================================================
--- pkg/inst/doc/phylobase.pdf 2008-12-19 00:51:34 UTC (rev 312)
+++ pkg/inst/doc/phylobase.pdf 2008-12-19 02:07:55 UTC (rev 313)
@@ -93,6 +93,7 @@
65 0 obj
<< /S /GoTo /D (subsection.A.3) >>
endobj
+<<<<<<< .working
68 0 obj
(multiphylo4)
endobj
@@ -113,9 +114,14 @@
endobj
98 0 obj <<
/Length 1262
+=======
+83 0 obj <<
+/Length 1281
+>>>>>>> .merge-right.r312
/Filter /FlateDecode
>>
stream
+<<<<<<< .working
xÚÕXKsÛ6¾ûWðÔgJo§ŽíÆi{©§Q{I{`$ÚÒX2= Õÿ>»XPJª•f¦i$AØo÷Ãb±K‘Ýg"{{!N<¯Æ£m2Yr%ÉÆwÐ Ü—6sÒr T6žfïÙ8—lWÿ5þf„ÝZq2
}¡/p[4p3i „õ\•ºŸð.+´l‚Ó*¸ðªWØ+XõoSj/khw¨J“ÊA7ŽJdRò`BŒBnÍ
å¹’ ®pö#HR–]¡z ¸ rU2üÐâǾ£ï·±»C£[ê¹nråÙû«(`3e¸`4×ÀZ„ù'Mê%ÿÕÜï¡ù= TÐnž,0:“†kãÈ© 7Îg…‚CI²¯›D¡VdàB£"kï3jüöÖÖø,ðà”C‰Ô†d%ó"€?ƒ ź–8Õ"rú פ›7½ÉÞƒ="(˜} sƒâ EÊ-*ZMðþ;êûèN…öšý
@@ -128,6 +134,18 @@
à’>páí~<¥¢FÇ2_Ð'k\ú’²Q\ ¶¸,1‹ý˜@¦5
ªh rüˆýwHÁn± c¢L–lò˜z×´[ >S„á±6yJŽP¯ê]%«½”æ6w[
÷cÕ}œu+{ž*]àÚá¯À½÷½;îŽy3¾ø%Ý
+=======
+xÚÝWÉrã6½û+xJU!„ pŒñ$s‰kFÉe’G¢%•%ÑEÑvü÷éÔTÉ$ xÝƃÊf™ÊÞ_©7¾×ã«Ñu™®¤Ñ¥ËÆ÷PŒ2Teæu)m4Ùxš}ã\‹9<MþÛøŒˆû#¬‘æPÜõ»¾ÂkÙÂË¥e¦²Ã€OÔ°J‹ «áµÁ§Ù`«õjS.¯(÷hJ›ÆC3v& £2e,Kƒ…u²,ˬ0A†¨êG¯a&SŠk4o ÏCn*?:üáÅ7üÿŽš{tºã–›67A¼`{Mó lfƒ,U +-°F0 žÒÔ¯<0|Ë_M
+ŸÀ;›i'ól±vJV¾Ê
+gd‘çºi Ê‚×ͶD _i`PeÝ,ãÂÇ÷°–.dQFo<ΨÀ,`DW<•Î‹VüsÑwÌ¡UÄ!Z<éíà×6B²Ï@³ŠFŸÇÜ¢F1Œr‡†Ö|?äÞ‰zFáSØ`ÅOP|F#šŽJZ,š—TË”]†jõg ‡9¡Å Ñ GKB b
+š©uùÈ•
+-Œ%’WǶèèŒËlqlË8^ ƒ
+2 ¿ §}ÚJHõSÏð¸u_ŸP`BP¼….€-/€e´+§h®tJø?CKÁäíSŠ/´aqÞ~ÁÜ Ï^iåE¸Ð—êÄ—â¦^> 3çÊ+/DŒ°Â ¶k¿¸›#JÊ^@lŠe=$£“ 50Á¥x‘ñÞÁ\¿×+xcž\ž™µòZ]<ëwyáÁï‘¢_•v)òäL›jhÿ¿Ëvý)ªÓ•yut»ŸU eEç ]Q²MvH˜òKUYñ8Ç4ùš8mÝ1VYz!óÂňŸ’ú®vösA—£ç?›ì8ƒxí¿CëùÕ=aÕœguzŒPUá?DÏ_îŗ>µú;„Z&t…ç8íü>íR.Øú•Ø
+îÿ ¦Ñz$3Š!#ìg¦kÈLpÖü’Dz62< ¦ÜW>ŠH ÐIœ”Â›É Ä XFê²Ôxø(~Èw2Rà(U»&>Wºi2¨¥óŸƒ¡îØw±ä”Ì>Ù×¥1;»Ž5 Øê8"OIil«äPv&ö4¡@ÜJ°Ã¬ËÞ•¼Ï›pÆ; Írx‚½jÖ˜+@[8ÅÍfÒ¥þ_¨_“†õ[]OU¤ž•ØèöÌ^Î/tU8ÐøI2
+‡Š;µÙ–Ò«êHç;›t>¼Á³i0fÐùXÆ%hvR ŽE1ž ¤A¦ˆ—Áý î×9{Zwt=x QªP î}V…Л$=V0 \w8úú¤†1Óòš@Ïç2m¸SÍ ã5¶ß#ûj~nH[‘'u—î-0ô¾ív@ƒ …î$n‘ˆhö¬‡ÄÔ®yl{¿³ð0QÍšuòªgV‡£ä×(È·Aw€*àr´«G²w úŒ1Ô`›ô)‰FªÃ ¥ %Ç{wÃøñVz¿7´“JiNcÈEY)»?AMkþC>¨gÉ@¾”%¿h]Ù|yäOÎöC at Y1GÂà
+ at Ac4Üàô kÒ†åÝÒöa Ëš!B5‹FZ¯nÃ
+õÞÏsvbû¦ui#k¤ƒŽùí,|MÃ`¤HL‹³ž%LþLÚÕ*Å V7OÛTË[Ú0vð»u_´Ëáî¼KhÚGi=ì §áòo‡¬µßçÝøê™Z™=
+>>>>>>> .merge-right.r312
endstream
endobj
78 0 obj <<
@@ -517,11 +535,17 @@
/Font << /F8 107 0 R /F55 108 0 R /F61 120 0 R /F57 114 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
+<<<<<<< .working
140 0 obj <<
/Length 2091
+=======
+125 0 obj <<
+/Length 2090
+>>>>>>> .merge-right.r312
/Filter /FlateDecode
>>
stream
+<<<<<<< .working
xÚÝXKãƾï¯ì%2êe?Ødo 1;AÈÁö£×*Þ‘"µÞòãS/6»)J«I ÈÉ®êzUÍân{WÜýéM!ÿ_=¼y÷uYÞ¼ñw›;mkêpçËJ[Þ=¬î¾Ÿýe®g;¸öp©ùB—•ž½‡{KÏzàªà*eí½ú®‚x®ÓëÑþîFz-<zþãßÁÐ…Ö*”b .¶puóEiììop{¾÷$cØ£¦}xÿ/°™DUóz¶^Zu[êwÉPôÒ®•x«!Ñ~©¡F™ï
[j(ÇñUlV´×¯c+$ì5C…7¦ÃØB?’9¦OM :^¢·ñº¾×Mƒ É!WÓÓ=CÔ¾ÀfÑ6IÏ/°õ;a+^Çf…µÊ õCÔÐCŸGEì™f”`Sô6ñH5ŠÚ}¯\%÷åôµÜ»©¨} ¿Ç…w_{“Âi¡œÓ@MT¿bŠ pKeLè Ú 0+âÅk—DUµ²…ÿ¿UýB¢0p ãJeC™Ço ëé(/‚½ÿúBÕµ>Gœk
ȉÈÿ¤é$ß åçë±=ížòöB~ ¦ô¥„¿L¼.qâ¼T©ÿŸU\L€ `¬‚?âúV áú§¸p9„s™dR'ö©Ò2ÉžH’[Žãš_„©gVlBÚèTp4èzPé8_XWÎN-ívn¹5Ê®7½¹©° Š²à?}.ÖÂm]¥ìèÉŸ;ɈfÙ±øâÛ…«†…‡ÈÙ‰Ç×øs?¡±.Ô¸Aå$δê΃êÑr¢¡œsµ™}E5Ï:¢%›3ù£ˆ˜ÒÊ[U9öj?. Ñ”ö!OèŸw"õã|a ør-û w’eŸæ¦Boâ*.ìžùž„“ä{xá ¥æ©ãÅ—¹©g‡?,›=ß4(¨=àƒ™m×BËy
@@ -533,6 +557,29 @@
à¸ù¸©)Reëêƒô _ÈÝòúþ2#œMüu6
êï9‘~B®1TÏ£þË æeȽٻ½ÌI”v4*aï¦Y’j¼í$¤aÉ<?_ ŽOªÀ9!=u$sJE@üxŠm7ß.kîpX2ÑiÛ àõP¸ôǯ–rBsx›–ȧgìC{ó ¬065“ñPâ(A½ŠÈûsÜ 9‘ÓÈ´k¾sPwÁ”g¾YË9üFßÀ\R…_Þ7tâ¸à›zvºÙ1+IÕÃóuŸ°™OžoÙ\1 ж Î0™ñ& “âa
öêâp¤à?/ZŠx° œ¬Ñ ¸wOÝQ“;XÐÝñp at QNœÈM(¸+‹¼%–~àâ é‹eÁÎðf}Ž(¶ƒïióv(lÚæ3öµ ÀŒŠ*‚ ¨lÁ Ri{胮egPÃWŽ<>¾àvPŒ´eÈŠ“^·‰½=Q˜2G‚ÏMíÎm’ŽÒ°W͘˿_ÀwMÚ;ö[^ÙôÉü$¡€¬µ6‡ý8J1eùÅG(pÍ¡ñ"{æú˜C-O.ã~8*³ 4:¶XæË4 ¤UY3ªa<(ÓSÓé£h²¥©´}ÞŒ¾ãeŠ8ê,&¶·Êê* +–óÒàQ}Íãä–õ0S eñ^¾.ê,[V¥aÆïøËÝôsvú¸gê´-¶rîŒ JZó)ÿ4øÛá£ìùv·¯þ˜˜œ½[ ß²{¶ƒ¤V§õ3²'áÞÊŽýzˆ_±ù9gŸ82ü³Y"H?’Þ¶aÔ§öFØW1oòÑùîLhÀ ëKžumÅZÖà Þü9Œñ
+=======
+xÚíËŽë¶u¿Â¸›ÚȘ)J¢¤@“6A4éc€.’,4¶ìëd,
+,ùæÐïyQ"eyê‚ ‹.hIäyñ¼I'‹ý"Y|õ&‘çç÷o>þ2Ë¥*s“/îw :Uºr‘g…2i¶¸ß.¾_~»ÒË?~¼ÿ€‹8QÖj DPˆœQEž{€nµÖY¡—Ÿ 9
+CÁH†Ák×XN¥IñÛ±Êÿ«âwÇ
+k°™Êl¶XkÊLì·‡õFãFã_Ÿ(çt þWX>¸šai…¥&IŒ¬…~¿Zg&]þ ^Ï‚ÒpB'›£Ô0¶"HE½F #‡a"yLCp‡M˜@oš„˜ …… 0» Oà ãÊ&ù‡‰=2J^Ðsù7‰8r í”5 G•š±¾ƒÕ?‰
+7£97'õ²Aï* ƒ4¼² kžÚ
+’GV¼îѪÒZ’ÌØré´Z§6[ž;¢v¹óÔ(›X¿õ^ø†Ì~H²„ ú’m
+¯®Ñ[d˜“
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 313
More information about the Phylobase-commits
mailing list