/packages/archive/2010/04.2010/04.30.2010/spacodi/R/nodelabels.sp.R

 1nodelabels.sp <-
 2function (text, node, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightblue", border = "black", ...) {
 3    lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
 4    if (missing(node)) 
 5	node <- (lastPP$Ntip + 1):length(lastPP$xx)
 6    XX <- lastPP$xx[node]
 7    YY <- lastPP$yy[node]
 8    BOTHlabels.sp(text, node, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, border, ...)
 9}
10
11BOTHlabels.sp <-
12function (text, sel, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, border, ...) {
13    if (missing(text)) 
14	text <- NULL
15    if (length(adj) == 1) 
16	adj <- c(adj, 0.5)
17    if (is.null(text) && is.null(pch) && is.null(thermo) && is.null(pie)) 
18	text <- as.character(sel)
19    frame <- match.arg(frame, c("rect", "circle", "none"))
20    args <- list(...)
21    CEX <- if ("cex" %in% names(args)) 
22	args$cex
23    else par("cex")
24    if (frame != "none" && !is.null(text)) {
25        if (frame == "rect") {
26            width <- strwidth(text, units = "inches", cex = CEX)
27            height <- strheight(text, units = "inches", cex = CEX)
28            if ("srt" %in% names(args)) {
29                args$srt <- args$srt%%360
30                if (args$srt == 90 || args$srt == 270) {
31					tmp <- width
32					width <- height
33					height <- tmp
34                }
35                else if (args$srt != 0) 
36				warning("only right angle rotation of frame is supported;\n         try  `frame = \"n\"' instead.\n")
37            }
38            width <- xinch(width)
39            height <- yinch(height)
40            xl <- XX - xinch(0.10)
41            xr <- XX + xinch(-0.01)
42            yb <- YY - yinch(0.02)
43            yt <- YY + yinch(0.02)
44            rect(xl, yb, xr, yt, col = bg, border = border)
45        }
46        if (frame == "circle") {
47            radii <- 0.8 * apply(cbind(strheight(text, units = "inches", 
48												 cex = CEX), strwidth(text, units = "inches", 
49																	  cex = CEX)), 1, max)
50            symbols(XX, YY, circles = radii, inches = max(radii), add = TRUE, bg = bg)
51        }
52    }
53    if (!is.null(thermo)) {
54        parusr <- par("usr")
55        width <- CEX * (parusr[2] - parusr[1])/40
56        height <- CEX * (parusr[4] - parusr[3])/15
57        if (is.vector(thermo)) 
58		thermo <- cbind(thermo, 1 - thermo)
59        thermo <- height * thermo
60        xl <- XX - width/2
61        xr <- xl + width
62        yb <- YY - height/2
63        if (is.null(piecol)) 
64		piecol <- rainbow(ncol(thermo))
65        rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1])
66        for (i in 2:ncol(thermo)) rect(xl, yb + rowSums(thermo[, 
67														1:(i - 1), drop = FALSE]), xr, yb + rowSums(thermo[, 
68																									1:i]), border = NA, col = piecol[i])
69        rect(xl, yb, xr, yb + height, border = "black")
70        segments(xl, YY, xl - width/5, YY)
71        segments(xr, YY, xr + width/5, YY)
72    }
73    if (!is.null(pie)) {
74        if (is.vector(pie)) 
75		pie <- cbind(pie, 1 - pie)
76        xrad <- CEX * diff(par("usr")[1:2])/50
77        xrad <- rep(xrad, length(sel))
78        for (i in 1:length(sel)) floating.pie.asp(XX[i], YY[i], 
79												  pie[i, ], radius = xrad[i], col = piecol)
80    }
81    if (!is.null(text)) 
82	text(XX, YY, text, adj = adj, col = col, ...)
83    if (!is.null(pch)) 
84	points(XX + adj[1] - 0.5, YY + adj[2] - 0.5, pch = pch, 
85		   col = col, bg = bg, ...)
86}
87