R/plt.facetSeries.R

In lessR: Less Code with More Comprehensive Results

.plt.facet.series <-
function(series.data, shared, shared.lab, on,
         facet1, facet2,
         pt_fill, pt_color, pt_size, shape,
         fit, fit_lwd, n_row, n_col, aspect) {

  # the multi-series overlay of the columns of series.data plotted against
  #   the single shared variable, repeated across the panels of the facet
  #   variable(s): each panel displays the full overlay for one facet level
  #   (or combination of levels), with all panels on a common scale
  # on="x": the series are on the x-axis with the shared variable on y
  # on="y": the series are on the y-axis with the shared variable on x
  k  <- ncol(series.data)
  nm <- names(series.data)
  n  <- nrow(series.data)

  dd <- data.frame(
    value  = unlist(series.data, use.names = FALSE),
    shared = rep(shared, k),
    series = factor(rep(nm, each = n), levels = nm),
    f1     = rep(facet1, k))
  two.facets <- !is.null(facet2)
  if (two.facets) dd$f2 <- rep(facet2, k)

  # layout: default a single column of panels, as with the generic facet
  #   path; lattice takes c(cols, rows)
  n.pan <- nlevels(dd$f1) * (if (two.facets) nlevels(dd$f2) else 1L)
  if (!is.null(n_col))      lay <- c(n_col, ceiling(n.pan / n_col))
  else if (!is.null(n_row)) lay <- c(ceiling(n.pan / n_row), n_row)
  else if (!two.facets)     lay <- c(1, n.pan)
  else                      lay <- NULL  # lattice default two-facet grid

  asp <- if (is.numeric(aspect)) aspect
         else if (identical(aspect, "xy")) "xy" else "fill"

  cond <- if (two.facets) "f1 + f2" else "f1"
  ser.lab <- paste(nm, collapse=", ")
  if (on == "x") {                     # the series are on the x-axis
    ff <- stats::as.formula(paste("shared ~ value |", cond))
    x.lab <- ser.lab;  y.lab <- shared.lab
  } else {                             # the series are on the y-axis
    ff <- stats::as.formula(paste("value ~ shared |", cond))
    x.lab <- shared.lab;  y.lab <- ser.lab
  }
  scl <- list(col = getOption("axis_text_color"),
              cex = getOption("axis_size"))

  # per-panel overlay of the series, each series's optional fit line drawn
  #   in that series's color
  pan.grp <- function(x, y, col.symbol, ...) {
    lattice::panel.xyplot(x, y, col.symbol = col.symbol, ...)
    if (fit != "off"  &&  sum(is.finite(x) & is.finite(y)) > 2) {
      if (fit == "loess")
        lattice::panel.loess(x, y, col = col.symbol, lwd = fit_lwd)
      else if (fit %in% c("lm", "ls"))
        lattice::panel.lmline(x, y, col = col.symbol, lwd = fit_lwd)
    }
  }
  pan <- function(x, y, groups, subscripts, ...)
    lattice::panel.superpose(x, y, groups = groups,
                             subscripts = subscripts,
                             panel.groups = pan.grp, ...)

  panel_color <- getOption("panel_color")
  frame_color <- ifelse(panel_color == "transparent", "gray30", panel_color)
  lab.spec <- function(lab) if (is.null(lab)) NULL else
    list(label = lab, cex = getOption("lab_size"),
         col = getOption("lab_color"))

  p <- lattice::xyplot(ff, data = dd, groups = dd$series,
    scales = scl, layout = lay, as.table = TRUE, aspect = asp,
    xlab = lab.spec(x.lab), ylab = lab.spec(y.lab),
    panel = pan,
    auto.key = list(space = "top", columns = min(k, 3L), points = TRUE),
    par.strip.text = list(cex = getOption("axis_size"),
                          col = getOption("strip_text_color")),
    par.settings = list(
      background = list(col = getOption("window_fill")),
      panel.background = list(col = getOption("panel_fill")),
      superpose.symbol = list(col = pt_color, fill = pt_fill,
                              pch = shape, cex = pt_size),
      axis.line = list(col = frame_color,
                       lty = getOption("axis_lty"),
                       lwd = getOption("axis_lwd")),
      strip.border = list(col = getOption("strip_color"), lwd = 1),
      strip.background = list(col = getOption("strip_fill"))))

  print(p)
}