/packages/archive/2010/04.2010/04.20.2010/spacodi/R/BOTHlabels.tim.R

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