Bar stack/fill with an x axis: one bar per cell, in x order

.github/workflows/unit-tests.yml

@@ -0,0 +1,24 @@
+name: Unit tests
+
+# Functional tests of the plotting logic (unit_tests/run.R), run inside the
+# operator image built from this commit, so they use the same R and package
+# versions a release ships.
+on:
+  pull_request:
+  push:
+    branches: ['main', 'master']
+
+jobs:
+  unit-tests:
+    runs-on: ubuntu-latest
+    steps:
+      - name: Checkout repository
+        uses: actions/checkout@v4
+      - name: Build the operator image
+        run: docker build -t plot_operator:test .
+      - name: Run unit tests in the operator image
+        run: |
+          docker run --rm \
+            -v "$PWD/unit_tests:/operator/unit_tests:ro" \
+            --entrypoint R plot_operator:test \
+            --no-save --slave -f unit_tests/run.R

README.md

@@ -26,3 +26,23 @@ Output data|.
 ##### Details
 
 The operator maps the input data projected in Tercen to a ggplot chart.
+
+**Bar charts.** `bar.position` sets how the bars of a cell are drawn:
+
+* `dodge`: one bar per value, side by side.
+* `stack` and `fill`: values that share an x position are stacked; `fill` scales each stack to 1.
+  When no two values of a cell share an x position (no x axis, or the colour factor on x), the
+  whole cell is drawn as one stacked bar, first position at the bottom.
+
+The order of the bars, and of the layers of a stacked cell, is the x axis order. Without an x
+axis it is the crosstab order, by magnitude.
+
+##### Unit tests
+
+`unit_tests/run.R` checks the bar placement (order, stacking, fill) by building the bar layer and
+reading back what ggplot computes. It runs in the operator image, on every pull request
+(`.github/workflows/unit-tests.yml`) and locally:
+
+    docker build -t plot_operator:test .
+    docker run --rm -v "$PWD/unit_tests:/operator/unit_tests:ro" \
+      --entrypoint R plot_operator:test --no-save --slave -f unit_tests/run.R

unit_tests/run.R

@@ -0,0 +1,130 @@
+# Unit tests for the bar placement in utils.R.
+#
+# Run inside the operator image, from /operator:
+#   docker build -t plot_operator:test .
+#   docker run --rm -v "$PWD/unit_tests:/operator/unit_tests:ro" \
+#     --entrypoint R plot_operator:test --no-save --slave -f unit_tests/run.R
+#
+# Base R only (no testthat), so the production image needs nothing extra. Each
+# test builds the bar layer the operator draws and reads back what ggplot
+# computed (ggplot_build): positions, groups and stacked heights.
+suppressPackageStartupMessages({
+  library(dplyr)
+  library(ggplot2)
+})
+source("utils.R")
+
+failures <- character()
+check <- function(desc, expr) {
+  ok <- tryCatch(isTRUE(expr), error = function(e) {
+    message("  error: ", conditionMessage(e))
+    FALSE
+  })
+  cat(if (ok) "PASS " else "FAIL ", desc, "\n", sep = "")
+  if (!ok) failures <<- c(failures, desc)
+}
+
+# Two cells, three labels each, values that do not sum to 1, in a scrambled read
+# order. `xl` is the crosstab's .xLevels: ascending value within the cell.
+cells <- data.frame(
+  .ri   = c(0, 0, 0, 0, 0, 0),
+  .ci   = c(0, 0, 0, 1, 1, 1),
+  label = c("C", "A", "B", "B", "C", "A"),
+  .y    = c(5, 2, 9, 1, 4, 7),
+  xl    = c(1, 0, 2, 0, 1, 2),
+  .axisIndex = 0L
+)
+
+# The bars ggplot computes for the operator's bar layer, as generate_plot sets it
+# up: the same global mapping and one panel per crosstab cell.
+bars <- function(df, has_x_axis, bar_position, dodge_width = 0.8) {
+  collapsed <- collapse_bars(df, has_x_axis, bar_position)
+  if (collapsed) df <- stack_cells(df)
+  p <- suppressWarnings(ggplot(mapping = aes_string(
+    x = ".x", y = ".y", fill = "label", group = "label", order = "label"
+  ))) +
+    suppressWarnings(bar_layer(df, collapsed, bar_position, dodge_width, size = 0.5, color = "black")) +
+    facet_grid(.ri ~ .ci)
+  d <- suppressWarnings(layer_data(p, 1))
+  d$height <- d$ymax - d$ymin
+  d
+}
+
+# Labels of one panel from bottom to top, identified by their height (the test
+# values are distinct within a cell). For fill, heights are shares of the total.
+stack_order <- function(d, panel, df, ci, fill = FALSE) {
+  cell <- df[df$.ci == ci, ]
+  d <- d[d$PANEL == panel, ]
+  d <- d[order(d$ymin), ]
+  h <- if (fill) d$height * sum(cell$.y) else d$height
+  vapply(h, function(v) cell$label[which.min(abs(cell$.y - v))], "")
+}
+
+no_x <- crosstab_x_position(cells, cells$xl)
+
+cat("-- x position without an x axis\n")
+check("uses the crosstab position (.xLevels + 1)", identical(no_x$.x, as.integer(cells$xl) + 1L))
+fallback <- crosstab_x_position(cells)
+check("falls back to read order per cell without .xLevels",
+      identical(fallback$.x, c(1L, 2L, 3L, 1L, 2L, 3L)))
+
+cat("-- when cells are drawn as one bar\n")
+check("no x axis, stack: one bar per cell", collapse_bars(no_x, FALSE, "stack"))
+check("no x axis, fill: one bar per cell", collapse_bars(no_x, FALSE, "fill"))
+check("no x axis, dodge: separate bars", !collapse_bars(no_x, FALSE, "dodge"))
+x_label <- mutate(cells, .x = label)
+check("x = colour factor (one value per x), stack: one bar", collapse_bars(x_label, TRUE, "stack"))
+check("x = colour factor, dodge: separate bars", !collapse_bars(x_label, TRUE, "dodge"))
+by_day <- bind_rows(mutate(cells, .x = 1), mutate(cells, .x = 2, .y = .y + 1))
+check("numeric x with several values per x, stack: per-x stacking", !collapse_bars(by_day, TRUE, "stack"))
+mixed <- bind_rows(mutate(cells[1:3, ], .x = 1), mutate(cells[4:6, ], .x = c(1, 2, 3)))
+check("one cell with values sharing an x keeps per-x stacking", !collapse_bars(mixed, TRUE, "stack"))
+
+cat("-- no x axis\n")
+d <- bars(no_x, FALSE, "stack")
+check("stack: one bar per cell", all(table(d$PANEL) == 3) && all(tapply(d$x, d$PANEL, function(v) length(unique(v))) == 1))
+check("stack: bar height is the cell total", isTRUE(all.equal(as.vector(tapply(d$ymax, d$PANEL, max)), c(16, 12))))
+check("stack: smallest value at the bottom (crosstab order), cell 1",
+      identical(stack_order(d, 1, no_x, 0), c("A", "C", "B")))
+check("stack: smallest value at the bottom (crosstab order), cell 2",
+      identical(stack_order(d, 2, no_x, 1), c("B", "C", "A")))
+d <- bars(no_x, FALSE, "fill")
+check("fill: every bar reaches 1", isTRUE(all.equal(as.vector(tapply(d$ymax, d$PANEL, max)), c(1, 1))))
+check("fill: same order as stack", identical(stack_order(d, 1, no_x, 0, fill = TRUE), c("A", "C", "B")))
+d <- bars(no_x, FALSE, "dodge")
+p1 <- d[d$PANEL == 1, ]
+check("dodge: one bar per value, ordered by magnitude", identical(p1$height[order(p1$x)], c(2, 5, 9)))
+
+cat("-- x axis = the colour factor\n")
+d <- bars(x_label, TRUE, "stack")
+check("stack: one bar per cell", all(tapply(d$x, d$PANEL, function(v) length(unique(v))) == 1))
+check("stack: in x-axis order, first at the bottom, cell 1",
+      identical(stack_order(d, 1, x_label, 0), c("A", "B", "C")))
+check("stack: in x-axis order, first at the bottom, cell 2",
+      identical(stack_order(d, 2, x_label, 1), c("A", "B", "C")))
+d <- bars(x_label, TRUE, "fill")
+check("fill: every bar reaches 1, in x-axis order",
+      isTRUE(all.equal(as.vector(tapply(d$ymax, d$PANEL, max)), c(1, 1))) &&
+      identical(stack_order(d, 2, x_label, 1, fill = TRUE), c("A", "B", "C")))
+
+cat("-- x axis with values sharing an x: plain ggplot behaviour\n")
+plain <- function(df, position) {
+  p <- suppressWarnings(ggplot(mapping = aes_string(
+    x = ".x", y = ".y", fill = "label", group = "label", order = "label"
+  ))) +
+    suppressWarnings(geom_bar(data = df, position = position, stat = "identity", size = 0.5, width = 0.5, color = "black")) +
+    facet_grid(.ri ~ .ci)
+  suppressWarnings(layer_data(p, 1))
+}
+same_bars <- function(a, b) {
+  cols <- c("PANEL", "x", "xmin", "xmax", "ymin", "ymax", "group")
+  isTRUE(all.equal(a[cols], b[cols], check.attributes = FALSE))
+}
+check("stack: one stacked bar per x, as ggplot", same_bars(bars(by_day, TRUE, "stack"), plain(by_day, "stack")))
+check("fill: as ggplot", same_bars(bars(by_day, TRUE, "fill"), plain(by_day, "fill")))
+check("dodge: as ggplot", same_bars(bars(by_day, TRUE, "dodge", 0.8), plain(by_day, position_dodge(width = 0.8))))
+check("dodge with x = colour factor: as ggplot",
+      same_bars(bars(x_label, TRUE, "dodge", 0.8), plain(x_label, position_dodge(width = 0.8))))
+
+cat("\n", length(failures), " failed\n", sep = "")
+if (length(failures)) quit(status = 1)

utils.R

@@ -187,14 +187,11 @@ getValues <- function(ctx, is_2d_histogram = FALSE) {
     # view shows them (by magnitude). Counting rows here instead gave whatever
     # order the table was read in.
     qt_names <- unlist(lapply(ctx$schema$columns, "[[", "name"))
+    x_levels <- NULL
     if (!ctx$isPairwise && ".xLevels" %in% qt_names) {
-      data$.x <- as.integer(select(ctx, .xLevels)[[".xLevels"]]) + 1L
-    } else {
-      data <- data %>%
-        group_by(.ci, .ri) %>%
-        mutate(.x = row_number()) %>%
-        ungroup()
+      x_levels <- select(ctx, .xLevels)[[".xLevels"]]
     }
+    data <- crosstab_x_position(data, x_levels)
   }
 
   if (length(ctx$colors))
@@ -258,6 +255,75 @@ getValues <- function(ctx, is_2d_histogram = FALSE) {
 
 
 
+#####
+### Bar placement
+# Pure functions (a data frame in, a data frame or a ggplot layer out) so that
+# unit_tests/ can check them without a Tercen context.
+
+# x position of each value when the projection has no x axis. `x_levels` is the
+# crosstab's own position per cell (`.xLevels`, 0-based, by magnitude), so the
+# bars follow the crosstab view. Without it (pairwise projections), values are
+# numbered in read order within each cell.
+crosstab_x_position <- function(data, x_levels = NULL) {
+  if (!is.null(x_levels)) {
+    data$.x <- as.integer(x_levels) + 1L
+    return(data)
+  }
+  data %>%
+    group_by(.ci, .ri) %>%
+    mutate(.x = row_number()) %>%
+    ungroup()
+}
+
+# Stack and fill need values that share an x position. Without an x axis, or
+# when the x axis gives every value of a cell its own position (e.g. the colour
+# factor on x), nothing shares one: the whole cell is then drawn as one bar.
+# When values do share an x, ggplot stacks them per x position.
+collapse_bars <- function(df, has_x_axis, bar_position) {
+  if (!bar_position %in% c("stack", "fill")) return(FALSE)
+  !has_x_axis || all(dplyr::count(df, .ri, .ci, .x)$n == 1)
+}
+
+# One bar per cell: stack in x order (crosstab order without an x axis).
+stack_cells <- function(df) {
+  df %>% mutate(.stack_level = as.integer(factor(.x)), .x = 1)
+}
+
+# The bar layer. A collapsed cell stacks its values first position at the
+# bottom; otherwise the position is the bar.position setting.
+bar_layer <- function(df, collapsed, bar_position, dodge_width, size, color) {
+  if (collapsed) {
+    pos <- if (bar_position == "fill") {
+      position_fill(reverse = TRUE)
+    } else {
+      position_stack(reverse = TRUE)
+    }
+    return(geom_bar(
+      data = df,
+      mapping = aes(group = .stack_level),
+      position = pos,
+      stat = "identity",
+      size = size,
+      width = 0.5,
+      color = color
+    ))
+  }
+  pos <- switch(
+    bar_position,
+    "dodge" = position_dodge(width = dodge_width),
+    "stack" = "stack",
+    "fill" = "fill"
+  )
+  geom_bar(
+    data = df,
+    position = pos,
+    stat = "identity",
+    size = size,
+    width = 0.5,
+    color = color
+  )
+}
+
 get_axis_labels <- function(ctx, lab, type) {
   nms <- switch(
     type,
@@ -350,13 +416,6 @@ generate_plot <-
         )
       )
 
-      pos <- switch (
-        input.par$bar.position,
-        "dodge" = position_dodge(width = input.par$dodge.width),
-        "stack" = "stack",
-        "fill" = "fill"
-      )
-
       for (j in seq_along(chart_types)) {
         type <- chart_types[j]
         df_plot <- df %>% filter(.axisIndex == j - 1L)
@@ -394,36 +453,16 @@ generate_plot <-
             )
           }
           if (type == "ChartBar") {
-            if (!ctx$hasXAxis && input.par$bar.position %in% c("stack", "fill")) {
-              # No x axis: every value of a cell sits at its own crosstab
-              # position, so there is nothing at a shared x to stack or fill.
-              # Put the whole cell on one bar and stack it in crosstab order
-              # (first crosstab position at the bottom).
-              df_plot <- df_plot %>% mutate(.stack_level = .x, .x = 1)
-              stack_pos <- if (input.par$bar.position == "fill") {
-                position_fill(reverse = TRUE)
-              } else {
-                position_stack(reverse = TRUE)
-              }
-              plt <- plt + geom_bar(
-                data = df_plot,
-                mapping = aes(group = .stack_level),
-                position = stack_pos,
-                stat = "identity",
-                size = 0.5 * chart_sizes[j] / size_scale_factor,
-                width = 0.5,
-                color = default_color
-              )
-            } else {
-              plt <- plt + geom_bar(
-                data = df_plot,
-                position = pos,
-                stat = "identity",
-                size = 0.5 * chart_sizes[j] / size_scale_factor,
-                width = 0.5,
-                color = default_color
-              )
-            }
+            collapsed <- collapse_bars(df_plot, ctx$hasXAxis, input.par$bar.position)
+            if (collapsed) df_plot <- stack_cells(df_plot)
+            plt <- plt + bar_layer(
+              df_plot,
+              collapsed = collapsed,
+              bar_position = input.par$bar.position,
+              dodge_width = input.par$dodge.width,
+              size = 0.5 * chart_sizes[j] / size_scale_factor,
+              color = default_color
+            )
           }
           if (type == "2D_Histogram") {
             plt <- plt + geom_rect(