1 ## nodelabels.R (2010-07-17)
5 ## Copyright 2004-2010 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon
7 ## This file is part of the R-package `ape'.
8 ## See the file ../COPYING for licensing issues.
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).
16 floating.pie.asp <- function(xpos, ypos, x, edges = 200, radius = 1,
17 col = NULL, startpos = 0, ...)
20 user.asp <- diff(u[3:4])/diff(u[1:2])
22 inches.asp <- p[2]/p[1]
23 asp <- user.asp/inches.asp
24 if (!is.numeric(x) || any(is.na(x) | x < 0)) {
26 stop("floating.pie: x values must be non-negative")
28 x <- c(0, cumsum(x)/sum(x))
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
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)
48 BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
49 pie, piecol, col, bg, horiz, width, height, ...)
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"))
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) {
68 } else if (args$srt != 0)
69 warning("only right angle rotation of frame is supported;\n try `frame = \"n\"' instead.\n")
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)
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)
85 if (!is.null(thermo)) {
89 width <- CEX * (parusr[2] - parusr[1])
90 width <- if (horiz) width/15 else width/40
93 if (is.null(height)) {
94 height <- CEX * (parusr[4] - parusr[3])
95 height <- if (horiz) height/40 else height/15
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))
102 xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30)
104 yb <- YY - height/2 + adj[2] - 0.5
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])
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])
122 ## check for NA's before drawing the borders
123 s <- apply(thermo, 1, function(xx) any(is.na(xx)))
125 rect(xl, yb, xr, yt, border = "black")
128 segments(xl, YY, xl - width/5, YY)
129 segments(xr, YY, xr + width/5, YY)
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)
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, ...)
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, ...)
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, ...)
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, ...)
169 lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
170 if (missing(tip)) tip <- 1:lastPP$Ntip
173 BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
174 pie, piecol, col, bg, horiz, width, height, ...)
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, ...)
183 lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
185 sel <- 1:dim(lastPP$edge)[1]
186 subedge <- lastPP$edge
189 subedge <- lastPP$edge[sel, , drop = FALSE]
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]]
196 XX <- lastPP$xx[subedge[, 2]]
197 YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
200 XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
201 YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
203 BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
204 pie, piecol, col, bg, horiz, width, height, ...)
207 edges <- function(nodes0, nodes1, arrows = 0, type = "classical", ...)
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)
217 x0 <- lastPP$xx[nodes0]
218 y0 <- lastPP$yy[nodes0]
219 x1 <- lastPP$xx[nodes1]
220 y1 <- lastPP$yy[nodes1]
222 if (type == "classical")
223 graphics::arrows(x0, y0, x1, y1, code = arrows, ...)
225 fancyarrows(x0, y0, x1, y1, code = arrows, type = type, ...)
227 graphics::segments(x0, y0, x1, y1, ...)
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", ...)
235 foo <- function(x0, y0, x1, y1) {
236 ## important to correct with these parameters cause
237 ## the coordinate system will likely not be Cartesian
240 A1 <- pin[1]/diff(usr[1:2])
241 A2 <- pin[2]/diff(usr[3:4])
246 atan2(y1 - y0, x1 - x0)
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
253 xb <- xinch(length * cos(beta)) + x
254 yb <- yinch(length * sin(beta)) + y
256 col <- rep(col, length.out = 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)
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
272 col <- rep(col, length.out = 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])
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]
285 FUN <- if (type == "triangle") arrow.triangle else arrow.harpoon
286 XY0 <- if (code == 1 || code == 3) FUN(x0, y0) else list(x0, y0)
288 alpha <- (alpha + pi) %% (2 * pi)
290 } else XY1 <- list(x1, y1)
291 segments(XY0[[1]], XY0[[2]], XY1[[1]], XY1[[2]], col = col, lty = lty, lwd = lwd, ...)