library(testthat)
library(XML)
context("htmlTable - the rgroup argument")
test_that("Check that rgroup has the appropriate padding",
{
mx <- matrix(1:6, ncol=3)
colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)])
rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)])
out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2))
expect_match(out,
"
]*>[^<]*]*>iillRow A")
})
test_that("Check that dimensions are correct with rgroup usage",
{
mx <- matrix(1:6, ncol=3)
colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)])
table_str <-
suppressWarnings(htmlTable(mx,
rgroup=c("test1", "test2"),
n.rgroup=c(1,1)))
parsed_table <- readHTMLTable(as.character(table_str))[[1]]
expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match")
expect_equal(nrow(parsed_table), nrow(mx) + 2, info="Rows did not match")
expect_equal(as.character(parsed_table[1,1]),
"test1", info="The rgroup did not match")
expect_equal(as.character(parsed_table[3,1]),
"test2", info="The rgroup did not match")
expect_equal(as.character(parsed_table[2,1]),
as.character(mx[1,1]), info="The row values did not match")
expect_equal(as.character(parsed_table[4,1]),
as.character(mx[2,1]), info="The row values did not match")
expect_warning(htmlTable(mx,
rgroup=c("test1", "test2", "test3"),
n.rgroup=c(1,1, 0)))
expect_error(suppressWarnings(htmlTable(mx,
roup=c("test1", "test2", "test3"),
rgroup=c(1,1, 10))))
mx[2,1] <- "second row"
table_str <- htmlTable(mx,
rnames=letters[1:2],
rgroup=c("test1", ""),
n.rgroup=c(1,1))
expect_match(table_str, " | ]*>second row",
info="The second row should not have any spacers")
parsed_table <- readHTMLTable(as.character(table_str))[[1]]
expect_equal(nrow(parsed_table), nrow(mx) + 1, info="Rows did not match")
})
test_that("Check rgroup attribute",{
mx <- matrix(1:6, ncol=3)
colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)])
rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)])
rgroup <- paste("rgroup", 1:2)
attr(rgroup, "add") <- "test"
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
attr(rgroup, "add") <- c("test 1", "test 2")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
" | ]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1 | [^<]*]*>test 1")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
" | ]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1 | [^<]*]*>test 1")
attr(rgroup, "add") <- c(`1` = "test c")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
" | ]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1 | [^<]*]*>test c")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2), css.rgroup = ""),
" | ]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1 | [^<]*]*>test c")
attr(rgroup, "add") <- list(`2` = "test d")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
" | ]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 2 | [^<]*]*>test d")
attr(rgroup, "add") <- list(`1` = list(`2` = "test d"))
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
" | ]+colspan[ ]*=[ ]*'2'[^>]+>rgroup 1 | [^<]*]*>test d")
attr(rgroup, "add") <- list(`1` = list(`2` = "test d", `3` = "test e"))
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
" | ]+colspan[ ]*=[ ]*'2'[^>]+>rgroup 1 | [^<]*]*>test d | [^<]*]*>test e")
attr(rgroup, "add") <- list(`1` = list(`44` = "test d"))
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
attr(rgroup, "add") <- list(`1` = list(`asda` = "test d"))
expect_error(suppressWarnings(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))))
attr(rgroup, "add") <- list(`1` = list(`-23` = "test d"))
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
attr(rgroup, "add") <- list(`-1` = list(`3` = "test d"))
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
attr(rgroup, "add") <- list(`23` = list(`3` = "test d"))
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
rgroup[2] <- ""
attr(rgroup, "add") <- list(`2` = "test d")
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
attr(rgroup, "add") <- list("test d")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)),
"test d")
attr(rgroup, "add") <- list("test d", "test e")
expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))
})
test_that("Check rgroup attribute without CSS",{
mx <- matrix(1:6, ncol=3)
colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)])
rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)])
rgroup <- paste("rgroup", 1:2)
attr(rgroup, "add") <- list(`1` = "test d")
expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2), css.rgroup = ""),
" | ]+>rgroup 1 | [^<]*]*>test d | ")
})
test_that("Check rgroup attribute with matrix",{
mx <- matrix(1:6, ncol=2)
colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)])
rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)])
rgroup <- c(paste("rgroup", 1:2), "")
attr(rgroup, "add") <- matrix(c("test a",
"test b"),
ncol = 1)
out <- htmlTable(mx,
rgroup = rgroup,
n.rgroup = c(1, 1),
css.rgroup = "")
expect_match(out,
"]+>rgroup 1 | [^<]*]*>test a | ")
expect_match(out,
"]+>rgroup 2 | [^<]*]*>test b | ")
rgroup <- c(paste("rgroup", 1:2), "")
add_mtrx <- matrix(1:4,
ncol = 2)
attr(rgroup, "add") <- add_mtrx
out <- htmlTable(mx,
rgroup = rgroup,
n.rgroup = c(1, 1),
css.rgroup = "")
expect_match(out,
paste0("]+>rgroup 1 | ",
paste(sprintf("[^<]*]*>%d | ", add_mtrx[1,]),
collapse = ""),
"[^<]*
]+>rgroup 2",
paste(sprintf("[^<]*