SHARE
TWEET

Untitled

a guest Jun 25th, 2019 76 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. panel.barchart.alpha <- function (x, y, box.ratio = 1, box.width = box.ratio/(1 + box.ratio),
  2.     horizontal = TRUE, origin = NULL, reference = TRUE, stack = FALSE,
  3.     groups = NULL, col = if (is.null(groups)) plot.polygon$col else superpose.polygon$col,
  4.     border = if (is.null(groups)) plot.polygon$border else superpose.polygon$border,
  5.     lty = if (is.null(groups)) plot.polygon$lty else superpose.polygon$lty,
  6.     lwd = if (is.null(groups)) plot.polygon$lwd else superpose.polygon$lwd,
  7.     alpha = if (is.null(groups)) plot.polygon$alpha else superpose.polygon$alpha,
  8.     ..., identifier = "barchart")
  9. {
  10.     plot.polygon <- trellis.par.get("plot.polygon")
  11.     superpose.polygon <- trellis.par.get("superpose.polygon")
  12.     reference.line <- trellis.par.get("reference.line")
  13.     keep <- (function(x, y, groups, subscripts, ...) {
  14.         !is.na(x) & !is.na(y) & if (is.null(groups))
  15.             TRUE
  16.         else !is.na(groups[subscripts])
  17.     })(x = x, y = y, groups = groups, ...)
  18.     if (!any(keep))
  19.         return()
  20.     x <- as.numeric(x[keep])
  21.     y <- as.numeric(y[keep])
  22.     if (!is.null(groups)) {
  23.         groupSub <- function(groups, subscripts, ...) groups[subscripts[keep]]
  24.         if (!is.factor(groups))
  25.             groups <- factor(groups)
  26.         nvals <- nlevels(groups)
  27.         groups <- as.numeric(groupSub(groups, ...))
  28.     }
  29.     if (horizontal) {
  30.         if (is.null(groups)) {
  31.             if (is.null(origin)) {
  32.                 origin <- current.panel.limits()$xlim[1]
  33.                 reference <- FALSE
  34.             }
  35.             height <- box.width
  36.             if (reference)
  37.                 panel.abline(v = origin, col = reference.line$col,
  38.                   lty = reference.line$lty, lwd = reference.line$lwd,
  39.                   identifier = paste(identifier, "abline",
  40.                     sep = "."))
  41.             panel.rect(x = rep(origin, length(y)), y = y, height = rep(height,
  42.                 length(y)), width = x - origin, border = border,
  43.                 col = col, lty = lty, lwd = lwd, alpha=alpha,
  44.                 just = c("left", "centre"), identifier = identifier)
  45.         }
  46.         else if (stack) {
  47.             if (!is.null(origin) && origin != 0)
  48.                 warning("'origin' forced to 0 for stacked bars")
  49.             col <- rep(col, length.out = nvals)
  50.             border <- rep(border, length.out = nvals)
  51.             lty <- rep(lty, length.out = nvals)
  52.             lwd <- rep(lwd, length.out = nvals)
  53.             alpha <- rep(alpha, length.out = nvals)
  54.             height <- box.width
  55.             if (reference)
  56.                 panel.abline(v = origin, col = reference.line$col,
  57.                   lty = reference.line$lty, lwd = reference.line$lwd,
  58.                   identifier = paste(identifier, "abline",
  59.                     sep = "."))
  60.             for (i in unique(y)) {
  61.                 ok <- y == i
  62.                 ord <- sort.list(groups[ok])
  63.                 pos <- x[ok][ord] > 0
  64.                 nok <- sum(pos, na.rm = TRUE)
  65.                 if (nok > 0)
  66.                   panel.rect(x = cumsum(c(0, x[ok][ord][pos][-nok])),
  67.                     y = rep(i, nok), col = col[groups[ok][ord][pos]],
  68.                     border = border[groups[ok][ord][pos]], lty = lty[groups[ok][ord][pos]],
  69.                     lwd = lwd[groups[ok][ord][pos]], alpha = alpha[groups[ok][ord][pos]],
  70.                     height = rep(height, nok), width = x[ok][ord][pos], just = c("left",
  71.                       "centre"), identifier = paste(identifier,
  72.                       "pos", i, sep = "."))
  73.                 neg <- x[ok][ord] < 0
  74.                 nok <- sum(neg, na.rm = TRUE)
  75.                 if (nok > 0)
  76.                   panel.rect(x = cumsum(c(0, x[ok][ord][neg][-nok])),
  77.                     y = rep(i, nok), col = col[groups[ok][ord][neg]],
  78.                     border = border[groups[ok][ord][neg]], lty = lty[groups[ok][ord][neg]],
  79.                     lwd = lwd[groups[ok][ord][neg]], height = rep(height,
  80.                       nok), width = x[ok][ord][neg], just = c("left",
  81.                       "centre"), identifier = paste(identifier,
  82.                       "neg", i, sep = "."))
  83.             }
  84.         }
  85.         else {
  86.             if (is.null(origin)) {
  87.                 origin <- current.panel.limits()$xlim[1]
  88.                 reference <- FALSE
  89.             }
  90.             col <- rep(col, length.out = nvals)
  91.             border <- rep(border, length.out = nvals)
  92.             lty <- rep(lty, length.out = nvals)
  93.             lwd <- rep(lwd, length.out = nvals)
  94.             alpha <- rep(alpha, length.out = nvals)
  95.             height <- box.width/nvals
  96.             if (reference)
  97.                 panel.abline(v = origin, col = reference.line$col,
  98.                   lty = reference.line$lty, lwd = reference.line$lwd,
  99.                   identifier = paste(identifier, "abline",
  100.                     sep = "."))
  101.             for (i in unique(y)) {
  102.                 ok <- y == i
  103.                 nok <- sum(ok, na.rm = TRUE)
  104.                 panel.rect(x = rep(origin, nok), y = (i + height *
  105.                   (groups[ok] - (nvals + 1)/2)), col = col[groups[ok]],
  106.                   border = border[groups[ok]], lty = lty[groups[ok]],
  107.                   lwd = lwd[groups[ok]], alpha = alpha[groups[ok]],
  108.                     height = rep(height,
  109.                     nok), width = x[ok] - origin, just = c("left",
  110.                     "centre"), identifier = paste(identifier,
  111.                     "y", i, sep = "."))
  112.             }
  113.         }
  114.     }
  115.     else {
  116.         if (is.null(groups)) {
  117.             if (is.null(origin)) {
  118.                 origin <- current.panel.limits()$ylim[1]
  119.                 reference <- FALSE
  120.             }
  121.             width <- box.width
  122.             if (reference)
  123.                 panel.abline(h = origin, col = reference.line$col,
  124.                   lty = reference.line$lty, lwd = reference.line$lwd,
  125.                   identifier = paste(identifier, "abline",
  126.                     sep = "."))
  127.             panel.rect(x = x, y = rep(origin, length(x)), col = col,
  128.                 border = border, lty = lty, lwd = lwd, alpha = alpha,
  129.                 width = rep(width, length(x)), height = y - origin, just = c("centre",
  130.                   "bottom"), identifier = identifier)
  131.         }
  132.         else if (stack) {
  133.             if (!is.null(origin) && origin != 0)
  134.                 warning("'origin' forced to 0 for stacked bars")
  135.             col <- rep(col, length.out = nvals)
  136.             border <- rep(border, length.out = nvals)
  137.             lty <- rep(lty, length.out = nvals)
  138.             lwd <- rep(lwd, length.out = nvals)
  139.             alpha <- rep(alpha, length.out = nvals)
  140.             width <- box.width
  141.             if (reference)
  142.                 panel.abline(h = origin, col = reference.line$col,
  143.                   lty = reference.line$lty, lwd = reference.line$lwd,
  144.                   identifier = paste(identifier, "abline",
  145.                     sep = "."))
  146.             for (i in unique(x)) {
  147.                 ok <- x == i
  148.                 ord <- sort.list(groups[ok])
  149.                 pos <- y[ok][ord] > 0
  150.                 nok <- sum(pos, na.rm = TRUE)
  151.                 if (nok > 0)
  152.                   panel.rect(x = rep(i, nok), y = cumsum(c(0,
  153.                     y[ok][ord][pos][-nok])), col = col[groups[ok][ord][pos]],
  154.                     border = border[groups[ok][ord][pos]], lty = lty[groups[ok][ord][pos]],
  155.                     lwd = lwd[groups[ok][ord][pos]], alpha = alpha[groups[ok][ord][pos]],
  156.                     width = rep(width,
  157.                       nok), height = y[ok][ord][pos], just = c("centre",
  158.                       "bottom"), identifier = paste(identifier,
  159.                       "pos", i, sep = "."))
  160.                 neg <- y[ok][ord] < 0
  161.                 nok <- sum(neg, na.rm = TRUE)
  162.                 if (nok > 0)
  163.                   panel.rect(x = rep(i, nok), y = cumsum(c(0,
  164.                     y[ok][ord][neg][-nok])), col = col[groups[ok][ord][neg]],
  165.                     border = border[groups[ok][ord][neg]], lty = lty[groups[ok][ord][neg]],
  166.                     lwd = lwd[groups[ok][ord][neg]], alpha = alpha[groups[ok][ord][neg]],
  167.                     width = rep(width,
  168.                       nok), height = y[ok][ord][neg], just = c("centre",
  169.                       "bottom"), identifier = paste(identifier,
  170.                       "neg", i, sep = "."))
  171.             }
  172.         }
  173.         else {
  174.             if (is.null(origin)) {
  175.                 origin <- current.panel.limits()$ylim[1]
  176.                 reference = FALSE
  177.             }
  178.             col <- rep(col, length.out = nvals)
  179.             border <- rep(border, length.out = nvals)
  180.             lty <- rep(lty, length.out = nvals)
  181.             lwd <- rep(lwd, length.out = nvals)
  182.             alpha <- rep(alpha, length.out = nvals)
  183.             width <- box.width/nvals
  184.             if (reference)
  185.                 panel.abline(h = origin, col = reference.line$col,
  186.                   lty = reference.line$lty, lwd = reference.line$lwd,
  187.                   identifier = paste(identifier, "abline",
  188.                     sep = "."))
  189.             for (i in unique(x)) {
  190.                 ok <- x == i
  191.                 nok <- sum(ok, na.rm = TRUE)
  192.                 panel.rect(x = (i + width * (groups[ok] - (nvals +
  193.                   1)/2)), y = rep(origin, nok), col = col[groups[ok]],
  194.                   border = border[groups[ok]], lty = lty[groups[ok]],
  195.                   lwd = lwd[groups[ok]], alpha = alpha[groups[ok]],
  196.                   width = rep(width, nok),
  197.                   height = y[ok] - origin, just = c("centre",
  198.                     "bottom"), identifier = paste(identifier,
  199.                     "x", i, sep = "."))
  200.             }
  201.         }
  202.     }
  203. }
  204. environment(panel.barchart.alpha) <- asNamespace("lattice")
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top