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

http://github.com/eastman/spacodiR · R · 77 lines · 76 code · 1 blank · 0 comment · 33 complexity · ee3220ad260c476f040abdc79e647ffd MD5 · raw file

  1. BOTHlabels.tim <-
  2. function (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. }