RS-21803: Row Spans test

tests/testthat/test-createcustomtable.R

@@ -275,3 +275,288 @@ test_that("use.predefined.css = FALSE leaves the spacer header cell with no matc
     resDefault <- CreateCustomTable(m4, show.row.headers = FALSE, spacer.col = 2)
     expect_true(grepl('.spacer {', tableHtml(resDefault), fixed = TRUE))
 })
+
+# row.spans --------------------------------------------------------------
+
+# the documented @examples matrix; heights in the tests below are chosen to sum to nrow (4)
+# unless the scenario is deliberately exercising mismatched heights
+rowSpanMatrix <- structure(1:24, .Dim = c(4L, 6L),
+    .Dimnames = list(c("a", "b", "c", "d"), c("A", "B", "C", "D", "E", "F")))
+
+test_that("Default emits no rowspan cells",
+{
+    res <- CreateCustomTable(x2)
+    expect_false(grepl("rowspan=", tableHtml(res), fixed = TRUE))
+})
+
+test_that("One rowspan cell per span, with the right heights and labels",
+{
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans)
+    h <- tableHtml(res)
+    # anchored with the trailing quote so rowspan="1" cannot match rowspan="10"-style values
+    expect_equal(countOccurrences('<td rowspan="2" class="rowspandefault1">', h), 1)
+    expect_equal(countOccurrences('<td rowspan="1" class="rowspandefault1">', h), 2)
+    expect_true(grepl('<td rowspan="2" class="rowspandefault1">AA</td>', h, fixed = TRUE))
+    expect_true(grepl('<td rowspan="1" class="rowspandefault1">BB</td>', h, fixed = TRUE))
+    expect_true(grepl('<td rowspan="1" class="rowspandefault1">CC</td>', h, fixed = TRUE))
+})
+
+test_that("Spans are placed at the correct row offsets",
+{
+    # heights of 2, 1, 1 mean AA's span covers rows 1-2 (leaving row 2 without its own span
+    # cell), BB opens row 3 and CC opens row 4 - pinning the j <- j + row.span.lengths[i] loop
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans)
+    h <- tableHtml(res)
+    body <- sub(".*</thead>", "", h)
+    rows <- regmatches(body, gregexpr("<tr>.*?</tr>", body))[[1]]
+    expect_equal(length(rows), 4)
+    expect_true(grepl('<tr><td rowspan="2"', rows[1], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[2], fixed = TRUE))
+    expect_true(grepl('<tr><td rowspan="1" class="rowspandefault1">BB</td>', rows[3], fixed = TRUE))
+    expect_true(grepl('<tr><td rowspan="1" class="rowspandefault1">CC</td>', rows[4], fixed = TRUE))
+})
+
+test_that("A single rowspandefault CSS class is shared across all spans when sticky positioning is off",
+{
+    # NOT a production bug: addCSSclass() only expands class.css into a per-row/per-column
+    # matrix when its `position` argument is non-NULL (see addCSSclass() in
+    # createcustomtable.R). Here row.height/num.header.rows are not set, so top.position is
+    # NULL and the row-span block's scalar CSS string is never expanded - addCSSclass()
+    # derives its class count from length(class.css), so it creates a single
+    # "rowspandefault1" class that every span's <td> reuses. (The row-header block passes the
+    # same top.position variable as its own `position` argument; on this default path
+    # top.position is also NULL, so that block collapses to a single shared class too - it
+    # only ends up with one class per row when its call *does* supply a non-NULL `position`,
+    # i.e. on the sticky path.) On the sticky path (see the next test) each span DOES
+    # get its own "rowspandefaultN" class, matching the plan's expectation.
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans)
+    h <- normWs(tableHtml(res))
+    # trailing "{" anchors the declaration itself, distinct from the "rowspandefault1" token
+    # that also appears (three times, once in each span's class attribute)
+    expect_equal(countOccurrences(".rowspandefault1{", h), 1)
+    expect_equal(countOccurrences(".rowspandefault2{", h), 0)
+    expect_equal(countOccurrences('class="rowspandefault1">', h), 3)
+})
+
+test_that("Each span gets its own rowspandefault CSS class when sticky positioning is on",
+{
+    # With row.height/num.header.rows set, top.position is non-NULL, so addCSSclass()
+    # expands the row-span CSS string into one class per span (rowspandefault1/2/3) instead
+    # of sharing a single class - the counterpart to the sticky-off case above.
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.height = "30px", num.header.rows = 1,
+                    row.spans = spans)
+    h <- normWs(tableHtml(res))
+    expect_equal(countOccurrences(".rowspandefault1{", h), 1)
+    expect_equal(countOccurrences(".rowspandefault2{", h), 1)
+    expect_equal(countOccurrences(".rowspandefault3{", h), 1)
+    expect_equal(countOccurrences(".rowspandefault4{", h), 0)
+})
+
+test_that("A per-span class is appended, not substituted",
+{
+    spans <- list(list(height = 2, label = "AA", class = "bluefill"),
+                  list(height = 1, label = "BB"), list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans)
+    h <- tableHtml(res)
+    expect_true(grepl('<td rowspan="2" class="rowspandefault1 bluefill">AA</td>', h, fixed = TRUE))
+})
+
+test_that("A span without a class entry carries only the generated class",
+{
+    spans <- list(list(height = 2, label = "AA", class = "bluefill"),
+                  list(height = 1, label = "BB"), list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans)
+    h <- tableHtml(res)
+    # exact match (no trailing token/space) confirms nothing was appended for BB
+    expect_true(grepl('<td rowspan="1" class="rowspandefault1">BB</td>', h, fixed = TRUE))
+})
+
+test_that("Span styling arguments reach the rowspandefault CSS declaration",
+{
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans, row.span.fill = "rgb(9,9,9)",
+                    row.span.font.size = 21, row.span.align.horizontal = "right")
+    h <- normWs(tableHtml(res))
+    # anchor to the rowspandefault1 declaration itself, not just anywhere in the document,
+    # so the assertions cannot be satisfied by an unrelated CSS rule
+    block <- regmatches(h, regexpr(".rowspandefault1[{][^}]*[}]", h))
+    expect_true(grepl("background: rgb(9,9,9)", block, fixed = TRUE))
+    expect_true(grepl("font-size: 21px", block, fixed = TRUE))
+    expect_true(grepl("text-align: right", block, fixed = TRUE))
+})
+
+test_that("row.spans prepends an extra header cell (ncol + 2 th cells)",
+{
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    # a distinct corner label lets ths[1] (row-span corner, always blank) and ths[2]
+    # (row-header corner, carries `corner`) be told apart even if their order were swapped
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans, corner = "RH")
+    h <- tableHtml(res)
+    thead <- sub("</thead>.*", "", h)
+    ths <- regmatches(thead, gregexpr('<th class="[^"]*">[^<]*</th>', thead))[[1]]
+    # 6 data columns + row-header corner + row-span corner
+    expect_equal(length(ths), 8)
+    expect_equal(ths[1], '<th class="cornerdefault1"></th>')
+    expect_equal(ths[2], '<th class="cornerdefault1">RH</th>')
+})
+
+test_that("Adding row.spans increases (does not reduce) the emitted sticky-position count",
+{
+    # PLAN DEVIATION: the plan expected the rm.index pruning at the top of the row.spans
+    # block to REDUCE the sticky-position count relative to the no-spans case. In practice
+    # that pruning trims the top.position vector, which is reassigned and then also fed
+    # into the row-span column's OWN addCSSclass() call; the cell/row-header sticky counts
+    # (computed earlier in the function) are unaffected. (A table combining row.spans with
+    # col.spans would also see the col-span classes affected, since the later column-span
+    # block passes the same pruned top.position as its position argument.) Because the
+    # row-span column also gets a "position: sticky" class of its own, adding row.spans
+    # increases the total sticky count by 1 (for num.header.rows = 1, the minimal
+    # combination) rather than decreasing it. Pinning the actual, confirmed behaviour
+    # instead of the plan's assumption.
+    # NOTE: at num.header.rows = 1, top.position has length 1, so the emitted output is the
+    # same either way: for the heights used here (2, 1, 1) rm.index holds only out-of-range
+    # indices (>= 2), so `top.position[-rm.index]` is a no-op. If every span height were 1,
+    # rm.index would stay NULL and `top.position[-rm.index]` (i.e. `top.position[-NULL]`)
+    # would error rather than silently no-op - but that all-heights-1 combination is never
+    # exercised at num.header.rows = 1 by this test. See the num.header.rows = 2 case below
+    # for the pruning branch actually removing an index.
+    spans <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    noSpans <- CreateCustomTable(rowSpanMatrix, row.height = "30px", num.header.rows = 1)
+    withSpans <- CreateCustomTable(rowSpanMatrix, row.height = "30px", num.header.rows = 1,
+                    row.spans = spans)
+    countNoSpans <- countOccurrences("position: sticky", tableHtml(noSpans))
+    countWithSpans <- countOccurrences("position: sticky", tableHtml(withSpans))
+    expect_equal(countWithSpans, countNoSpans + 1)
+})
+
+test_that("The rm.index pruning branch is actually exercised at num.header.rows = 2",
+{
+    # At num.header.rows = 2, top.position has length 2, so rm.index pruning is only a
+    # no-op when no span's offset (height - 1) lands on index 2. A front-loaded span
+    # (heights 2, 1, 1) prunes index 2 out of top.position; a back-loaded span
+    # (heights 1, 1, 2) does not prune anything, since its offset lands past top.position's
+    # length. Confirmed counts: no spans -> noSpans, front-loaded (pruned) -> noSpans + 1,
+    # back-loaded (not pruned) -> noSpans + 2. Expressed relative to noSpans (rather than
+    # hardcoded absolutes) so an unrelated CSS addition elsewhere doesn't make this brittle.
+    frontLoaded <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    backLoaded <- list(list(height = 1, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 2, label = "CC"))
+    resNoSpans <- CreateCustomTable(rowSpanMatrix, row.height = "30px", num.header.rows = 2)
+    withFront <- CreateCustomTable(rowSpanMatrix, row.height = "30px", num.header.rows = 2,
+                    row.spans = frontLoaded)
+    withBack <- CreateCustomTable(rowSpanMatrix, row.height = "30px", num.header.rows = 2,
+                    row.spans = backLoaded)
+    noSpans <- countOccurrences("position: sticky", tableHtml(resNoSpans))
+    expect_equal(countOccurrences("position: sticky", tableHtml(withFront)), noSpans + 1)
+    expect_equal(countOccurrences("position: sticky", tableHtml(withBack)), noSpans + 2)
+})
+
+test_that("Span heights not summing to nrow are pinned to current (unvalidated) behaviour",
+{
+    # under-covering: heights sum to 2 against nrow = 4, so rows 3-4 simply get no span cell
+    spans <- list(list(height = 1, label = "AA"), list(height = 1, label = "BB"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = spans)
+    h <- tableHtml(res)
+    body <- sub(".*</thead>", "", h)
+    rows <- regmatches(body, gregexpr("<tr>.*?</tr>", body))[[1]]
+    expect_equal(length(rows), 4)
+    expect_true(grepl('<tr><td rowspan="1" class="rowspandefault1">AA</td>', rows[1], fixed = TRUE))
+    expect_true(grepl('<tr><td rowspan="1" class="rowspandefault1">BB</td>', rows[2], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[3], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[4], fixed = TRUE))
+
+    # over-covering: a single span with a height greater than nrow completes without error;
+    # there is no bounds check in the j <- j + row.span.lengths[i] loop, but with only one
+    # span the loop makes just one assignment (row.span.html[1] <- ...) before it ends, so
+    # `j` only overruns nrow AFTER that final (and only) span - row.span.html never grows
+    # beyond its original length and no misalignment occurs here. See the multi-span case
+    # below for what happens when a later span's assignment lands past the overrun.
+    overSpans <- list(list(height = 10, label = "AA"))
+    res <- CreateCustomTable(rowSpanMatrix, row.spans = overSpans)
+    h <- tableHtml(res)
+    body <- sub(".*</thead>", "", h)
+    rows <- regmatches(body, gregexpr("<tr>.*?</tr>", body))[[1]]
+    expect_equal(length(rows), 4)
+    expect_true(grepl('<tr><td rowspan="10" class="rowspandefault1">AA</td>', rows[1], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[2], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[3], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[4], fixed = TRUE))
+})
+
+test_that("A multi-span over-cover silently drops the last span and leaks a cbind warning (genuine defect, not yet ticketed)",
+{
+    # Genuine production defect being pinned here, not the plan-authoring mistake above:
+    # when a span's height pushes `j` (in the `j <- j + row.span.lengths[i]` loop) past
+    # nrow, the next assignment to row.span.html[j] silently grows that vector beyond
+    # nrows (here to length 12, for the height-1/10/3 spans below) - so CC's span is written
+    # past the end of the table and effectively discarded, rather than misaligning rows 3-4
+    # (the emitted rowspan attribute keeps its literal, oversized value - e.g. rowspan="10" -
+    # and it is the browser's HTML renderer, not this code, that clamps it to the remaining
+    # rows, so the table shape itself stays correct). cbind(row.span.html, cell.html) then
+    # warns because the result's row count
+    # (4, taken from cell.html) is not a multiple of row.span.html's length (12). No ticket
+    # has been filed for this yet.
+    overSpans <- list(list(height = 1, label = "AA"), list(height = 10, label = "BB"),
+                  list(height = 3, label = "CC"))
+    expect_warning(
+        res <- CreateCustomTable(rowSpanMatrix, row.spans = overSpans),
+        "number of rows of result is not a multiple of vector length", fixed = TRUE
+    )
+    h <- tableHtml(res)
+    body <- sub(".*</thead>", "", h)
+    rows <- regmatches(body, gregexpr("<tr>.*?</tr>", body))[[1]]
+    expect_equal(length(rows), 4)
+    expect_true(grepl('<tr><td rowspan="1" class="rowspandefault1">AA</td>', rows[1], fixed = TRUE))
+    expect_true(grepl('<tr><td rowspan="10" class="rowspandefault1">BB</td>', rows[2], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[3], fixed = TRUE))
+    expect_false(grepl("rowspan", rows[4], fixed = TRUE))
+})
+
+test_that("All-height-1 row.spans with sticky positioning errors on invalid unary -NULL (genuine unticketed defect)",
+{
+    # Genuine production crash being pinned here (not yet ticketed): rm.index is only
+    # populated for spans taller than one row, so when EVERY span height is 1, rm.index
+    # stays NULL, and the pruning expression `top.position[-rm.index]` becomes
+    # `top.position[-NULL]`. In base R, unary minus on NULL is invalid ("invalid argument
+    # to unary operator"), so the function throws rather than returning the original
+    # top.position unchanged. This only happens when sticky positioning is also active
+    # (row.height set AND num.header.rows set), since top.position is only computed - and
+    # only fed into the row.spans pruning branch - in that case. If this defect is ever
+    # fixed, this expect_error should be changed to assert successful output instead.
+    allOnes <- list(list(height = 1, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"), list(height = 1, label = "DD"))
+    expect_error(
+        CreateCustomTable(rowSpanMatrix, row.spans = allOnes, row.height = "30px",
+            num.header.rows = 1),
+        "invalid argument to unary operator", fixed = TRUE
+    )
+
+    # Same all-height-1 spans without sticky positioning: top.position/rm.index pruning is
+    # never reached, so this succeeds - the crash is specific to the sticky combination,
+    # not to row.spans (or all-height-1 spans) in general.
+    expect_error(res <- CreateCustomTable(rowSpanMatrix, row.spans = allOnes), NA)
+    expect_true(grepl('<td rowspan="1" class="rowspandefault1">AA</td>', tableHtml(res),
+        fixed = TRUE))
+
+    # Mixed heights (2, 1, 1) with the same sticky args: rm.index is populated (the height-2
+    # span), so the pruning expression is a normal subscript, not `-NULL`, and this succeeds.
+    mixedHeights <- list(list(height = 2, label = "AA"), list(height = 1, label = "BB"),
+                  list(height = 1, label = "CC"))
+    expect_error(
+        CreateCustomTable(rowSpanMatrix, row.spans = mixedHeights, row.height = "30px",
+            num.header.rows = 1),
+        NA
+    )
+})