/packages/archive/2010/04.2010/04.30.2010/spacodi/R/nodelabels.sp.R
R | 87 lines | 85 code | 2 blank | 0 comment | 34 complexity | c5da25246b6598268e6af16a0721ed97 MD5 | raw file
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