R/nodelabels.R

   1 ## nodelabels.R (2008-02-08)
   2
   3 ##   Labelling Trees
   4
   5 ## Copyright 2004-2008 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
  92         xr <- xl + width
  93         yb <- YY - height/2
  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         for (i in 1:length(sel))
 110           floating.pie.asp(XX[i], YY[i], pie[i, ],
 111                            radius = xrad, col = piecol)
 112     }
 113     if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...)
 114     if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5,
 115                               pch = pch, col = col, bg = bg, ...)
 116 }
 117
 118 nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect",
 119                        pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 120                        col = "black", bg = "lightblue", ...)
 121 {
 122     xx <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv)
 123     yy <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv)
 124     if (missing(node))
 125         node <- (get("last_plot.phylo$Ntip",
 126                      envir = .PlotPhyloEnv) + 1):length(xx)
 127     XX <- xx[node]
 128     YY <- yy[node]
 129     BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
 130                pie, piecol, col, bg, ...)
 131 }
 132
 133 tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect",
 134                       pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 135                       col = "black", bg = "yellow", ...)
 136 {
 137     if (missing(tip))
 138         tip <- 1:get("last_plot.phylo$Ntip", envir = .PlotPhyloEnv)
 139     XX <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv)[tip]
 140     YY <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv)[tip]
 141     BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
 142                pie, piecol, col, bg, ...)
 143 }
 144
 145 edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect",
 146                       pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
 147                       col = "black", bg = "lightgreen", ...)
 148 {
 149     xx <- get("last_plot.phylo$xx", envir = .PlotPhyloEnv)
 150     yy <- get("last_plot.phylo$yy", envir = .PlotPhyloEnv)
 151     lastEdge <- get("last_plot.phylo$edge", envir = .PlotPhyloEnv)
 152     if (missing(edge)) {
 153         sel <- 1:dim(lastEdge)[1]
 154         subedge <- lastEdge
 155     } else {
 156         sel <- edge
 157         subedge <- lastEdge[sel, , drop = FALSE]
 158     }
 159     if (get("last_plot.phylo$type", envir = .PlotPhyloEnv) == "phylogram") {
 160         if(get("last_plot.phylo$direction", envir = .PlotPhyloEnv)
 161            %in% c("rightwards", "leftwards")) {
 162             XX <- (xx[subedge[, 1]] + xx[subedge[, 2]]) / 2
 163             YY <- yy[subedge[, 2]]
 164         } else {
 165             XX <- xx[subedge[, 2]]
 166             YY <- (yy[subedge[, 1]] + yy[subedge[, 2]]) / 2
 167         }
 168     } else {
 169         XX <- (xx[subedge[, 1]] + xx[subedge[, 2]]) / 2
 170         YY <- (yy[subedge[, 1]] + yy[subedge[, 2]]) / 2
 171     }
 172     BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
 173                pie, piecol, col, bg, ...)
 174 }