diff --git a/tests/testthat/test-createcustomtable.R b/tests/testthat/test-createcustomtable.R index d983744..07345e6 100644 --- a/tests/testthat/test-createcustomtable.R +++ b/tests/testthat/test-createcustomtable.R @@ -926,3 +926,186 @@ test_that("sig.change.fills inline style is emitted only on the flagged body cel expect_length(headerBlock, 1) expect_false(grepl("style=", headerBlock, fixed = TRUE)) }) + +# col.widths and custom.css ------------------------------------------------ + +test_that("A single col.widths value emits exactly one tag", +{ + res <- CreateCustomTable(x2, col.widths = '200px') + h <- normWs(tableHtml(res)) + expect_equal(countOccurrences("", h, fixed = TRUE)) +}) + +test_that("A comma-separated col.widths string is split into one tag per width, in order", +{ + res <- CreateCustomTable(x2, col.widths = "20%, 30%, 50%") + h <- normWs(tableHtml(res)) + tags <- regmatches(h, gregexpr("]*>", h))[[1]] + expect_equal(tags, c("", "", "")) +}) + +test_that("A character vector col.widths is accepted equivalently to the comma-separated string", +{ + resString <- CreateCustomTable(x2, col.widths = "20%, 30%, 50%") + resVector <- CreateCustomTable(x2, col.widths = c("20%", "30%", "50%")) + hString <- normWs(tableHtml(resString)) + tagsString <- regmatches(hString, gregexpr("]*>", hString))[[1]] + tagsVector <- regmatches(normWs(tableHtml(resVector)), gregexpr("]*>", normWs(tableHtml(resVector))))[[1]] + expect_equal(tagsVector, c("", "", "")) + expect_equal(tagsString, tagsVector) +}) + +test_that("The col.widths default is the row-header column's 25% width when rownames are present, and nothing when they are not", +{ + resWithRownames <- CreateCustomTable(x2) + hWith <- normWs(tableHtml(resWithRownames)) + tags <- regmatches(hWith, gregexpr("]*>", hWith))[[1]] + expect_equal(tags, "") + + x2NoRownames <- x2 + rownames(x2NoRownames) <- NULL + resNoRownames <- CreateCustomTable(x2NoRownames) + expect_false(grepl("]*>", h)) + expect_length(table, 1) + expect_true(grepl("width:calc(100% - 5px)", table, fixed = TRUE)) +}) + +test_that("col.widths.fill.container = FALSE omits the calc() table width", +{ + # only col.widths.fill.container differs from the TRUE case above + res <- CreateCustomTable(x2, cell.border.width = 5, col.widths.fill.container = FALSE) + h <- normWs(tableHtml(res)) + table <- regmatches(h, regexpr("]*>", h)) + expect_length(table, 1) + expect_false(grepl("width:calc(100% - 5px)", table, fixed = TRUE)) + # positive control: the height-side calc() (which is not gated by this argument) + # remains, so the negative assertion above isn't vacuously true from mangled output + expect_true(grepl("height:calc(100% - 5px)", table, fixed = TRUE)) +}) + +test_that("The existing smoke-tested col.widths call also emits its tag", +{ + expect_error(res <- CreateCustomTable(x2, col.widths = '200px', + col.header.border.width = NULL, border.color = "red"), NA) + h <- normWs(tableHtml(res)) + expect_true(grepl("", h, fixed = TRUE)) +}) + +test_that("Fewer col.widths entries than columns emits only the supplied tags, unpadded", +{ + # 2 widths for a 4-column render (row header + 3 data columns): confirmed current + # behaviour is no padding/redistribution of the remaining columns + res <- CreateCustomTable(x2, col.widths = c("20%", "30%")) + h <- normWs(tableHtml(res)) + tags <- regmatches(h, gregexpr("]*>", h))[[1]] + expect_equal(tags, c("", "")) +}) + +test_that("More col.widths entries than columns emits every supplied tag, untruncated", +{ + # x4 (with rownames) renders 5 columns (row header + W/X/Y/Z), so 7 widths is + # genuinely more than the column count, exercising the surplus path + x4 <- matrix(1:16, 4, 4, dimnames = list(letters[1:4], c("W", "X", "Y", "Z"))) + res <- CreateCustomTable(x4, col.widths = c("20%", "30%", "10%", "10%", "5%", "1%", "2%")) + h <- normWs(tableHtml(res)) + tags <- regmatches(h, gregexpr("]*>", h))[[1]] + expect_equal(tags, c("", "", "", + "", "", "", "")) +}) + +test_that("Custom CSS text reaches the emitted HTML verbatim", +{ + css <- "table { background-color:green }" + res <- CreateCustomTable(x2, custom.css = css) + expect_true(grepl(css, tableHtml(res), fixed = TRUE)) +}) + +test_that("Default custom.css = '' does not emit a distinctive custom.css token, alongside the iframeless host", +{ + res <- CreateCustomTable(x2) + expect_true(attr(res, "can-run-in-root-dom")) + expect_false(grepl("mytesttoken", tableHtml(res), fixed = TRUE)) + + # positive control: the same distinctive token IS present when supplied via custom.css, + # so the negative assertion above isn't vacuous + resWithCss <- CreateCustomTable(x2, custom.css = "table.mytesttoken { color:red }") + expect_true(grepl("mytesttoken", tableHtml(resWithCss), fixed = TRUE)) +}) + +test_that("override.borders suppresses the border declaration only when both 'border' and 'nth-child' occur in custom.css", +{ + # the heuristic (createcustomtable.R) is a plain unanchored substring match on both + # tokens; cell.border.width/color are non-default so the declaration is distinctive + cssBoth <- "table.mycustom { border: 4px solid rgb(9,9,9); } .mycustom:nth-child(2) { color:red; }" + resBoth <- CreateCustomTable(x2, custom.css = cssBoth, cell.border.width = 4, cell.border.color = "red") + hBoth <- normWs(tableHtml(resBoth)) + cellRuleBoth <- regmatches(hBoth, regexpr("\\.celldefault1\\{[^}]*\\}", hBoth)) + expect_length(cellRuleBoth, 1) + expect_false(grepl("border: 4px solid red", cellRuleBoth, fixed = TRUE)) + + # "border-top" alone still counts as containing the literal substring "border", but + # with no "nth-child" anywhere the heuristic does not trip and the border declaration + # is emitted as normal - pinning the literal, unanchored substring match + cssBorderOnly <- "table.mycustom { border-top: 4px solid rgb(9,9,9); }" + resBorderOnly <- CreateCustomTable(x2, custom.css = cssBorderOnly, cell.border.width = 4, cell.border.color = "red") + hBorderOnly <- normWs(tableHtml(resBorderOnly)) + cellRuleBorderOnly <- regmatches(hBorderOnly, regexpr("\\.celldefault1\\{[^}]*\\}", hBorderOnly)) + expect_length(cellRuleBorderOnly, 1) + expect_true(grepl("border: 4px solid red", cellRuleBorderOnly, fixed = TRUE)) + + # "border-top" together with an unrelated selector's "nth-child" DOES trip the + # heuristic (it is a plain unanchored substring match on both tokens anywhere in + # custom.css, not scoped to the same rule) - this is a deliberate opt-out escape + # hatch, not a defect + cssUnanchored <- "table.x { border-top: 1px; } .x:nth-child(2){color:red}" + resUnanchored <- CreateCustomTable(x2, custom.css = cssUnanchored, cell.border.width = 4, cell.border.color = "red") + hUnanchored <- normWs(tableHtml(resUnanchored)) + cellRuleUnanchored <- regmatches(hUnanchored, regexpr("\\.celldefault1\\{[^}]*\\}", hUnanchored)) + expect_length(cellRuleUnanchored, 1) + expect_false(grepl("border: 4px solid red", cellRuleUnanchored, fixed = TRUE)) +}) + +test_that("override.borders also suppresses the border declaration in colheaderdefault and rowheaderdefault", +{ + cssBoth <- "table.mycustom { border: 4px solid rgb(9,9,9); } .mycustom:nth-child(2) { color:red; }" + res <- CreateCustomTable(x2, custom.css = cssBoth, col.header.border.width = 4, col.header.border.color = "red", + row.header.border.width = 4, row.header.border.color = "blue") + h <- normWs(tableHtml(res)) + + colHdrRule <- regmatches(h, regexpr("\\.colheaderdefault1\\{[^}]*\\}", h)) + expect_length(colHdrRule, 1) + expect_false(grepl("border: 4px solid red", colHdrRule, fixed = TRUE)) + + rowHdrRule <- regmatches(h, regexpr("\\.rowheaderdefault1\\{[^}]*\\}", h)) + expect_length(rowHdrRule, 1) + expect_false(grepl("border: 4px solid blue", rowHdrRule, fixed = TRUE)) + + # positive control: the same border arguments DO reach these rules with no custom.css, + # so the negative assertions above are not vacuously true + resNoCss <- CreateCustomTable(x2, col.header.border.width = 4, col.header.border.color = "red", + row.header.border.width = 4, row.header.border.color = "blue") + hNoCss <- normWs(tableHtml(resNoCss)) + colHdrRuleNoCss <- regmatches(hNoCss, regexpr("\\.colheaderdefault1\\{[^}]*\\}", hNoCss)) + expect_true(grepl("border: 4px solid red", colHdrRuleNoCss, fixed = TRUE)) + rowHdrRuleNoCss <- regmatches(hNoCss, regexpr("\\.rowheaderdefault1\\{[^}]*\\}", hNoCss)) + expect_true(grepl("border: 4px solid blue", rowHdrRuleNoCss, fixed = TRUE)) +}) + +test_that("Enabling scroll forces the plain Box host even with no custom.css", +{ + # row.height sets enable.y.scroll, which alone (custom.css still '') switches the + # widget host away from boxIframeless() + res <- CreateCustomTable(x2, row.height = "40px") + expect_equal(attr(res, "can-run-in-root-dom"), NULL) +})