From 60caa4732360bea03558d3732735f68a5276fb14 Mon Sep 17 00:00:00 2001 From: Surrey Date: Fri, 21 Aug 2026 10:53:47 +1000 Subject: [PATCH 1/3] test: add CreateCustomTable header visibility and cell formatting coverage Covers transpose, show.col.headers/show.row.headers (including the NULL-dimnames force-disable paths), cell.align.horizontal, font.size and font.unit propagation, cell.font.size override, col.header.classes/ row.header.classes, col.classes/row.classes (including their positional list access) and the cell.inline.styl typo's no-op behaviour. Co-Authored-By: Claude Opus 4.8 (1M context) --- tests/testthat/test-createcustomtable.R | 255 ++++++++++++++++++++++++ 1 file changed, 255 insertions(+) diff --git a/tests/testthat/test-createcustomtable.R b/tests/testthat/test-createcustomtable.R index 5ec99e2..11cfc75 100644 --- a/tests/testthat/test-createcustomtable.R +++ b/tests/testthat/test-createcustomtable.R @@ -660,3 +660,258 @@ test_that("Row count does not change how many times the banding rule is emitted" expect_equal(countOccurrences("nth-child(odd)", tableHtml(res2)), 1) expect_equal(countOccurrences("nth-child(odd)", tableHtml(res7)), 1) }) + +# header visibility and cell formatting ---------------------------------- + +test_that("transpose swaps which labels become row vs column headers", +{ + m <- matrix(1:6, 2, 3, dimnames = list(c("r1", "r2"), c("c1", "c2", "c3"))) + res <- CreateCustomTable(m, transpose = TRUE) + h <- normWs(tableHtml(res)) + + # the former row names (r1, r2) now form the column-header row + expect_true(grepl('r1r2', + h, fixed = TRUE)) + # the former column names (c1, c2, c3) now form the row-header cells + expect_true(grepl('c1', h, fixed = TRUE)) + expect_true(grepl('c2', h, fixed = TRUE)) + expect_true(grepl('c3', h, fixed = TRUE)) +}) + +test_that("transpose changes the cell order to that of the original first column", +{ + m <- matrix(1:6, 2, 3, dimnames = list(c("r1", "r2"), c("c1", "c2", "c3"))) + res <- CreateCustomTable(m, transpose = TRUE) + h <- tableHtml(res) + + # original column c1 was r1=1, r2=2; after transpose this becomes the first body row + rows <- regmatches(h, gregexpr(".*?", h))[[1]] + firstBodyRow <- rows[2] # rows[1] is the header row inside + expect_true(grepl(">1", firstBodyRow, fixed = TRUE)) + expect_true(grepl(">2", firstBodyRow, fixed = TRUE)) + expect_false(grepl(">5", firstBodyRow, fixed = TRUE)) +}) + +test_that("show.col.headers = FALSE emits no column-header cell and no colheaderdefault CSS rule", +{ + # anchored on 'class="' so the surrounding tag (which also starts 'a", h, fixed = TRUE)) + expect_false(grepl("rowheaderdefault", h, fixed = TRUE)) + + # positive control: both are present when row headers are shown + resShown <- CreateCustomTable(x2) + hShown <- tableHtml(resShown) + expect_true(grepl(">a", hShown, fixed = TRUE)) + expect_true(grepl("rowheaderdefault", hShown, fixed = TRUE)) +}) + +test_that("show.col.headers and show.row.headers both FALSE emits a bare data grid", +{ + res <- CreateCustomTable(x2, show.col.headers = FALSE, show.row.headers = FALSE) + h <- tableHtml(res) + expect_false(grepl('a", h, fixed = TRUE)) + + rows <- regmatches(h, gregexpr(".*?", h))[[1]] + firstBodyRow <- rows[1] + expect_equal(countOccurrences("[^<]*', h))[[1]] + dataHeaders <- thTags[grepl("colheaderdefault", thTags, fixed = TRUE)] + expect_equal(length(dataHeaders), ncol(x2)) + expect_true(all(grepl('colheaderdefault1 myhdr">', dataHeaders, fixed = TRUE))) +}) + +test_that("row.header.classes is appended to the generated rowheaderdefault class", +{ + res <- CreateCustomTable(x2, row.header.classes = "myrowhdr") + h <- tableHtml(res) + rowHdrTags <- regmatches(h, gregexpr('[a-d]', h))[[1]] + expect_equal(length(rowHdrTags), nrow(x2)) + expect_true(all(grepl('rowheaderdefault1 myrowhdr">', rowHdrTags, fixed = TRUE))) +}) + +test_that("col.classes applies to a whole data column, indexed against data columns only", +{ + res <- CreateCustomTable(x2, col.classes = list(list(ix = 3, class = "bluefill")), + show.row.headers = TRUE) + h <- tableHtml(res) + rows <- regmatches(h, gregexpr(".*?", h))[[1]] + bodyRows <- rows[-1] + expect_equal(length(bodyRows), nrow(x2)) + for (row in bodyRows) + { + tds <- regmatches(row, gregexpr('', row))[[1]] + # tds[1] is the row-header cell, tds[2:4] are data columns 1:3 + expect_false(grepl("bluefill", tds[2], fixed = TRUE)) + expect_false(grepl("bluefill", tds[3], fixed = TRUE)) + expect_true(grepl("bluefill", tds[4], fixed = TRUE)) + } +}) + +test_that("row.classes applies to a whole data row", +{ + res <- CreateCustomTable(x2, row.classes = list(list(ix = 1, class = "redfill"))) + h <- tableHtml(res) + rows <- regmatches(h, gregexpr(".*?", h))[[1]] + bodyRows <- rows[-1] + + row1Tds <- regmatches(bodyRows[1], gregexpr('', bodyRows[1]))[[1]] + expect_true(all(grepl("redfill", row1Tds[2:4], fixed = TRUE))) + + row2Tds <- regmatches(bodyRows[2], gregexpr('', bodyRows[2]))[[1]] + expect_false(any(grepl("redfill", row2Tds[2:4], fixed = TRUE))) +}) + +test_that("col.classes and row.classes intersect on the shared cell", +{ + res <- CreateCustomTable(x2, col.classes = list(list(ix = 2, class = "bluefill")), + row.classes = list(list(ix = 1, class = "redfill"))) + h <- tableHtml(res) + rows <- regmatches(h, gregexpr(".*?", h))[[1]] + bodyRows <- rows[-1] + + row1Tds <- regmatches(bodyRows[1], gregexpr('', bodyRows[1]))[[1]] + # data column 2 of row 1 carries both classes; columns 1 and 3 of row 1 carry only redfill + expect_true(grepl("redfill", row1Tds[2], fixed = TRUE)) + expect_false(grepl("bluefill", row1Tds[2], fixed = TRUE)) + expect_true(grepl("redfill", row1Tds[3], fixed = TRUE)) + expect_true(grepl("bluefill", row1Tds[3], fixed = TRUE)) + expect_true(grepl("redfill", row1Tds[4], fixed = TRUE)) + expect_false(grepl("bluefill", row1Tds[4], fixed = TRUE)) + + row2Tds <- regmatches(bodyRows[2], gregexpr('', bodyRows[2]))[[1]] + expect_false(grepl("redfill", row2Tds[3], fixed = TRUE)) + expect_true(grepl("bluefill", row2Tds[3], fixed = TRUE)) +}) + +test_that("col.classes/row.classes read ix/class positionally, so the element names are cosmetic", +{ + resNamed <- CreateCustomTable(x2, col.classes = list(list(ix = 3, class = "bluefill"))) + resUnnamed <- CreateCustomTable(x2, col.classes = list(list(foo = 3, bar = "bluefill"))) + + # the random per-call container name means the documents differ byte-for-byte; + # compare only the column-3 body cells, which is what this scenario is about + extractCol3 <- function(h) regmatches(h, gregexpr('(9|10|11|12)', h))[[1]] + col3Named <- extractCol3(tableHtml(resNamed)) + col3Unnamed <- extractCol3(tableHtml(resUnnamed)) + expect_length(col3Named, nrow(x2)) + expect_identical(col3Named, col3Unnamed) +}) + +test_that("The cell.inline.styl typo means sig.change.fills styling is never prepended for the header row", +{ + # createcustomtable.R assigns 'cell.inline.styl <- rbind("", cell.inline.style)' (missing + # the letter 'e'); this writes to a variable that is never read again, so the header-row + # blank-style prepend it was meant to add to cell.inline.style is silently discarded. This + # is a confirmed defect (separate from this test-writing task) - pinned here as current, + # no-op behaviour: the inline style block is emitted exactly once, on the flagged data cell, + # never on a header cell. + sig <- matrix(0, nrow(x2), ncol(x2)) + sig[1, 1] <- 1 + res <- CreateCustomTable(x2, sig.change.fills = sig, show.col.headers = TRUE) + h <- tableHtml(res) + expect_equal(countOccurrences("style='background:", h), 1) + expect_true(grepl("celldefault1\" style='background:rgb(195,255,199)'>1", h, fixed = TRUE)) + + headerBlock <- regmatches(h, regexpr(".*?", h)) + expect_length(headerBlock, 1) + expect_false(grepl("style=", headerBlock, fixed = TRUE)) +}) From 98710f9c5b11ba1f2cd3aa6e772c2ff5b5b5c8bf Mon Sep 17 00:00:00 2001 From: Surrey Date: Fri, 21 Aug 2026 11:03:57 +1000 Subject: [PATCH 2/3] fix(test): strengthen header-visibility/cell-formatting assertions Correct the mislabeled cell.inline.styl block: it is a dead store (never read under R/), not a confirmed defect, and the intended fix is deletion not renaming, since renaming would error on the mismatched header row. Also compare full body-row blocks instead of column 3 only, pin the font-size: 2em count, assert the row-header cell lacks stray fill classes, and add positive-render controls to two absence-only blocks. Co-Authored-By: Claude Opus 4.8 (1M context) --- tests/testthat/test-createcustomtable.R | 36 +++++++++++++++---------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-createcustomtable.R b/tests/testthat/test-createcustomtable.R index 11cfc75..d820d84 100644 --- a/tests/testthat/test-createcustomtable.R +++ b/tests/testthat/test-createcustomtable.R @@ -741,6 +741,8 @@ test_that("NULL rownames force-disable row headers even when show.row.headers = res <- CreateCustomTable(m, show.row.headers = TRUE) h <- tableHtml(res) expect_false(grepl("rowheaderdefault", h, fixed = TRUE)) + # positive control: the table still rendered a known body cell + expect_true(grepl(">1", h, fixed = TRUE)) }) test_that("NULL colnames force-disable column headers even when show.col.headers = TRUE", @@ -750,6 +752,8 @@ test_that("NULL colnames force-disable column headers even when show.col.headers res <- CreateCustomTable(m, show.col.headers = TRUE) h <- tableHtml(res) expect_false(grepl("colheaderdefault", h, fixed = TRUE)) + # positive control: the table still rendered a known body cell + expect_true(grepl(">1", h, fixed = TRUE)) }) test_that("cell.align.horizontal reaches text-align and the padding side in the celldefault rule", @@ -791,7 +795,7 @@ test_that("font.unit is honoured in the emitted font-size declaration", { res <- CreateCustomTable(x2, font.size = 2, font.unit = "em") h <- normWs(tableHtml(res)) - expect_true(grepl("font-size: 2em", h, fixed = TRUE)) + expect_equal(countOccurrences("font-size: 2em", h), 15) expect_false(grepl("font-size: 2px", h, fixed = TRUE)) }) @@ -840,6 +844,7 @@ test_that("col.classes applies to a whole data column, indexed against data colu { tds <- regmatches(row, gregexpr('', row))[[1]] # tds[1] is the row-header cell, tds[2:4] are data columns 1:3 + expect_false(grepl("bluefill", tds[1], fixed = TRUE)) expect_false(grepl("bluefill", tds[2], fixed = TRUE)) expect_false(grepl("bluefill", tds[3], fixed = TRUE)) expect_true(grepl("bluefill", tds[4], fixed = TRUE)) @@ -852,11 +857,14 @@ test_that("row.classes applies to a whole data row", h <- tableHtml(res) rows <- regmatches(h, gregexpr(".*?", h))[[1]] bodyRows <- rows[-1] + expect_equal(length(bodyRows), nrow(x2)) row1Tds <- regmatches(bodyRows[1], gregexpr('', bodyRows[1]))[[1]] + expect_false(grepl("redfill", row1Tds[1], fixed = TRUE)) expect_true(all(grepl("redfill", row1Tds[2:4], fixed = TRUE))) row2Tds <- regmatches(bodyRows[2], gregexpr('', bodyRows[2]))[[1]] + expect_false(grepl("redfill", row2Tds[1], fixed = TRUE)) expect_false(any(grepl("redfill", row2Tds[2:4], fixed = TRUE))) }) @@ -887,23 +895,23 @@ test_that("col.classes/row.classes read ix/class positionally, so the element na resNamed <- CreateCustomTable(x2, col.classes = list(list(ix = 3, class = "bluefill"))) resUnnamed <- CreateCustomTable(x2, col.classes = list(list(foo = 3, bar = "bluefill"))) - # the random per-call container name means the documents differ byte-for-byte; - # compare only the column-3 body cells, which is what this scenario is about - extractCol3 <- function(h) regmatches(h, gregexpr('(9|10|11|12)', h))[[1]] - col3Named <- extractCol3(tableHtml(resNamed)) - col3Unnamed <- extractCol3(tableHtml(resUnnamed)) - expect_length(col3Named, nrow(x2)) - expect_identical(col3Named, col3Unnamed) + # the random per-call container name only appears before ; the body markup + # after is stem-free, so comparing the whole body block is strictly stronger + # than comparing just the column-3 cells, at the same cost + bodyNamed <- sub(".*", "", tableHtml(resNamed)) + bodyUnnamed <- sub(".*", "", tableHtml(resUnnamed)) + expect_identical(bodyNamed, bodyUnnamed) }) -test_that("The cell.inline.styl typo means sig.change.fills styling is never prepended for the header row", +test_that("sig.change.fills inline style is emitted only on the flagged body cell, never in ", { # createcustomtable.R assigns 'cell.inline.styl <- rbind("", cell.inline.style)' (missing - # the letter 'e'); this writes to a variable that is never read again, so the header-row - # blank-style prepend it was meant to add to cell.inline.style is silently discarded. This - # is a confirmed defect (separate from this test-writing task) - pinned here as current, - # no-op behaviour: the inline style block is emitted exactly once, on the flagged data cell, - # never on a header cell. + # the letter 'e'). This is a dead store: 'cell.inline.styl' is never read again anywhere + # under R/, so the assignment has no effect on the emitted HTML. Renaming it to the + # apparently-intended 'cell.inline.style' does NOT fix anything - it makes the call error, + # because 'cell.styles' never gains a matching header row while 'cell.html' stays body-only + # (arguments cannot be recycled to the same length). So the correct disposition for the + # line is deletion, not renaming, and the current emitted output below is correct as-is. sig <- matrix(0, nrow(x2), ncol(x2)) sig[1, 1] <- 1 res <- CreateCustomTable(x2, sig.change.fills = sig, show.col.headers = TRUE) From a66067b803cb21bd2a8e7730a483ffadb7f21a5a Mon Sep 17 00:00:00 2001 From: Surrey Date: Fri, 21 Aug 2026 11:49:58 +1000 Subject: [PATCH 3/3] test: tighten header visibility assertions Co-Authored-By: Claude Opus 4.8 (1M context) --- tests/testthat/test-createcustomtable.R | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-createcustomtable.R b/tests/testthat/test-createcustomtable.R index d820d84..d983744 100644 --- a/tests/testthat/test-createcustomtable.R +++ b/tests/testthat/test-createcustomtable.R @@ -671,7 +671,7 @@ test_that("transpose swaps which labels become row vs column headers", # the former row names (r1, r2) now form the column-header row expect_true(grepl('r1r2', - h, fixed = TRUE)) + h, fixed = TRUE)) # the former column names (c1, c2, c3) now form the row-header cells expect_true(grepl('c1', h, fixed = TRUE)) expect_true(grepl('c2', h, fixed = TRUE)) @@ -687,9 +687,8 @@ test_that("transpose changes the cell order to that of the original first column # original column c1 was r1=1, r2=2; after transpose this becomes the first body row rows <- regmatches(h, gregexpr(".*?", h))[[1]] firstBodyRow <- rows[2] # rows[1] is the header row inside - expect_true(grepl(">1", firstBodyRow, fixed = TRUE)) - expect_true(grepl(">2", firstBodyRow, fixed = TRUE)) - expect_false(grepl(">5", firstBodyRow, fixed = TRUE)) + expect_equal(firstBodyRow, + 'c112') }) test_that("show.col.headers = FALSE emits no column-header cell and no colheaderdefault CSS rule", @@ -731,7 +730,8 @@ test_that("show.col.headers and show.row.headers both FALSE emits a bare data gr rows <- regmatches(h, gregexpr(".*?", h))[[1]] firstBodyRow <- rows[1] - expect_equal(countOccurrences("159') }) test_that("NULL rownames force-disable row headers even when show.row.headers = TRUE", @@ -801,7 +801,7 @@ test_that("font.unit is honoured in the emitted font-size declaration", test_that("An explicit cell.font.size overrides font.size for cells only", { - res <- CreateCustomTable(x2, font.size = 13, cell.font.size = 30) + res <- CreateCustomTable(x2, font.size = 17, cell.font.size = 30) h <- normWs(tableHtml(res)) cellRule <- regmatches(h, regexpr('\\.celldefault1\\{[^}]*\\}', h)) @@ -810,7 +810,7 @@ test_that("An explicit cell.font.size overrides font.size for cells only", colHdrRule <- regmatches(h, regexpr('\\.colheaderdefault1\\{[^}]*\\}', h)) expect_length(colHdrRule, 1) - expect_true(grepl("font-size: 13px", colHdrRule, fixed = TRUE)) + expect_true(grepl("font-size: 17px", colHdrRule, fixed = TRUE)) }) test_that("col.header.classes is appended to the generated colheaderdefault class", @@ -875,6 +875,7 @@ test_that("col.classes and row.classes intersect on the shared cell", h <- tableHtml(res) rows <- regmatches(h, gregexpr(".*?", h))[[1]] bodyRows <- rows[-1] + expect_equal(length(bodyRows), nrow(x2)) row1Tds <- regmatches(bodyRows[1], gregexpr('', bodyRows[1]))[[1]] # data column 2 of row 1 carries both classes; columns 1 and 3 of row 1 carry only redfill @@ -901,6 +902,8 @@ test_that("col.classes/row.classes read ix/class positionally, so the element na bodyNamed <- sub(".*", "", tableHtml(resNamed)) bodyUnnamed <- sub(".*", "", tableHtml(resUnnamed)) expect_identical(bodyNamed, bodyUnnamed) + # positive control: col.classes actually took effect in both forms + expect_true(grepl("bluefill", bodyNamed, fixed = TRUE)) }) test_that("sig.change.fills inline style is emitted only on the flagged body cell, never in ", @@ -909,8 +912,8 @@ test_that("sig.change.fills inline style is emitted only on the flagged body cel # the letter 'e'). This is a dead store: 'cell.inline.styl' is never read again anywhere # under R/, so the assignment has no effect on the emitted HTML. Renaming it to the # apparently-intended 'cell.inline.style' does NOT fix anything - it makes the call error, - # because 'cell.styles' never gains a matching header row while 'cell.html' stays body-only - # (arguments cannot be recycled to the same length). So the correct disposition for the + # because 'cell.styles' never gains a matching header row (arguments cannot be recycled + # to the same length). So the correct disposition for the # line is deletion, not renaming, and the current emitted output below is correct as-is. sig <- matrix(0, nrow(x2), ncol(x2)) sig[1, 1] <- 1