R/nodelabels.R

   1 ## nodelabels.R (2010-07-17)
   2
   3 ##   Labelling Trees
   4
   5 ## Copyright 2004-2010 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, horiz, width, height, ...)
  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
  88         if (is.null(width)) {
  89             width <- CEX * (parusr[2] - parusr[1])
  90             width <- if (horiz) width/15 else width/40
  91         }
  92
  93         if (is.null(height)) {
  94             height <- CEX * (parusr[4] - parusr[3])
  95             height <- if (horiz) height/40 else height/15
  96         }
  97
  98         if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo)
  99         thermo <- if (horiz) width * thermo else height * thermo
 100         if (is.null(piecol)) piecol <- rainbow(ncol(thermo))
 101
 102         xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30)
 103         xr <- xl + width
 104         yb <- YY - height/2 + adj[2] - 0.5
 105         yt <- yb + height
 106
 107         if (horiz) {
 108             ## draw the first rectangle:
 109             rect(xl, yb, xl + thermo[, 1], yt, border = NA, col = piecol[1])
 110             for (i in 2:ncol(thermo))
 111                 rect(xl + rowSums(thermo[, 1:(i - 1), drop = FALSE]), yb,
 112                      xl + rowSums(thermo[, 1:i]), yt, border = NA, col = piecol[i])
 113         } else {
 114             ## draw the first rectangle:
 115             rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1])
 116             for (i in 2:ncol(thermo))
 117                 rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]),
 118                      xr, yb + rowSums(thermo[, 1:i]),
 119                      border = NA, col = piecol[i])
 120         }
 121
 122         ## check for NA's before drawing the borders
 123         s <- apply(thermo, 1, function(xx) any(is.na(xx)))
 124         xl[s] <-  xr[s] <- NA
 125         rect(xl, yb, xr, yt, border = "black")
 126
 127         if (!horiz) {
 128             segments(xl, YY, xl - width/5, YY)
 129             segments(xr, YY, xr + width/5, YY)
 130         }
 131     }
 132     ## from BB:
 133     if (!is.null(pie)) {
 134         if (is.vector(pie)) pie <- cbind(pie, 1 - pie)
 135         xrad <- CEX * diff(par("usr")[1:2]) / 50
 136         xrad <- rep(xrad, length(sel))
 137         XX <- XX + adj[1] - 0.5
 138         YY <- YY + adj[2] - 0.5
 139         for (i in 1:length(sel)) {
 140             if (any(is.na(pie[i, ]))) next
 141             floating.pie.asp(XX[i], YY[i], pie[i, ], radius = xrad[i], col = piecol)
 142         }
 143     }
 144     if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...)
 145     if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5,
 146                               pch = pch, col = col, bg = bg, ...)
 147 }
 148
 149 nodelabels <-
 150     function(text, node, adj = c(0.5, 0.5), frame = "rect",
 151              pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 152              col = "black", bg = "lightblue", horiz = FALSE,
 153              width = NULL, height = NULL, ...)
 154 {
 155     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 156     if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx)
 157     XX <- lastPP$xx[node]
 158     YY <- lastPP$yy[node]
 159     BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
 160                pie, piecol, col, bg, horiz, width, height, ...)
 161 }
 162
 163 tiplabels <-
 164     function(text, tip, adj = c(0.5, 0.5), frame = "rect",
 165              pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 166              col = "black", bg = "yellow", horiz = FALSE,
 167              width = NULL, height = NULL, ...)
 168 {
 169     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 170     if (missing(tip)) tip <- 1:lastPP$Ntip
 171     XX <- lastPP$xx[tip]
 172     YY <- lastPP$yy[tip]
 173     BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
 174                pie, piecol, col, bg, horiz, width, height, ...)
 175 }
 176
 177 edgelabels <-
 178     function(text, edge, adj = c(0.5, 0.5), frame = "rect",
 179              pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 180              col = "black", bg = "lightgreen", horiz = FALSE,
 181              width = NULL, height = NULL, ...)
 182 {
 183     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 184     if (missing(edge)) {
 185         sel <- 1:dim(lastPP$edge)[1]
 186         subedge <- lastPP$edge
 187     } else {
 188         sel <- edge
 189         subedge <- lastPP$edge[sel, , drop = FALSE]
 190     }
 191     if (lastPP$type == "phylogram") {
 192         if (lastPP$direction %in% c("rightwards", "leftwards")) {
 193             XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
 194             YY <- lastPP$yy[subedge[, 2]]
 195         } else {
 196             XX <- lastPP$xx[subedge[, 2]]
 197             YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
 198         }
 199     } else {
 200         XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
 201         YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
 202     }
 203     BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
 204                pie, piecol, col, bg, horiz, width, height, ...)
 205 }
 206
 207 edges <- function(nodes0, nodes1, arrows = 0, type = "classical", ...)
 208 {
 209     type <- match.arg(type, c("classical", "triangle", "harpoon"))
 210     lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 211     ## we do the recycling if necessary:
 212     if (length(nodes0) != length(nodes1)) {
 213         tmp <- cbind(nodes0, nodes1)
 214         nodes0 <- tmp[, 1]
 215         nodes1 <- tmp[, 2]
 216     }
 217     x0 <- lastPP$xx[nodes0]
 218     y0 <- lastPP$yy[nodes0]
 219     x1 <- lastPP$xx[nodes1]
 220     y1 <- lastPP$yy[nodes1]
 221     if (arrows)
 222         if (type == "classical")
 223             graphics::arrows(x0, y0, x1, y1, code = arrows, ...)
 224         else
 225             fancyarrows(x0, y0, x1, y1, code = arrows, type = type, ...)
 226     else
 227         graphics::segments(x0, y0, x1, y1, ...)
 228 }
 229
 230 fancyarrows <-
 231     function(x0, y0, x1, y1, length = 0.25, angle = 30, code = 2,
 232              col = par("fg"), lty = par("lty"), lwd = par("lwd"),
 233              type = "triangle", ...)
 234 {
 235     foo <- function(x0, y0, x1, y1) {
 236         ## important to correct with these parameters cause
 237         ## the coordinate system will likely not be Cartesian
 238         pin <- par("pin")
 239         usr <- par("usr")
 240         A1 <- pin[1]/diff(usr[1:2])
 241         A2 <- pin[2]/diff(usr[3:4])
 242         x0 <- x0 * A1
 243         y0 <- y0 * A2
 244         x1 <- x1 * A1
 245         y1 <- y1 * A2
 246         atan2(y1 - y0, x1 - x0)
 247     }
 248     arrow.triangle <- function(x, y) {
 249         beta <- alpha - angle/2
 250         xa <- xinch(length * cos(beta)) + x
 251         ya <- yinch(length * sin(beta)) + y
 252         beta <- beta + angle
 253         xb <- xinch(length * cos(beta)) + x
 254         yb <- yinch(length * sin(beta)) + y
 255         n <- length(x)
 256         col <- rep(col, length.out = n)
 257         for (i in 1:n)
 258             polygon(c(x[i], xa[i], xb[i]), c(y[i], ya[i], yb[i]),
 259                     col = col[i], border = col[i])
 260         list((xa + xb)/2, (ya + yb)/2)
 261     }
 262     arrow.harpoon <- function(x, y) {
 263         beta <- alpha - angle/2
 264         xa <- xinch(length * cos(beta)) + x
 265         ya <- yinch(length * sin(beta)) + y
 266         beta <- alpha + angle/2
 267         xb <- xinch(length * cos(beta)) + x
 268         yb <- yinch(length * sin(beta)) + y
 269         xc <- x/2 + (xa + xb)/4
 270         yc <- y/2 + (ya + yb)/4
 271         n <- length(x)
 272         col <- rep(col, length.out = n)
 273         for (i in 1:n)
 274             polygon(c(x[i], xa[i], xc[i], xb[i]),
 275                     c(y[i], ya[i], yc[i], yb[i]),
 276                     col = col[i], border = col[i])
 277         list(xc, yc)
 278     }
 279
 280     type <- match.arg(type, c("triangle", "harpoon"))
 281     angle <- pi*angle/180 # degree -> radian
 282     alpha <- foo(x0, y0, x1, y1) # angle of segment with x-axis
 283     ## alpha is in [-pi, pi]
 284
 285     FUN <- if (type == "triangle") arrow.triangle else arrow.harpoon
 286     XY0 <- if (code == 1 || code == 3) FUN(x0, y0) else list(x0, y0)
 287     if (code >= 2) {
 288         alpha <- (alpha + pi) %% (2 * pi)
 289         XY1 <- FUN(x1, y1)
 290     } else XY1 <- list(x1, y1)
 291     segments(XY0[[1]], XY0[[2]], XY1[[1]], XY1[[2]], col = col, lty = lty, lwd = lwd, ...)
 292 }