R/nodelabels.R

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