R/bar.stackedLattice.R

In lessR: Less Code with More Comprehensive Results

.bar.stackedStats <-
function(dc, x.df, lv, facet2, fct.nm) {

  # one "Frequencies of Responses by Variable" table per panel, the same
  #   table the unfaceted multi-item chart writes from .bc.main(), with
  #   the items in the order they are drawn and the mean of each item
  #   computed over the response categories coded 1 to their number

  n.resp <- length(lv)
  # weights as in .bc.main(): the response values themselves when they are
  #   numeric, otherwise the factor levels coded 1 to their number
  wt <- if (is.numeric(lv)) lv else seq_len(n.resp)
  itm <- colnames(x.df)

  cells <- unique(dc[, fct.nm, drop=FALSE])
  cells <- cells[do.call(order, rev(as.list(cells))), , drop=FALSE]

  for (k in seq_len(nrow(cells))) {

    sel <- dc[[fct.nm[1L]]] == cells[k, 1L]
    lbl <- as.character(cells[k, 1L])
    if (!is.null(facet2)) {
      sel <- sel & dc[[fct.nm[2L]]] == cells[k, 2L]
      lbl <- paste(lbl, as.character(cells[k, 2L]), sep=", ")
    }
    dk <- dc[sel, , drop=FALSE]

    # responses by item, then transposed so each row is an item
    m <- tapply(dk$Count, list(as.character(dk$Response),
                               as.character(dk$Item)), sum)
    # index by name: a numeric  lv  would otherwise select by position
    m <- m[as.character(lv), itm, drop=FALSE]
    m[is.na(m)] <- 0
    wm <- apply(m, 2, function(cnt)
                 if (sum(cnt) > 0) weighted.mean(wt, cnt) else NA)

    txttl <- paste("Frequencies of Responses by Variable, ",
                   getOption("facet1name"), ": ", lbl, sep="")

    txtbl <- .prntbl(as.table(t(m)), 0, cc=NULL)
    mx <- max(nchar(round(wm, 2)), na.rm=TRUE)
    txtbl[1] <- paste(txtbl[1], " ", .fmtc("Mean", w=mx+1))
    for (i in seq_along(itm))
      txtbl[i+1] <- paste(txtbl[i+1], " ", .fmt(wm[i], 3, w=mx+1))

    txtbl[length(itm)+2] <- ""

    class(txtbl) <- "out"
    class(txttl) <- "out"
    output <- list(out_title=txttl, out_text=txtbl)
    class(output) <- "out_all"
    print(output)
  }

}


.bar.stackedLattice <-
function(x.df, facet1, facet2, lv, nrows, ncols, asp, prop,
         fill, color, trans, xlab, ylab, main,
         rotate_x, axis_fmt, axis_x_pre,
         width, height, pdf_file, legend_title, quiet,
         stack100 = FALSE, horiz = TRUE,
         legend_position = "right_margin") {

  # stack100 scales each bar to 100%, the same normalization the
  #   proportion option applies, so the two share one code path
  pct <- isTRUE(stack100)
  if (pct) prop <- TRUE

  # lattice places the key by side, so map the lessR legend positions
  #   onto the four sides, the margin variants included
  key.space <- switch(sub("_margin$", "", legend_position),
                      left = "left", top = "top", bottom = "bottom",
                      "right")

  # panel a multi-item stacked bar chart across the levels of facet.
  #   The unfaceted chart is drawn by .bc.main() in base graphics, which
  #   owns the device (it saves and restores par, draws its own legend,
  #   and derives its own scale), so panels are composed here in lattice
  #   instead, as .bar.lattice() already does for a single-variable bar
  #   chart. Items, response levels, colors, and the count scale are
  #   pooled over the whole data frame so the panels stay comparable.

  if (!quiet)
    cat("[Trellis graphics from Deepayan Sarkar's lattice package]\n\n")

  panel_fill <- getOption("panel_fill")
  panel_color <- getOption("panel_color")

  grid_x_color <- getOption("grid_x_color")
  if (is.null(grid_x_color)) grid_x_color <- getOption("grid_color")
  grid_x_lwd <- getOption("grid_x_lwd")
  if (is.null(grid_x_lwd)) grid_x_lwd <- getOption("grid_lwd")
  grid_x_lty <- getOption("grid_x_lty")
  if (is.null(grid_x_lty)) grid_x_lty <- getOption("grid_lty")

  axis_x_color <- getOption("axis_x_color")
  if (is.null(axis_x_color)) axis_x_color <- getOption("axis_color")
  axis_y_color <- getOption("axis_y_color")
  if (is.null(axis_y_color)) axis_y_color <- getOption("axis_color")

  # axis color is panel_color unless axis_color changed from its default
  sub_theme <- getOption("sub_theme")
  if (sub_theme != "black") {
    panel_color <- ifelse(axis_x_color != "gray15", axis_x_color, "#DED9CD")
    if (panel_color == "#DED9CD")
      panel_color <- ifelse(axis_y_color != "gray15", axis_y_color,
                            "#DED9CD")
  }
  else {
    panel_color <- ifelse(axis_x_color != "gray55", axis_x_color, "gray55")
    if (panel_color == "gray55")
      panel_color <- ifelse(axis_y_color != "gray55", axis_y_color, "gray55")
  }

  axis_x_text_color <- getOption("axis_x_text_color")
  if (is.null(axis_x_text_color))
    axis_x_text_color <- getOption("axis_text_color")
  axis_y_text_color <- getOption("axis_y_text_color")
  if (is.null(axis_y_text_color))
    axis_y_text_color <- getOption("axis_text_color")

  axis_x_size <- getOption("axis_x_size")
  if (is.null(axis_x_size)) axis_x_size <- getOption("axis_size")
  adj <- .RSadj(axis_size=axis_x_size); axis_x_size <- adj$axis_size
  axis_y_size <- getOption("axis_y_size")
  if (is.null(axis_y_size)) axis_y_size <- getOption("axis_size")
  adj <- .RSadj(axis_size=axis_y_size); axis_y_size <- adj$axis_size

  lab_x_color <- getOption("lab_x_color")
  if (is.null(lab_x_color)) lab_x_color <- getOption("lab_color")
  lab_y_color <- getOption("lab_y_color")
  if (is.null(lab_y_color)) lab_y_color <- getOption("lab_color")

  lab_size <- getOption("lab_size")
  lab_x_size <- getOption("lab_x_size")
  lab_y_size <- getOption("lab_y_size")
  if (is.null(lab_x_size)) lab_x_size <- lab_size
  adj <- .RSadj(lab_size=lab_x_size); lab_x_size <- adj$lab_size
  if (is.null(lab_y_size)) lab_y_size <- lab_size
  adj <- .RSadj(lab_size=lab_y_size); lab_y_size <- adj$lab_size

  # if applicable, open graphics window of specified dimensions
  in.RStudio <- identical(getOption("device"), "RStudioGD")
  in.knitr <- !is.null(options()$knitr.in.progress)
  if (!in.RStudio && !in.knitr) dev.new(width=width, height=height)


  # ------------------------------------------------
  # one row per item, response level, and facet cell

  # counts first: the console tables report counts even when the bars
  #   are drawn as proportions, as the unfaceted chart does
  dc <- NULL
  for (j in seq_len(ncol(x.df))) {
    xj <- factor(x.df[, j], levels=lv)
    if (is.null(facet2)) {
      tb <- table(xj, facet1)
      d1 <- as.data.frame.table(tb, responseName="Count")
      names(d1)[1:2] <- c("Response", "Facet1")
    }
    else {
      tb <- table(xj, facet1, facet2)
      d1 <- as.data.frame.table(tb, responseName="Count")
      names(d1)[1:3] <- c("Response", "Facet1", "Facet2")
    }
    d1$Item <- colnames(x.df)[j]
    dc <- rbind(dc, d1)
  }

  fct.nm <- if (is.null(facet2)) "Facet1" else c("Facet1", "Facet2")

  dl <- dc
  if (prop) {  # each bar sums to one within its own item by facet cell
    key <- do.call(paste, dl[, c("Item", fct.nm), drop=FALSE])
    cell <- tapply(dl$Count, key, sum)
    dl$Count <- dl$Count / as.numeric(cell[key])
    if (pct) dl$Count <- 100 * dl$Count
    dl$Count[is.nan(dl$Count)] <- 0  # a cell with no observations
  }

  # lattice fills a factor axis from the bottom, so reverse for the first
  #   variable to appear at the top of a horizontal chart. A vertical
  #   chart reads left to right, so it keeps the supplied order
  dl$Item <- factor(dl$Item,
               levels=if (horiz) rev(colnames(x.df)) else colnames(x.df))

  # common scale: the largest stacked total over all item by facet cells
  grp.nm <- setdiff(names(dl), c("Response", "Count"))
  tot <- tapply(dl$Count, do.call(paste, dl[, grp.nm, drop=FALSE]), sum)
  mx <- max(tot, na.rm=TRUE)
  brks <- pretty(c(0, mx))

  # one frequency table per panel, in panel order
  if (!quiet) .bar.stackedStats(dc, x.df, lv, facet2, fct.nm)


  # ------------------------------------------------
  # the paneled chart

  # built from strings so that the column names are not bare symbols.
  #   horiz places the items on the vertical axis and the counts on the
  #   horizontal, so the response side of the formula swaps with horiz
  lhs <- if (horiz) "Item ~ Count" else "Count ~ Item"
  frm <- if (is.null(facet2))
           stats::as.formula(paste(lhs, "| Facet1"))
         else
           stats::as.formula(paste(lhs, "| Facet1 * Facet2"))

  cnt.scale <- list(labels=.axis.format(brks, axis_fmt, axis_x_pre, "no"),
                    at=brks, tck=.8)
  lim <- c(0, mx * 1.04)

  # set only the limit for the count axis: passing the other as NULL is
  #   not the same as omitting it, and leaves lattice to take min() of
  #   an empty range for the item axis
  bc.args <- list(frm, data=dl, groups=dl$Response, stack=TRUE,
                  horizontal=horiz,
                  scales=if (horiz) list(x=cnt.scale)
                         else list(y=cnt.scale))
  if (horiz) bc.args$xlim <- lim else bc.args$ylim <- lim

  p <- do.call(lattice::barchart, bc.args)

  # customize layout cols and rows, need only specify one
  if (!is.null(nrows) || !is.null(ncols)) {
    n.panels <- ifelse(is.null(facet2), nlevels(factor(facet1)),
                       nlevels(factor(facet1)) * nlevels(factor(facet2)))
    if (is.null(ncols)) ncols <- (n.panels %/% nrows) + (n.panels %% nrows > 0)
    if (is.null(nrows)) nrows <- (n.panels %/% ncols) + (n.panels %% ncols > 0)
    p <- update(p, layout=c(ncols, nrows))
  }

  # separate panels with a border even if turned off when only one plot
  panel_frame_color <- ifelse(panel_color == "transparent",
                              "gray50", panel_color)

  g.x_color <- grid_x_color
  if (g.x_color == "transparent") g.x_color <- getOption("grid_color")

  a.x.text_color <- axis_x_text_color
  if (a.x.text_color == "transparent") a.x.text_color <- axis_y_text_color
  a.y.text_color <- axis_y_text_color
  if (a.y.text_color == "transparent") a.y.text_color <- axis_x_text_color

  l.x_color <- lab_x_color
  if (l.x_color == "transparent") l.x_color <- lab_y_color
  l.y_color <- lab_y_color
  if (l.y_color == "transparent") l.y_color <- lab_x_color

  # more physical space of the axis from the axis labels unless many rows
  if (is.null(nrows)) nrows <- 1
  if (nrows < 7) {
    pad <- 2.08 - 0.56*log(nrows)
    p <- update(p,
         par.settings=list(
           layout_heights=list(axis_xlab_padding=pad)))
  }

  # move strip to left for a single column
  strip.lft <- FALSE
  if (!is.null(ncols)) if (ncols == 1) strip.lft <- TRUE

  p <- update(p,
       strip = lattice::strip.custom(
         par.strip.text = list(
           cex=axis_x_size,
           col=getOption("strip_text_color"),
           bg=list(col=getOption("strip_fill")),
           strip.border=list(col=getOption("strip_color"), lwd=0.5),
           strip.left=strip.lft
    )))

  alpha.fill <- if (is.null(trans)) 1 else 1 - trans
  if (is.na(alpha.fill)) alpha.fill <- 1

  x.lab <- if (is.null(xlab)) "" else xlab
  y.lab <- if (is.null(ylab)) "" else ylab

  p <- update(p,
         aspect=asp,
         xlab=list(label=x.lab, cex=lab_x_size, col=l.x_color),
         ylab=list(label=y.lab, cex=lab_y_size, col=l.y_color),
         main=list(label=main, cex=getOption("main_size", 1.1),
                   col=getOption("lab_color")),
         key=list(space=key.space, title=legend_title,
                  cex.title=axis_x_size, cex=axis_x_size,
                  rectangles=list(col=fill, border=color, alpha=alpha.fill),
                  text=list(lab=as.character(lv))),
         par.settings=list(
           background=list(col=getOption("window_fill")),
           panel.background=list(col=panel_fill),
           superpose.polygon=list(col=fill, border=color, alpha=alpha.fill),
           layout_heights=list(top.padding=1, axis_top=0.5),
           axis_line=list(col=panel_frame_color,
             lty=getOption("axis_lty"), lwd=getOption("axis_lwd"))),
         scales=list(
           x = list(cex=axis_x_size, rot=rotate_x, col=a.x.text_color),
           y = list(cex=axis_y_size, rot=getOption("rotate_y"),
                    col=a.y.text_color)),
         panel = function(...) {
            panel.grid(h=0, v=-1, col=g.x_color,
                       lwd=grid_x_lwd, lty=grid_x_lty)
            panel.barchart(...)
          }
        )


  # display
  # Note: programmatic PDF save is not reliable for lattice/trellis
  #   graphics due to grid's internal device state.
  if (!is.null(pdf_file))
    message("Writing directly to a PDF file does not work in this context.\n",
            "To save as PDF, use RStudio > Plots > Export > Save as PDF.")

  axis.text.old <- lattice::trellis.par.get("axis.text")
  lattice::trellis.par.set("axis.text",
    utils::modifyList(axis.text.old, list(cex=axis_x_size)))
  # style() font family, set unconditionally so that "" restores the
  #   device default -- see the note in .plt.lattice()
  ff <- getOption("font_family", "")
  if (is.null(ff)) ff <- ""
  lattice::trellis.par.set("grid.pars",
    utils::modifyList(lattice::trellis.par.get("grid.pars"),
                      list(fontfamily=ff)))
  # fill panels top-down, left-to-right, as ggplot2 does and as
  #   .plt.hexbinFacet(), .plt.sunflowerFacet(), and .plt.facetSeries()
  #   already do. Lattice's own default fills from the bottom up.
  p <- update(p, as.table=TRUE)

  print(p)
  lattice::trellis.par.set("axis.text", axis.text.old)

  cat("\n")

}