X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Fnodelabels.R;h=152761d182545a6fc3e73c9e57af81c45b59d0ab;hb=bfd7604547c1dd38cd97707c184bebf3525cf426;hp=9d5b39ce46d9fde1206a47b4c5e67e50fcd2492e;hpb=6fe5709ee413e5a1a379918a70c64cee05e9ae54;p=ape.git diff --git a/R/nodelabels.R b/R/nodelabels.R index 9d5b39c..152761d 100644 --- a/R/nodelabels.R +++ b/R/nodelabels.R @@ -1,8 +1,8 @@ -## nodelabels.R (2010-03-12) +## nodelabels.R (2012-02-10) ## Labelling Trees -## Copyright 2004-2010 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon +## Copyright 2004-2012 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. @@ -46,7 +46,7 @@ floating.pie.asp <- function(xpos, ypos, x, edges = 200, radius = 1, } BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo, - pie, piecol, col, bg, ...) + pie, piecol, col, bg, horiz, width, height, ...) { if (missing(text)) text <- NULL if (length(adj) == 1) adj <- c(adj, 0.5) @@ -84,26 +84,50 @@ BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo, } if (!is.null(thermo)) { parusr <- par("usr") - width <- CEX * (parusr[2] - parusr[1]) / 40 - height <- CEX * (parusr[4] - parusr[3]) / 15 + + if (is.null(width)) { + width <- CEX * (parusr[2] - parusr[1]) + width <- if (horiz) width/15 else width/40 + } + + if (is.null(height)) { + height <- CEX * (parusr[4] - parusr[3]) + height <- if (horiz) height/40 else height/15 + } + if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo) - thermo <- height * thermo + thermo <- if (horiz) width * thermo else height * thermo + if (is.null(piecol)) piecol <- rainbow(ncol(thermo)) + xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30) xr <- xl + width yb <- YY - height/2 + adj[2] - 0.5 - if (is.null(piecol)) piecol <- rainbow(ncol(thermo)) - ## draw the first rectangle: - rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1]) - for (i in 2:ncol(thermo)) - rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]), - xr, yb + rowSums(thermo[, 1:i]), - border = NA, col = piecol[i]) + yt <- yb + height + + if (horiz) { + ## draw the first rectangle: + rect(xl, yb, xl + thermo[, 1], yt, border = NA, col = piecol[1]) + for (i in 2:ncol(thermo)) + rect(xl + rowSums(thermo[, 1:(i - 1), drop = FALSE]), yb, + xl + rowSums(thermo[, 1:i]), yt, border = NA, col = piecol[i]) + } else { + ## draw the first rectangle: + rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1]) + for (i in 2:ncol(thermo)) + rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]), + xr, yb + rowSums(thermo[, 1:i]), + border = NA, col = piecol[i]) + } + ## check for NA's before drawing the borders s <- apply(thermo, 1, function(xx) any(is.na(xx))) xl[s] <- xr[s] <- NA - rect(xl, yb, xr, yb + height, border = "black") - segments(xl, YY, xl - width/5, YY) - segments(xr, YY, xr + width/5, YY) + rect(xl, yb, xr, yt, border = "black") + + if (!horiz) { + segments(xl, YY, xl - width/5, YY) + segments(xr, YY, xr + width/5, YY) + } } ## from BB: if (!is.null(pie)) { @@ -122,33 +146,39 @@ BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo, pch = pch, col = col, bg = bg, ...) } -nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect", - pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, - col = "black", bg = "lightblue", ...) +nodelabels <- + function(text, node, adj = c(0.5, 0.5), frame = "rect", + pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, + col = "black", bg = "lightblue", horiz = FALSE, + width = NULL, height = NULL, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx) XX <- lastPP$xx[node] YY <- lastPP$yy[node] BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo, - pie, piecol, col, bg, ...) + pie, piecol, col, bg, horiz, width, height, ...) } -tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect", - pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, - col = "black", bg = "yellow", ...) +tiplabels <- + function(text, tip, adj = c(0.5, 0.5), frame = "rect", + pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, + col = "black", bg = "yellow", horiz = FALSE, + width = NULL, height = NULL, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(tip)) tip <- 1:lastPP$Ntip XX <- lastPP$xx[tip] YY <- lastPP$yy[tip] BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo, - pie, piecol, col, bg, ...) + pie, piecol, col, bg, horiz, width, height, ...) } -edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect", - pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, - col = "black", bg = "lightgreen", ...) +edgelabels <- + function(text, edge, adj = c(0.5, 0.5), frame = "rect", + pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, + col = "black", bg = "lightgreen", horiz = FALSE, + width = NULL, height = NULL, date = NULL, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(edge)) { @@ -170,8 +200,13 @@ edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect", XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2 YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2 } + + ## suggestion by Rob Lanfear: + if (!is.null(date)) + XX[] <- max(lastPP$xx) - date + BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo, - pie, piecol, col, bg, ...) + pie, piecol, col, bg, horiz, width, height, ...) } edges <- function(nodes0, nodes1, arrows = 0, type = "classical", ...)