R/nodelabels.R

   1 ## nodelabels.R (2009-09-30)
   2
   3 ##   Labelling Trees
   4
   5 ## Copyright 2004-2009 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 ## from JL:
  11 ## floating.pie() from plotrix with two changes:
  12 ## (1) aspect ratio fixed, so pies will appear circular
  13 ##     (`radius' is the radius in user coordinates along the x axis);
  14 ## (2) zero values allowed (but not negative).
  15
  16 floating.pie.asp <- function(xpos, ypos, x, edges = 200, radius = 1,
  17                              col = NULL, startpos = 0, ...)
  18 {
  19     u <- par("usr")
  20     user.asp <- diff(u[3:4])/diff(u[1:2])
  21     p <- par("pin")
  22     inches.asp <- p[2]/p[1]
  23     asp <- user.asp/inches.asp
  24     if (!is.numeric(x) || any(is.na(x) | x < 0)) {
  25       ## browser()
  26       stop("floating.pie: x values must be non-negative")
  27     }
  28     x <- c(0, cumsum(x)/sum(x))
  29     dx <- diff(x)
  30     nx <- length(dx)
  31     if (is.null(col)) col <- rainbow(nx)
  32     else if (length(col) < nx) col <- rep(col, nx)
  33     bc <- 2 * pi * (x[1:nx] + dx/2) + startpos
  34     for (i in 1:nx) {
  35         n <- max(2, floor(edges * dx[i]))
  36         t2p <- 2 * pi * seq(x[i], x[i + 1], length = n) + startpos
  37         xc <- c(cos(t2p) * radius + xpos, xpos)
  38         yc <- c(sin(t2p) * radius*asp + ypos, ypos)
  39         polygon(xc, yc, col = col[i], ...)
  40         ## t2p <- 2 * pi * mean(x[i + 0:1]) + startpos
  41         ## xc <- cos(t2p) * radius
  42         ## yc <- sin(t2p) * radius*asp
  43         ## lines(c(1, 1.05) * xc, c(1, 1.05) * yc)
  44     }
  45     ## return(bc)
  46 }
  47
  48 BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
  49                        pie, piecol, col, bg, ...)
  50 {
  51     if (missing(text)) text <- NULL
  52     if (length(adj) == 1) adj <- c(adj, 0.5)
  53     if (is.null(text) && is.null(pch) && is.null(thermo) && is.null(pie))
  54       text <- as.character(sel)
  55     frame <- match.arg(frame, c("rect", "circle", "none"))
  56     args <- list(...)
  57     CEX <- if ("cex" %in% names(args)) args$cex else par("cex")
  58     if (frame != "none" && !is.null(text)) {
  59         if (frame == "rect") {
  60             width <- strwidth(text, units = "inches", cex = CEX)
  61             height <- strheight(text, units = "inches", cex = CEX)
  62             if ("srt" %in% names(args)) {
  63                 args$srt <- args$srt %% 360 # just in case srt >= 360
  64                 if (args$srt == 90 || args$srt == 270) {
  65                     tmp <- width
  66                     width <- height
  67                     height <- tmp
  68                 } else if (args$srt != 0)
  69                   warning("only right angle rotation of frame is supported;\n         try  `frame = \"n\"' instead.\n")
  70             }
  71             width <- xinch(width)
  72             height <- yinch(height)
  73             xl <- XX - width*adj[1] - xinch(0.03)
  74             xr <- xl + width + xinch(0.03)
  75             yb <- YY - height*adj[2] - yinch(0.02)
  76             yt <- yb + height + yinch(0.05)
  77             rect(xl, yb, xr, yt, col = bg)
  78         }
  79         if (frame == "circle") {
  80             radii <- 0.8*apply(cbind(strheight(text, units = "inches", cex = CEX),
  81                                      strwidth(text, units = "inches", cex = CEX)), 1, max)
  82             symbols(XX, YY, circles = radii, inches = max(radii), add = TRUE, bg = bg)
  83         }
  84     }
  85     if (!is.null(thermo)) {
  86         parusr <- par("usr")
  87         width <- CEX * (parusr[2] - parusr[1]) / 40
  88         height <- CEX * (parusr[4] - parusr[3]) / 15
  89         if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo)
  90         thermo <- height * thermo
  91         xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30)
  92         xr <- xl + width
  93         yb <- YY - height/2 + adj[2] - 0.5
  94         if (is.null(piecol)) piecol <- rainbow(ncol(thermo))
  95         ## draw the first rectangle:
  96         rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1])
  97         for (i in 2:ncol(thermo))
  98             rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]),
  99                  xr, yb + rowSums(thermo[, 1:i]),
 100                  border = NA, col = piecol[i])
 101         rect(xl, yb, xr, yb + height, border = "black")
 102         segments(xl, YY, xl - width/5, YY)
 103         segments(xr, YY, xr + width/5, YY)
 104     }
 105     ## from BB:
 106     if (!is.null(pie)) {
 107         if (is.vector(pie)) pie <- cbind(pie, 1 - pie)
 108         xrad <- CEX * diff(par("usr")[1:2]) / 50
 109         xrad <- rep(xrad, length(sel))
 110         XX <- XX + adj[1] - 0.5
 111         YY <- YY + adj[2] - 0.5
 112         for (i in 1:length(sel))
 113             floating.pie.asp(XX[i], YY[i], pie[i, ], radius = xrad[i], col = piecol)
 114     }
 115     if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...)
 116     if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5,
 117                               pch = pch, col = col, bg = bg, ...)
 118 }
 119
 120 nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect",
 121                        pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 122                        col = "black", bg = "lightblue", ...)
 123 {
 124     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 125     if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx)
 126     XX <- lastPP$xx[node]
 127     YY <- lastPP$yy[node]
 128     BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
 129                pie, piecol, col, bg, ...)
 130 }
 131
 132 tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect",
 133                       pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 134                       col = "black", bg = "yellow", ...)
 135 {
 136     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 137     if (missing(tip)) tip <- 1:lastPP$Ntip
 138     XX <- lastPP$xx[tip]
 139     YY <- lastPP$yy[tip]
 140     BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
 141                pie, piecol, col, bg, ...)
 142 }
 143
 144 edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect",
 145                       pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 146                       col = "black", bg = "lightgreen", ...)
 147 {
 148     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 149     if (missing(edge)) {
 150         sel <- 1:dim(lastPP$edge)[1]
 151         subedge <- lastPP$edge
 152     } else {
 153         sel <- edge
 154         subedge <- lastPP$edge[sel, , drop = FALSE]
 155     }
 156     if (lastPP$type == "phylogram") {
 157         if (lastPP$direction %in% c("rightwards", "leftwards")) {
 158             XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
 159             YY <- lastPP$yy[subedge[, 2]]
 160         } else {
 161             XX <- lastPP$xx[subedge[, 2]]
 162             YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
 163         }
 164     } else {
 165         XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
 166         YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
 167     }
 168     BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
 169                pie, piecol, col, bg, ...)
 170 }