diff --git a/.github/workflows/unit-tests.yml b/.github/workflows/unit-tests.yml new file mode 100644 index 0000000..2623007 --- /dev/null +++ b/.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 diff --git a/README.md b/README.md index 80c9191..f08d1ab 100644 --- a/README.md +++ b/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 diff --git a/unit_tests/run.R b/unit_tests/run.R new file mode 100644 index 0000000..6fb3d4c --- /dev/null +++ b/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) diff --git a/utils.R b/utils.R index 8290501..9b5fee4 100644 --- a/utils.R +++ b/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(