R/plt.hexbinFacet.R

In lessR: Less Code with More Comprehensive Results

.plt.hexbin.facet <-
function(x, y, facet1, facet2, facet1.name, facet2.name,
         hex_bins, hexbin_legend, x.lab, y.lab, n_row, n_col, aspect, quiet,
         axis_fmt = "K", axis_x_pre = "", axis_y_pre = "") {

  # hexbinplot's constructor rejects aspect="fill", but lattice's update()
  #   accepts it, so build with a placeholder and set the real aspect after.
  #   The XY default "fill" lets each panel expand to fill its cell, so the
  #   columns are not left narrow; hexagons stretch uniformly, preserving the
  #   count-to-color encoding.  A numeric aspect or "xy" (banking) is honored.
  asp <- if (is.numeric(aspect)) aspect
         else if (identical(aspect, "xy")) "xy"
         else "fill"

  if (!requireNamespace("hexbin", quietly = TRUE)) {
    stop("Package \"hexbin\" needed for this visualization\n",
         "Please install it:  install.packages(\"hexbin\")\n\n",
         call. = FALSE)
  }

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

  if (!is.factor(facet1)) facet1 <- factor(facet1)
  facet1 <- droplevels(facet1)
  facet1 <- factor(facet1, labels = .lab.lv(facet1.name, levels(facet1)))

  # -------------------------------------------------------------------------
  # color ramp from pt_fill, identical to the single hexbin plot
  hc <- .getHC(getOption("pt_fill"))
  pt_hue <- hc[1]; pt_chroma <- hc[2]
  clr.hex <- colorRampPalette(c(
    hcl(pt_hue, pt_chroma * 0.3, 90),   # sparse  — very light
    hcl(pt_hue, pt_chroma * 0.7, 50),   # mid
    hcl(pt_hue, pt_chroma,       15)))  # dense   — full color, dark

  # -------------------------------------------------------------------------
  # conditioning formula and panel layout (lattice layout is c(cols, rows))
  d <- data.frame(x = x, y = y, ..f1 = facet1)
  if (is.null(facet2)) {
    ff <- y ~ x | ..f1
    k <- nlevels(facet1)
    if (!is.null(n_col))      lay <- c(n_col, ceiling(k / n_col))
    else if (!is.null(n_row)) lay <- c(ceiling(k / n_row), n_row)
    else { nc <- ceiling(sqrt(k)); lay <- c(nc, ceiling(k / nc)) }
  }
  else {  # two facets: cols = facet1 levels, rows = facet2 levels
    if (!is.factor(facet2)) facet2 <- factor(facet2)
    facet2 <- droplevels(facet2)
    facet2 <- factor(facet2, labels = .lab.lv(facet2.name, levels(facet2)))
    d$..f2 <- facet2
    ff <- y ~ x | ..f1 * ..f2
    lay <- c(nlevels(facet1), nlevels(facet2))
  }

  # -------------------------------------------------------------------------
  # lessR lattice styling (mirrors .plt.lattice)
  panel_color <- getOption("panel_color")
  panel_frame_color <- ifelse(panel_color == "transparent",
                              "gray30", panel_color)

  # common x/y bin bounds for every panel: makes the panels comparable and
  #   avoids a degenerate range error when a facet cell has too few (or all
  #   identical) points to define its own bounds
  xbnds <- range(x, na.rm = TRUE)
  ybnds <- range(y, na.rm = TRUE)

  # axis_fmt-formatted tick labels (e.g., 60K), matching the other forms
  axT1 <- pretty(xbnds)
  ayT2 <- pretty(ybnds)
  lbl.x <- .axis.format(axT1, axis_fmt, axis_x_pre, axis_y_pre = "no")
  lbl.y <- .axis.format(ayT2, axis_fmt, axis_x_pre = "no", axis_y_pre)

  p <- hexbin::hexbinplot(ff, data = d, xbins = hex_bins, colramp = clr.hex,
    xbnds = xbnds, ybnds = ybnds, aspect = 1,  # placeholder; reset below
    colorkey = hexbin_legend, layout = lay, as.table = TRUE,
    xlab = list(label = x.lab, cex = getOption("lab_size"),
                col = getOption("lab_color")),
    ylab = list(label = y.lab, cex = getOption("lab_size"),
                col = getOption("lab_color")),
    scales = list(col = getOption("axis_text_color"),
                  cex = getOption("axis_size"),
                  x = list(at = axT1, labels = lbl.x),
                  y = list(at = ayT2, labels = lbl.y)),
    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")),
      # extra right padding so the "Counts" legend title is not truncated
      layout.widths = list(right.padding = 3),
      axis.line = list(col = panel_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"))))

  p <- update(p, aspect = asp)  # "fill" allowed here, not in the constructor

  # hexbinplot passes neither the color cuts nor the color ramp to its
  #   colorkey, so the key defaults to 17 cuts drawn in hexbin's own gray
  #   ramp whatever the data. With counts of 1 and 2 that key repeats a
  #   swatch per cut, labeled "1" seven times and "2" seven times, in
  #   colors no panel displays. Match the key to the panels: one cut per
  #   distinct count, capped at hexbin's 17, as hexbin::plot() does for the
  #   unfaceted display, and the ramp the panels were drawn with.
  if (!is.null(p$legend$right$args)) {
    mx <- p$legend$right$args$maxcnt
    if (!is.null(mx))
      p$legend$right$args$colorcut <- seq(0, 1, length = min(17, max(mx, 2)))
    p$legend$right$args$colramp <- clr.hex
  }

  print(p)
}