R/plt.profileFacet.R

In lessR: Less Code with More Comprehensive Results

.plt.profile.facet <-
function(x, y, by, facet1, facet2, by.name,
         facet1.name, facet2.name,
         fill, x.lab, y.lab, main = NULL,
         n_row = NULL, n_col = NULL,
         axis_fmt = "K", axis_x_pre = "", axis_y_pre = "",
         rotate_x = 0, origin_y = NULL, quiet) {

  # The values arrive aggregated, one row per (x, by, facet) cell, so this
  #   function only places them: a point at each category of  x  and a
  #   segment joining the points of a group across the categories. With a
  #   by  variable each panel carries one profile per group, which is the
  #   interaction plot of the single-panel form drawn within every panel

  grouped <- !is.null(by)
  grp  <- if (grouped) droplevels(factor(by)) else factor(rep("", length(x)))
  lv.g <- levels(grp)
  n.g  <- length(lv.g)

  # save graphics state ONCE, restore on exit
  old.par <- par(no.readonly = TRUE)
  on.exit({
    ro <- c("cin", "cra", "csi", "cxy", "din", "page")
    par(old.par[setdiff(names(old.par), ro)])
  }, add = TRUE)

  # panel-strip label:  VarName = "level"  (quote non-numeric levels only),
  #   matching the faceted distribution and contour forms
  .lab.lv <- function(nm, lv) {
    q <- ifelse(is.na(suppressWarnings(as.numeric(lv))),
                paste0('"', lv, '"'), lv)
    paste0(nm, " = ", q)
  }

  # -------------------------------------------------------------------------
  # build the panel grid: one profile display per facet cell
  if (!is.factor(facet1)) facet1 <- factor(facet1)
  lv1 <- levels(droplevels(facet1))

  if (!is.null(facet2)) {  # two facets: rows = facet2, cols = facet1
    if (!is.factor(facet2)) facet2 <- factor(facet2)
    lv2 <- levels(droplevels(facet2))
    nc <- length(lv1); nr <- length(lv2)
    cells <- expand.grid(c1 = lv1, c2 = lv2, stringsAsFactors = FALSE)
    cells <- cells[order(match(cells$c2, lv2), match(cells$c1, lv1)), ]
    sel <- Map(function(a, b) which(facet1 == a & facet2 == b),
               cells$c1, cells$c2)
    labs <- paste0(.lab.lv(facet1.name, cells$c1), ", ",
                   .lab.lv(facet2.name, cells$c2))
  }
  else {  # one facet: near-square grid unless n_row / n_col supplied
    k <- length(lv1)
    if (!is.null(n_col))      { nc <- n_col; nr <- ceiling(k / nc) }
    else if (!is.null(n_row)) { nr <- n_row; nc <- ceiling(k / nr) }
    else { nc <- ceiling(sqrt(k)); nr <- ceiling(k / nc) }
    sel <- lapply(lv1, function(a) which(facet1 == a))
    labs <- .lab.lv(facet1.name, lv1)
  }

  # -------------------------------------------------------------------------
  # every panel shares the categories of  x  and the scale of  y, which is
  #   what makes the panels comparable. A category absent from a panel keeps
  #   its place on that panel's axis and draws no point
  if (!is.factor(x)) x <- factor(x)
  x.lev <- levels(droplevels(x))
  n.x   <- length(x.lev)
  x.pos <- match(as.character(x), x.lev)

  ok <- is.finite(y)
  if (!any(ok)) {
    cat("\n"); stop(call. = FALSE, "\n------\n",
      "No facet cell has a value to plot.\n\n")
  }
  y.rng <- range(y[ok])
  # every panel shares one value scale, so the origin widens that one range
  if (!is.null(origin_y)) {
    if (y.rng[1L] > origin_y) y.rng[1L] <- origin_y
    if (y.rng[2L] < origin_y) y.rng[2L] <- origin_y
  }
  ayT <- pretty(y.rng)
  lbl.y <- .axis.format(ayT, axis_fmt, axis_x_pre = "no", axis_y_pre)
  y.lim <- range(ayT)
  x.lim <- c(1 - 0.35, n.x + 0.35)  # keep the end points off the panel edge

  clr <- if (length(fill) >= n.g) fill[seq_len(n.g)]
         else rep(fill, length.out = n.g)

  # -------------------------------------------------------------------------
  # draw the grid
  ax <- .axes_dim()
  col.bg  <- getOption("panel_fill")
  col.box <- getOption("panel_color")
  g.x <- getOption("grid_x_color")
  if (is.null(g.x)) g.x <- getOption("grid_color")
  g.y <- getOption("grid_y_color")
  if (is.null(g.y)) g.y <- getOption("grid_color")
  g.lwd <- getOption("grid_lwd"); if (is.null(g.lwd)) g.lwd <- 1
  g.lty <- getOption("grid_lty"); if (is.null(g.lty)) g.lty <- "solid"

  par(bg = getOption("window_fill"))
  par(oma = c(if (rotate_x != 0) 4.6 else 3.4, 4.6,
              if (grouped) 2.8 else 1.0, 0.8))  # top: room for the legend
  par(mfrow = c(nr, nc))
  par(mgp = c(3.5, 0.4, 0), tcl = -0.25)

  for (i in seq_len(nr * nc)) {
    row.i <- ((i - 1) %/% nc) + 1
    col.i <- ((i - 1) %%  nc) + 1
    last.row  <- row.i == nr
    first.col <- col.i == 1

    par(mar = c(0.6, 0.6, 1.5, 0.5))
    plot.new()
    plot.window(xlim = x.lim, ylim = y.lim)
    rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4],
         col = col.bg, border = col.box)
    abline(h = ayT, col = g.y, lwd = g.lwd, lty = g.lty)
    abline(v = seq_len(n.x), col = g.x, lwd = g.lwd, lty = g.lty)

    if (i <= length(sel)) for (j in seq_len(n.g)) {
      k <- sel[[i]][grp[sel[[i]]] == lv.g[j]]
      k <- k[is.finite(y[k])]
      if (!length(k)) next
      o <- order(x.pos[k])          # follow the order of the categories
      k <- k[o]
      # a category with no value in this cell leaves a gap that the segment
      #   spans, as the profile of a single panel does
      if (length(k) > 1)
        segments(x.pos[k][-length(k)], y[k][-length(k)],
                 x.pos[k][-1], y[k][-1], col = clr[j], lwd = 1.5)
      points(x.pos[k], y[k], pch = 21, bg = clr[j], col = clr[j], cex = 1.1)
    }

    if (last.row)
      axis(1, at = seq_len(n.x), labels = x.lev, cex.axis = ax$axis_x_size,
           col.axis = ax$axis_x_text_color, las = if (rotate_x != 0) 2 else 0)
    if (first.col)
      axis(2, at = ayT, labels = lbl.y, cex.axis = ax$axis_y_size,
           col.axis = ax$axis_y_text_color)
    if (i <= length(labs))
      title(main = labs[i], cex.main = getOption("lab_size") * 1.05,
            col.main = getOption("lab_color"), font.main = 1, line = 0.3)
    box(col = col.box)
  }

  # shared axis titles in the outer margin
  lab.cex <- getOption("lab_size") * 1.15
  mtext(x.lab, side = 1, outer = TRUE,
        line = if (rotate_x != 0) 2.8 else 1.6,
        cex = lab.cex, col = getOption("lab_color"))
  mtext(y.lab, side = 2, outer = TRUE, line = 2.8, cex = lab.cex,
        col = getOption("lab_color"))
  if (!is.null(main))
    mtext(main, side = 3, outer = TRUE, line = 1.2, cex = lab.cex,
          col = getOption("lab_color"))

  # legend for the profiles of each group, across the top of the whole grid
  if (grouped) {
    par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0),
        new = TRUE)
    plot.new()
    legend("top", legend = lv.g, title = by.name, horiz = TRUE, bty = "n",
           col = clr, pt.bg = clr, pch = 21, lwd = 1.5,
           cex = lab.cex * 0.92, text.col = getOption("lab_color"))
  }

  # on.exit() restores par
}