1 ## nodelabels.R (2008-02-28)
5 ## Copyright 2004-2008 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, ...)
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)) {
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
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)
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 for (i in 1:length(sel))
111 floating.pie.asp(XX[i], YY[i], pie[i, ],
112 radius = xrad[i], col = piecol)
114 if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...)
115 if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5,
116 pch = pch, col = col, bg = bg, ...)
119 nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect",
120 pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
121 col = "black", bg = "lightblue", ...)
123 lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
124 if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx)
125 XX <- lastPP$xx[node]
126 YY <- lastPP$yy[node]
127 BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
128 pie, piecol, col, bg, ...)
131 tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect",
132 pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
133 col = "black", bg = "yellow", ...)
135 lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
136 if (missing(tip)) tip <- 1:lastPP$Ntip
139 BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
140 pie, piecol, col, bg, ...)
143 edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect",
144 pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
145 col = "black", bg = "lightgreen", ...)
147 lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
149 sel <- 1:dim(lastPP$edge)[1]
150 subedge <- lastPP$edge
153 subedge <- lastPP$edge[sel, , drop = FALSE]
155 if (lastPP$type == "phylogram") {
156 if (lastPP$direction %in% c("rightwards", "leftwards")) {
157 XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
158 YY <- lastPP$yy[subedge[, 2]]
160 XX <- lastPP$xx[subedge[, 2]]
161 YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
164 XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
165 YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
167 BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
168 pie, piecol, col, bg, ...)