Advertisement
Guest User

myplotbetadisp.r

a guest
Jun 19th, 2017
925
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 5.67 KB | None | 0 0
  1. myplotbetadisper <- function (x, axes = c(1, 2), cex = 0.7, pch = seq_len(ng), col = NULL,
  2. lty = "solid", lwd = 1, hull = TRUE, ellipse = FALSE, conf,
  3. segments = TRUE, seg.col = "grey", seg.lty = lty, seg.lwd = lwd,
  4. label = TRUE, label.cex = 1, ylab, xlab, main, sub,
  5. fillrect="white", coltextrect="black", alphaPoints=0.5,
  6. labPoints=NULL, poslabPoints=4, ...)
  7. {
  8. localAxis <- function(..., col, bg, pch, cex, lty, lwd) axis(...)
  9. localBox <- function(..., col, bg, pch, cex, lty, lwd) box(...)
  10. localTitle <- function(..., col, bg, pch, cex, lty, lwd) title(...)
  11. Ellipse <- function(scrs, centres, conf, col, lty, lwd, ...) {
  12. mat <- cov.wt(scrs, center = centres)
  13. if (mat$n.obs == 1)
  14. mat$cov[] <- 0
  15. xy <- if (mat$n.obs > 1) {
  16. vegan:::veganCovEllipse(mat$cov, mat$center, conf)
  17. }
  18. else {
  19. scrs
  20. }
  21. vegan:::ordiArgAbsorber(xy, FUN = lines, col = col, lty = lty,
  22. lwd = lwd, ...)
  23. }
  24. if (missing(main))
  25. main <- deparse(substitute(x))
  26. if (missing(sub))
  27. sub <- paste("method = \"", attr(x, "method"), "\"",
  28. sep = "")
  29. if (missing(xlab))
  30. xlab <- paste("PCoA", axes[1])
  31. if (missing(ylab))
  32. ylab <- paste("PCoA", axes[2])
  33. t <- if (missing(conf)) {
  34. 1
  35. }
  36. else {
  37. sqrt(qchisq(conf, df = 2))
  38. }
  39. g <- scores(x, choices = axes)
  40. ng <- length(levels(x$group))
  41. lev <- levels(x$group)
  42. if (is.null(col)) {
  43. col <- palette()
  44. }
  45. col <- rep_len(col, ng)
  46. colpts <- apply(col2rgb(col), 2, addAlpha, alpha=alphaPoints)
  47. seg.col <- rep_len(seg.col, ng)
  48. plot(g$sites, asp = 1, type = "n", axes = FALSE, ann = FALSE,
  49. ...)
  50. if (is.matrix(g$centroids)) {
  51. for (i in seq_along(lev)) {
  52. curlev <- lev[i]
  53. take <- x$group == curlev
  54. j <- which(lev == curlev)
  55. if (segments) {
  56. segments(g$centroids[j, 1L], g$centroids[j, 2L],
  57. g$sites[take, 1L], g$sites[take, 2L], col = seg.col[i],
  58. lty = seg.lty, lwd = seg.lwd)
  59. }
  60. if (hull) {
  61. ch <- chull(g$sites[take, ])
  62. ch <- c(ch, ch[1])
  63. lines(x$vectors[take, axes][ch, ], col = col[i],
  64. lty = lty, lwd = lwd, ...)
  65. }
  66. if (ellipse) {
  67. Ellipse(g$sites[take, , drop = FALSE], centres = g$centroids[j,
  68. ], conf = t, col = col[i], lty = lty, lwd = lwd,
  69. ...)
  70. }
  71. points(g$centroids[j, , drop = FALSE], pch = 16,
  72. cex = 1, col = col[i], ...)
  73. }
  74. }
  75. else {
  76. if (segments) {
  77. segments(g$centroids[, 1L], g$centroids[, 2L], g$sites[,
  78. 1L], g$sites[, 2L], col = seg.col, lty = seg.lty,
  79. ...)
  80. }
  81. if (hull) {
  82. ch <- chull(g$sites)
  83. ch <- c(ch, ch[1])
  84. lines(x$vectors[, axes][ch, ], col = col[1L], lty = lty,
  85. lwd = lwd, ...)
  86. }
  87. if (ellipse) {
  88. Ellipse(g$sites, centres = g$centroids, conf = t,
  89. col = col[1L], lty = lty, lwd = lwd, ...)
  90. }
  91. points(g$centroids[, 1L], g$centroids[, 2L], pch = 16,
  92. cex = 1, col = col[1L], ...)
  93. }
  94. points(g$sites, pch = pch[x$group], cex = cex, col = col[x$group],
  95. ...)
  96. if (!is.null(labPoints)) {
  97. text(g$sites, labels=labPoints, pos=poslabPoints,
  98. cex = cex, col = col[x$group])
  99. }
  100. if (label) {
  101. myordilabel(x, display = "centroids", choices = axes, cex = label.cex, fill=fillrect, col=coltextrect)
  102. }
  103. localTitle(main = main, xlab = xlab, ylab = ylab, sub = sub,
  104. ...)
  105. localAxis(1, ...)
  106. localAxis(2, ...)
  107. localBox(...)
  108. class(g) <- "ordiplot"
  109. invisible(g)
  110. }
  111.  
  112.  
  113. myordilabel <- function (x, display, labels, choices = c(1, 2), priority, select,
  114. cex = 0.8, fill = "white", border = NULL, col = NULL, xpd = TRUE,
  115. ...)
  116. {
  117. if (missing(display))
  118. display <- "sites"
  119. x <- scores(x, choices = choices, display = display, ...)
  120. if (missing(labels))
  121. labels <- rownames(x)
  122. if (!missing(select)) {
  123. x <- .checkSelect(select, x)
  124. labels <- .checkSelect(select, labels)
  125. }
  126. if (!missing(priority)) {
  127. if (!missing(select))
  128. priority <- priority[select]
  129. ord <- order(priority)
  130. x <- x[ord, ]
  131. labels <- labels[ord]
  132. }
  133. else {
  134. ord <- seq_along(labels)
  135. }
  136. em <- strwidth("m", cex = cex, ...)
  137. ex <- strheight("x", cex = cex, ...)
  138. w <- (strwidth(labels, cex = cex, ...) + em/1.5)/2
  139. h <- (strheight(labels, cex = cex, ...) + ex/1.5)/2
  140. if (is.null(col))
  141. if (!is.null(border))
  142. col <- border
  143. else col <- par("fg")
  144. col <- rep(col, length = nrow(x))[ord]
  145. if (!is.null(border))
  146. border <- rep(border, length = nrow(x))[ord]
  147. fill <- rep(fill, length = nrow(x))[ord]
  148. for (i in 1:nrow(x)) {
  149. vegan:::ordiArgAbsorber(x[i, 1] + c(-1, 1, 1, -1) * w[i], x[i,
  150. 2] + c(-1, -1, 1, 1) * h[i], col = fill[i], border = border[i],
  151. xpd = xpd, FUN = polygon, ...)
  152. vegan:::ordiArgAbsorber(x[i, 1], x[i, 2], labels = labels[i],
  153. cex = cex, col = col[i], xpd = xpd, FUN = text, ...)
  154. }
  155. invisible(x)
  156. }
  157.  
  158. addAlpha <- function(col, alpha) {
  159. alpha <- round(alpha*255)
  160. rgb(red=col[1], green=col[2], blue=col[3], alpha=alpha, maxColorValue=255)
  161. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement