RS-21803: Sig Leader Circles test

tests/testthat/test-createcustomtable.R

@@ -1,5 +1,13 @@
 context("CreateCustomTable")
 
+tableHtml <- function(res) res$x$text  # rhtmlMetro::Box stores the emitted HTML in the widget payload's text field
+normWs <- function(s) trimws(gsub("\\s+", " ", s))
+countOccurrences <- function(pattern, s)
+{
+    m <- gregexpr(pattern, s, fixed = TRUE)[[1]]
+    if (m[1] == -1L) 0L else length(m)
+}
+
 xx <- structure(1:5, .Names = c("a", "b", "c", "d", "e"), statistic = "%")
 x2 <- matrix(1:12, 4, 3, dimnames = list(letters[1:4], c("X", "Y", "Z")))
 test_that("Percentage data",
@@ -33,3 +41,119 @@ test_that("Text data is exported correctly",
         "He asked me about the votes…Told him I didn’t know anything about it"),
         dim = c(4L, 1L)))
 })
+
+# sig.leader.circles -----------------------------------------------------
+
+test_that("No sig.leader.circles emits no circle CSS or divs",
+{
+    res <- CreateCustomTable(x2)
+    expect_false(grepl(".circle", tableHtml(res), fixed = TRUE))
+    expect_false(grepl('class="circle', tableHtml(res), fixed = TRUE))
+})
+
+test_that("Base circle classes are emitted when sig.leader.circles is supplied",
+{
+    # circle CSS is value-independent (driven only by non-NULL-ness of sig.leader.circles,
+    # circle.size and sig.fills.*); a plain fixture is used so the codes don't misleadingly
+    # appear to drive the CSS
+    circles <- matrix(0, 4, 3)
+    res <- CreateCustomTable(x2, sig.leader.circles = circles)
+    h <- normWs(tableHtml(res))
+    fmt <- "display: inline-block; line-height:35px; border-radius:35px; height: 35px; width:35px;"
+
+    # the trailing " {" is load-bearing: a bare ".circle2" also matches the filled
+    # variants ".circle21", ".circle20" and ".circle2-1", so without it the
+    # occurrence count would be wrong
+    expect_equal(countOccurrences(".circle2 {", h), 1)
+    expect_true(grepl(paste0(".circle2 { border: 2px solid rgb(120,120,120);", fmt, "}"), h, fixed = TRUE))
+
+    expect_equal(countOccurrences(".circle1 {", h), 1)
+    expect_true(grepl(paste0(".circle1 { border: 1px solid rgb(150,150,150);", fmt, "}"), h, fixed = TRUE))
+
+    expect_equal(countOccurrences(".circle0 {", h), 1)
+    expect_true(grepl(paste0(".circle0 { border: 0px solid rgb(0,0,0);", fmt, "}"), h, fixed = TRUE))
+})
+
+test_that("All nine filled circle variants are emitted with the correct fill colors",
+{
+    # circle CSS is value-independent (see "Base circle classes..." above); a plain fixture
+    # is used so the codes don't misleadingly appear to drive the CSS
+    circles <- matrix(0, 4, 3)
+    up <- "rgb(1,2,3)"
+    nothing <- "rgb(4,5,6)"
+    down <- "rgb(7,8,9)"
+    res <- CreateCustomTable(x2, sig.leader.circles = circles,
+                sig.fills.up = up, sig.fills.nothing = nothing, sig.fills.down = down)
+    h <- normWs(tableHtml(res))
+    variants <- c("circle21", "circle11", "circle01", "circle20", "circle10",
+                  "circle00", "circle2-1", "circle1-1", "circle0-1")
+
+    leader2px <- "2px solid rgb(120,120,120)"
+    tie1px <- "1px solid rgb(150,150,150)"
+    zero0px <- "0px solid rgb(0,0,0)"
+    fmt <- "display: inline-block; line-height:35px; border-radius:35px; height: 35px; width:35px;"
+    colors <- rep(c(up, nothing, down), each = 3)
+    borders <- rep(c(leader2px, tie1px, zero0px), 3)
+
+    for (i in seq_along(variants))
+    {
+        v <- variants[i]
+        # kept consistent with the base-class assertions; the nine variant names do not
+        # collide with each other.
+        expect_equal(countOccurrences(paste0(".", v, " {"), h), 1, info = v)
+        expected <- paste0(".", v, " { border: ", borders[i], "; background-color:",
+                            colors[i], ";", fmt, "}")
+        expect_true(grepl(expected, h, fixed = TRUE), info = v)
+    }
+})
+
+test_that("Every data cell is wrapped in a circle div carrying its own code",
+{
+    x22 <- matrix(1:4, 2, 2, dimnames = list(c("a", "b"), c("X", "Y")))
+    circles <- matrix(c(2, 1, 0, 2), 2, 2)
+    res <- CreateCustomTable(x22, sig.leader.circles = circles)
+    h <- tableHtml(res)
+    expect_equal(countOccurrences('<div class="circle', h), prod(dim(x22)))
+    expect_true(grepl('<div class="circle2">1</div>', h, fixed = TRUE))
+    expect_true(grepl('<div class="circle1">2</div>', h, fixed = TRUE))
+    expect_true(grepl('<div class="circle0">3</div>', h, fixed = TRUE))
+    expect_true(grepl('<div class="circle2">4</div>', h, fixed = TRUE))
+})
+
+test_that("Rendered cell text is preserved inside the circle div wrapping",
+{
+    txt <- "X & Y"
+    x22 <- matrix(c(txt, "b", "c", "d"), 2, 2, dimnames = list(c("a", "b"), c("X", "Y")))
+    circles <- matrix(c(2, 1, 0, 2), 2, 2)
+    res <- CreateCustomTable(x22, sig.leader.circles = circles)
+    h <- tableHtml(res)
+    expect_true(grepl(paste0('<div class="circle2">', txt, '</div>'), h, fixed = TRUE))
+})
+
+test_that("Out-of-range codes pin the current (buggy) normalisation behaviour",
+{
+    # sig.leader.circles[!which(...)] <- 0 negates integer indices rather than
+    # inverting a logical mask, so out-of-range codes are not reset to 0 as documented.
+    # No defect ticket has been filed for this yet; this test pins that behaviour
+    # deliberately, pending a fix.
+    x22 <- matrix(1:4, 2, 2, dimnames = list(c("a", "b"), c("X", "Y")))
+    circles <- matrix(c(5, 1, -3, 2), 2, 2)
+    res <- CreateCustomTable(x22, sig.leader.circles = circles)
+    h <- tableHtml(res)
+    expect_true(grepl('<div class="circle5">1</div>', h, fixed = TRUE))
+    expect_true(grepl('<div class="circle-3">3</div>', h, fixed = TRUE))
+    expect_true(grepl('<div class="circle1">2</div>', h, fixed = TRUE))
+})
+
+test_that("circle.size drives the emitted circle geometry",
+{
+    # circle CSS is value-independent (see "Base circle classes..." above); a plain fixture
+    # is used so the codes don't misleadingly appear to drive the CSS
+    circles <- matrix(0, 4, 3)
+    res <- CreateCustomTable(x2, sig.leader.circles = circles, circle.size = 50)
+    h <- normWs(tableHtml(res))
+    expect_true(grepl(paste0(".circle2 { border: 2px solid rgb(120,120,120);display: inline-block; ",
+                "line-height:50px; border-radius:50px; height: 50px; width:50px;}"), h, fixed = TRUE))
+    expect_false(grepl("line-height:35px", h, fixed = TRUE))
+    expect_false(grepl("border-radius:35px", h, fixed = TRUE))
+})