htmlTable/0000755000176200001440000000000014647053220012171 5ustar liggesusershtmlTable/tests/0000755000176200001440000000000013701421460013326 5ustar liggesusershtmlTable/tests/testthat/0000755000176200001440000000000014647053220015173 5ustar liggesusershtmlTable/tests/testthat/test-htmlTable_escape_html.R0000644000176200001440000000266013701421460022552 0ustar liggesuserslibrary(testthat) test_that("HTML code is properly escaped", { expect_match( object = htmlTable(data.frame(a = "<3"), rnames = FALSE, escape.html = TRUE ), regexp = "<3" ) df_test <- data.frame( a = c("<3", "<3"), b = c("&2", ">2"), stringsAsFactors = FALSE ) matrix_test <- as.matrix(df_test, ncol = 2 ) getCellContext <- function(tout) { tout %>% str_split("\n") %>% extract2(1) %>% as.list() %>% c(collapse = "_") %>% do.call(paste, .) %>% str_replace(".*(.+).*", "\\1") %>% str_split("% extract2(1) %>% Filter(function(x) grepl("", x), .) %>% str_replace(".*>([^<]+).*", "\\1") } expect_equivalent( htmlTable(df_test, rnames = FALSE, escape.html = TRUE ) %>% getCellContext(), htmlEscape(c(df_test[1,], df_test[2,])) ) expect_equivalent( htmlTable(matrix_test, rnames = FALSE, escape.html = TRUE ) %>% getCellContext(), htmlEscape(c(df_test[1,], df_test[2,])) ) tibble_test <- tibble::as_tibble(df_test) expect_equivalent( htmlTable(tibble_test, rnames = FALSE, escape.html = TRUE ) %>% getCellContext(), htmlEscape(c(df_test[1,], df_test[2,])) ) expect_equal(prEscapeHtml("$")[[1]], "$") }) htmlTable/tests/testthat/test-interactiveTable.R0000644000176200001440000002357514165130172021571 0ustar liggesuserslibrary(testthat) library(XML) context('interactiveTable') # A simple example test_that("With empty rownames(mx) it should skip those", { mx <- matrix(1:6, ncol = 3) table_str <- interactiveTable(mx) expect_false(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) expect_true(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("Empty cell names should be replaced with ''", { mx <- matrix(1:6, ncol = 3) mx[1,1] <- NA table_str <- interactiveTable(mx) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("The variable name should not be in the tables first row if no rownames(mx)", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) expect_false(grepl("[^<]*[^>]+>mx", table_str)) }) test_that("A rowlabel without rownames indicates some kind of error and should throw an error", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(interactiveTable(mx, rowlabel = "not_mx")) }) # Add rownames test_that("The rowname should appear", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- LETTERS[1:NROW(mx)] table_str <- interactiveTable(mx) class(table_str) <- "character" parsed_table <- readHTMLTable(table_str)[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1) expect_match(table_str, "]*>[^>]+>A") expect_match(table_str, "]*>[^>]+>B") }) test_that("Check that basic output are the same as the provided matrix", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) class(table_str) <- "character" parsed_table <- readHTMLTable(table_str)[[1]] expect_equal(ncol(parsed_table), ncol(mx), info = "Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info = "Rows did not match") expect_true(all(mx == parsed_table), info = "Some cells don't match the inputted cells") }) test_that("rnames = FALSE it should skip those", { mx <- matrix(1:6, ncol = 3) rownames(mx) <- c("Row A", "Row B") table_str <- interactiveTable(mx, rnames = FALSE) expect_false(grepl("FALSE", table_str)) expect_false(grepl("Row A", table_str)) }) test_that("Test align functions", { expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol = 10))), 10) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol = 2))), 2) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol = 2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("l", x = matrix(1, ncol = 2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("", x = matrix(1, ncol = 2, nrow = 2), rnames = TRUE)), 3) expect_equivalent(attr(prPrepareAlign("r|rlt|r|", x = matrix(1, ncol = 2, nrow = 2), rnames = TRUE), "n"), 3) expect_equivalent(attr(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "n"), 6) expect_match(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol = 5, nrow = 2), rnames = TRUE), "^r") expect_match(prPrepareAlign("l|r|", x = matrix(1, ncol = 3, nrow = 2), rnames = TRUE), "^l|r|r|$") align_str <- prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol = 5, nrow = 2), rnames = TRUE) expect_true("right" %in% prGetAlign(align_str, 1)) expect_true("right" %in% prGetAlign(align_str, 2)) expect_true("center" %in% prGetAlign(align_str, 3)) expect_true("left" %in% prGetAlign(align_str, 4)) expect_true("left" %in% prGetAlign(align_str, 5)) expect_true("right" %in% prGetAlign(align_str, 6)) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-right" %in% names(prGetAlign(align_str, 4))) expect_true("border-right" %in% names(prGetAlign(align_str, 5))) expect_true("border-right" %in% names(prGetAlign(align_str, 6))) expect_equivalent(length(prGetAlign(align_str, 1)), 2) expect_equivalent(length(prGetAlign(align_str, 2)), 1) expect_equivalent(length(prGetAlign(align_str, 6)), 2) align_str <- prPrepareAlign("|c|rc", x = matrix(1, ncol = 2, nrow = 2), rnames = TRUE) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-left" %in% names(prGetAlign(align_str, 1))) expect_true("center" %in% prGetAlign(align_str, 1)) mx <- matrix(1:6, ncol = 3) rownames(mx) <- c("Row A", "Row B") table_str <- interactiveTable(mx, rname = FALSE) expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- interactiveTable(mx) expect_match(table_str, "text-align: left;[^>]*>Row A") expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- interactiveTable(mx, align = "r") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: right;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") table_str <- interactiveTable(mx, align = "|ll|r|r|") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: left;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") expect_match(table_str, "border-left:[^>]*>Ro") expect_match(table_str, "border-right:[^>]*>1") expect_match(table_str, "border-right:[^>]*>3") expect_match(table_str, "border-right:[^>]*>5") }) test_that("Check color function",{ expect_equivalent(prPrepareColors(c("white", "#444444"), 2), c("#ffffff", "#444444")) expect_equivalent(prPrepareColors(c("white", "#444444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_equivalent(prPrepareColors(c("white", "#444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_null(attr(prPrepareColors(c("white", "#444444"), 3), "groups")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[1]], c("#ffffff", "#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("#444444", "#444444", "#444444")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("none")) expect_equivalent(attr(prPrepareColors(c("white", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("none", "none", "none")) ## Test the merge colors expect_equal(prMergeClr(c("white", "#444444")), colorRampPalette(c("#FFFFFF", "#444444"))(3)[2]) expect_equal(prMergeClr(c("red", "#444444")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#444444", "red")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#FFFFFF")), "#FFFFFF") expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000", "#000000")), prMergeClr(c("#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#FFFFFF")), prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#000000")), prMergeClr(c("#FFFFFF", "#000000", "#FFFFFF"))) }) test_that("Test prAddSemicolon2StrEnd",{ test_str <- "background: white" expect_equal(prAddSemicolon2StrEnd(test_str), paste0(test_str, ";")) test_str <- c("", "", `background-color` = "none") expect_equivalent(prAddSemicolon2StrEnd(test_str), paste0(test_str[3], ";")) expect_equal(names(prAddSemicolon2StrEnd(test_str)), names(test_str[3])) }) test_that("Problem with naming in stringr 1.0.0", { style_bug <- structure(c("", "font-weight: 900;", "#f7f7f7"), .Names = c("", "", "background-color")) expect_false(is.null(names(prAddSemicolon2StrEnd(style_bug)))) expect_match(prGetStyle(style_bug), regexp = "^font-weight: 900; background-color: #f7f7f7") }) test_that("Handling data.frames with factors",{ tmp <- data.frame(a = 1:3, b = factor(x = 1:3, labels = c("Unique_Factor_1", "Factor_2", "Factor_3"))) str <- interactiveTable(tmp) expect_true(grepl("Unique_Factor_1", str)) }) test_that("Check Javascript string",{ js <- prGetScriptString(structure(1:3, javascript = c("a", "B"))) expect_gt(length(strsplit(js, "]*>[^>]+color: red[^>]+>6") table_str <- htmlTable(mx, css.total = "color: red", total=4) expect_match(table_str, "]*>[^>]+color: red[^>]+>4") table_str <- htmlTable(mx, css.total = "color: red", total=c(4, 2)) expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>2") expect_match(table_str, "]*>[^>]+color: red[^>]+>4") table_str <- htmlTable(mx, css.total = "color: red", total=c(4, 2)) expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>2") expect_match(table_str, "]*>[^>]+color: red[^>]+>4") }) test_that("Check tspanner", { mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), css.total = "color: red", total="tspanner") expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>3") expect_match(table_str, "]*>[^>]+color: red[^>]+>6") }) test_that("Check choosing css.style", { mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), css.total = c("color: red", "color: green"), total="tspanner") expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>3") expect_match(table_str, "]*>[^>]+color: green[^>]+>6") }) test_that("The total should be added to the output if used with addmargins", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] total_out <- table(var1, var2) %>% addmargins %>% htmlTable(css.total = "background: purple") expect_match(total_out, "]+background: purple[^>]+>[^>]*Sum", info = "Expect the variable name to appear as a cgroup") expect_match(total_out, "]*>var2", info = "Expect the variable name to appear as a cgroup") }) htmlTable/tests/testthat/test-htmlTable_cgroup.R0000644000176200001440000001062313730316012021561 0ustar liggesuserslibrary(testthat) library(XML) test_that("Check that dimensions are correct with cgroup usage",{ mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx, cgroup = c("a", "b"), n.cgroup=c(1, 2)) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1, info = "Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info="Rows did not match") expect_warning(htmlTable(mx, cgroup=c("a", "b", "c"), n.cgroup=c(1, 2, 0))) expect_error(htmlTable(mx, cgroup=c("a", "b", "c"), n.cgroup=c(1, 2, 10))) table_str <- htmlTable(mx, cgroup=rbind(c("aa", NA), c("a", "b")), n.cgroup=rbind(c(2, NA), c(1, 2))) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1, info="Cols did not match for multilevel cgroup") table_str <- htmlTable(mx, cgroup=rbind(c("aa", "bb"), c("a", "b")), n.cgroup=rbind(c(2, 1), c(1, 2))) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 2, info="Cols did not match for multilevel cgroup") table_str <- htmlTable(mx, cgroup=c("a", "b"), n.cgroup=c(2, 1), tspanner=c("First spanner", "Secon spanner"), n.tspanner=c(1,1)) expect_match(table_str, "td[^>]*colspan='4'[^>]*>First spanner", info="The expected number of columns should be 4") expect_match(table_str, "td[^>]*colspan='4'[^>]*>Secon spanner", info="The expected number of columns should be 4") expect_error(htmlTable(mx, cgroup=c("a", "b"), n.cgroup=c(2, 1), tspanner=c("First spanner", "Secon spanner"), n.tspanner=c(1,2))) mx <- rbind(mx, mx, mx, mx) table_str <- htmlTable(mx, rnames = LETTERS[1:nrow(mx)], cgroup=rbind(c("aa", "bb"), c("a", "b")), n.cgroup=rbind(c(2, 1), c(1, 2)), rgroup=paste(1:4, "rgroup"), n.rgroup=rep(2, 4), tspanner=c("First tspanner", "Second tspanner"), n.tspanner=c(4,4)) expect_match(table_str, "td[^>]*colspan='6'[^>]*>1 rgroup", info="The expected number of columns should be 6") expect_match(table_str, "td[^>]*colspan='6'[^>]*>2 rgroup", info="The expected number of columns should be 6") parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(as.character(parsed_table[1,1]), "First tspanner") expect_equal(as.character(parsed_table[2,1]), "1 rgroup") expect_equal(as.character(parsed_table[8,1]), "Second tspanner") expect_equal(as.character(parsed_table[9,1]), "3 rgroup") }) test_that("Flexible number of cgroups",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(htmlTable(mx, cgroup = c("", "__test__"), n.cgroup = 1:3)) expect_error(htmlTable(mx, cgroup = c("", "__test__", ""), n.cgroup = 1)) out <- htmlTable(mx, cgroup = c("", "__test__"), n.cgroup = 1) expect_match(out, "colspan='2'[^>]*>__test__<") }) test_that("Assume last element for n.cgroup",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) out <- htmlTable(mx, cgroup = "__test__") expect_match(out, "colspan='3'[^>]*>__test__<") }) htmlTable/tests/testthat/structure.tex0000644000176200001440000000532313672220647017766 0ustar liggesusers%latex.default(structure(list(`1` = c("18", "14.6", "20.2", "18.9", "15.5", "20", "22.9", "16.9"), `2` = c("17.1", "14.6", "19.8", "17.7", "15.5", "20", "19.6", "16.8"), `3` = c("15.4", "14.5", "19.4", "16.5", "15.5", "20", "18.5", "16.7"), `4` = c("0.8", "0.1", "0.6", "1.1", NA, NA, "1.5", "0.1"), `5` = c("245", "335", "110", "123", "175", "97", "109", "113"), `6` = c("194.2", "299.5", "107.5", "116.5", "175", "97", "76", "102"), `7` = c("150", "264", "105", "110", "175", "97", "52", "91"), `8` = c("33.4", "50.2", "3.5", "7.5", NA, NA, "20.1", "15.6"), `9` = c("19.2", "15.8", "21.4", "21", "19.7", "21.5", "33.9", "30.4"), `10` = c("15.1", "15.4", "19.8", "19.8", "19.7", "21.5", "26.9", "28.2"), `11` = c("10.4", "15", "18.1", "17.8", "19.7", "21.5", "21.4", "26"), `12` = c("2.8", "0.6", "2.3", "1.6", NA, NA, "4.8", "3.1")), row.names = c(NA, -8L), class = c("tbl_df", "tbl", "data.frame")), rnames = c("3 Gears", "5 Gears", "3 Gears", "4 Gears", "5 Gears", "3 Gears", "4 Gears", "5 Gears"), header = c("Max", "Mean", "Min", "SD", "Max", "Mean", "Min", "SD", "Max", "Mean", "Min", "SD"), label = "test_table", rowlabel = "row", rgroup = c("8 Cylinders", "6 Cylinders", "4 Cylinders"), n.rgroup = c(2L, 3L, 3L), cgroup = c("qsec", "hp", "mpg"), n.cgroup = c(4L, 4L, 4L))% \begin{table}[!tbp] \begin{center} \begin{tabular}{lllllcllllcllll} \hline\hline \multicolumn{1}{l}{\bfseries row}&\multicolumn{4}{c}{\bfseries qsec}&\multicolumn{1}{c}{\bfseries }&\multicolumn{4}{c}{\bfseries hp}&\multicolumn{1}{c}{\bfseries }&\multicolumn{4}{c}{\bfseries mpg}\tabularnewline \cline{2-5} \cline{7-10} \cline{12-15} \multicolumn{1}{l}{}&\multicolumn{1}{c}{1}&\multicolumn{1}{c}{2}&\multicolumn{1}{c}{3}&\multicolumn{1}{c}{4}&\multicolumn{1}{c}{}&\multicolumn{1}{c}{5}&\multicolumn{1}{c}{6}&\multicolumn{1}{c}{7}&\multicolumn{1}{c}{8}&\multicolumn{1}{c}{}&\multicolumn{1}{c}{9}&\multicolumn{1}{c}{10}&\multicolumn{1}{c}{11}&\multicolumn{1}{c}{12}\tabularnewline \hline {\bfseries 8 Cylinders}&&&&&&&&&&&&&&\tabularnewline ~~1&18&17.1&15.4&0.8&&245&194.2&150&33.4&&19.2&15.1&10.4&2.8\tabularnewline ~~2&14.6&14.6&14.5&0.1&&335&299.5&264&50.2&&15.8&15.4&15&0.6\tabularnewline \hline {\bfseries 6 Cylinders}&&&&&&&&&&&&&&\tabularnewline ~~3&20.2&19.8&19.4&0.6&&110&107.5&105&3.5&&21.4&19.8&18.1&2.3\tabularnewline ~~4&18.9&17.7&16.5&1.1&&123&116.5&110&7.5&&21&19.8&17.8&1.6\tabularnewline ~~5&15.5&15.5&15.5&&&175&175&175&&&19.7&19.7&19.7&\tabularnewline \hline {\bfseries 4 Cylinders}&&&&&&&&&&&&&&\tabularnewline ~~6&20&20&20&&&97&97&97&&&21.5&21.5&21.5&\tabularnewline ~~7&22.9&19.6&18.5&1.5&&109&76&52&20.1&&33.9&26.9&21.4&4.8\tabularnewline ~~8&16.9&16.8&16.7&0.1&&113&102&91&15.6&&30.4&28.2&26&3.1\tabularnewline \hline \end{tabular}\end{center} \end{table} htmlTable/tests/testthat/test-htmlTable.R0000644000176200001440000002722214165130172020211 0ustar liggesuserslibrary(testthat) library(XML) library(tibble) library(magrittr) context("htmlTable") # A simple example test_that("With empty rownames(mx) it should skip those", { mx <- matrix(1:6, ncol = 3) table_str <- htmlTable(mx) expect_false(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) expect_true(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("Empty cell names should be replaced with ''", { mx <- matrix(1:6, ncol = 3) mx[1, 1] <- NA table_str <- htmlTable(mx) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("The variable name should not be in the tables first row if no rownames(mx)", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) expect_false(grepl("[^<]*[^>]+>mx", table_str)) }) test_that("A rowlabel without rownames indicates some kind of error and should throw an error", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(htmlTable(mx, rowlabel = "not_mx")) }) # Add rownames test_that("The rowname should appear", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- LETTERS[1:NROW(mx)] table_str <- htmlTable(mx) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1) expect_match(table_str, "]*>[^>]+>A") expect_match(table_str, "]*>[^>]+>B") }) test_that("Check that basic output are the same as the provided matrix", { mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) 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), info = "Rows did not match") expect_true(all(mx == parsed_table), info = "Some cells don't match the inputted cells" ) }) test_that("rnames = FALSE it should skip those", { mx <- matrix(1:6, ncol = 3) rownames(mx) <- c("Row A", "Row B") table_str <- htmlTable(mx, rnames = FALSE) expect_false(grepl("FALSE", table_str)) expect_false(grepl("Row A", table_str)) }) test_that("Test align functions", { expect_equivalent( nchar(prPrepareAlign("lr", x = matrix(1, ncol = 10))), 10 ) expect_equivalent( nchar(prPrepareAlign("lr", x = matrix(1, ncol = 2))), 2 ) expect_equivalent( nchar(prPrepareAlign("lr", x = matrix(1, ncol = 2), rnames = TRUE)), 3 ) expect_equivalent( nchar(prPrepareAlign("l", x = matrix(1, ncol = 2), rnames = TRUE)), 3 ) expect_equivalent( nchar(prPrepareAlign("", x = matrix(1, ncol = 2, nrow = 2), rnames = TRUE)), 3 ) expect_equivalent( attr(prPrepareAlign("r|rlt|r|", x = matrix(1, ncol = 2, nrow = 2), rnames = TRUE), "n"), 3 ) expect_equivalent( attr(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol = 5, nrow = 2), rnames = TRUE), "n"), 6 ) expect_match( prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol = 5, nrow = 2), rnames = TRUE), "^r" ) expect_match( prPrepareAlign("l|r|", x = matrix(1, ncol = 3, nrow = 2), rnames = TRUE), "^l|r|r|$" ) align_str <- prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol = 5, nrow = 2), rnames = TRUE) expect_true("right" %in% prGetAlign(align_str, 1)) expect_true("right" %in% prGetAlign(align_str, 2)) expect_true("center" %in% prGetAlign(align_str, 3)) expect_true("left" %in% prGetAlign(align_str, 4)) expect_true("left" %in% prGetAlign(align_str, 5)) expect_true("right" %in% prGetAlign(align_str, 6)) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-right" %in% names(prGetAlign(align_str, 4))) expect_true("border-right" %in% names(prGetAlign(align_str, 5))) expect_true("border-right" %in% names(prGetAlign(align_str, 6))) expect_equivalent(length(prGetAlign(align_str, 1)), 2) expect_equivalent(length(prGetAlign(align_str, 2)), 1) expect_equivalent(length(prGetAlign(align_str, 6)), 2) align_str <- prPrepareAlign("|c|rc", x = matrix(1, ncol = 2, nrow = 2), rnames = TRUE) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-left" %in% names(prGetAlign(align_str, 1))) expect_true("center" %in% prGetAlign(align_str, 1)) mx <- matrix(1:6, ncol = 3) rownames(mx) <- c("Row A", "Row B") table_str <- htmlTable(mx, rname = FALSE) expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- htmlTable(mx) expect_match(table_str, "text-align: left;[^>]*>Row A") expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- htmlTable(mx, align = "r") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: right;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") table_str <- htmlTable(mx, align = "|ll|r|r|") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: left;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") expect_match(table_str, "border-left:[^>]*>Ro") expect_match(table_str, "border-right:[^>]*>1") expect_match(table_str, "border-right:[^>]*>3") expect_match(table_str, "border-right:[^>]*>5") }) test_that("Check color function", { expect_equivalent( prPrepareColors(c("white", "#444444"), 2), c("#ffffff", "#444444") ) expect_equivalent( prPrepareColors(c("white", "#444444"), 3), c("#ffffff", "#444444", "#ffffff") ) expect_equivalent( prPrepareColors(c("white", "#444"), 3), c("#ffffff", "#444444", "#ffffff") ) expect_null(attr(prPrepareColors(c("white", "#444444"), 3), "groups")) expect_equivalent( attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c") ), "groups")[[1]], c("#ffffff", "#ffffff") ) expect_equivalent( attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c") ), "groups")[[2]], c("#444444", "#444444", "#444444") ) expect_equivalent( attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c") ), "groups")[[3]], c("#ffffff") ) expect_equivalent( attr(prPrepareColors(c("white", "#444444", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c") ), "groups")[[3]], c("none") ) expect_equivalent( attr(prPrepareColors(c("white", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c") ), "groups")[[2]], c("none", "none", "none") ) ## Test the merge colors expect_equal( prMergeClr(c("white", "#444444")), colorRampPalette(c("#FFFFFF", "#444444"))(3)[2] ) expect_equal( prMergeClr(c("red", "#444444")), colorRampPalette(c("red", "#444444"))(3)[2] ) expect_equal( prMergeClr(c("#444444", "red")), colorRampPalette(c("red", "#444444"))(3)[2] ) expect_equal( prMergeClr(c("#FFFFFF", "#FFFFFF", "#FFFFFF")), "#FFFFFF" ) expect_equal( prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000", "#000000")), prMergeClr(c("#FFFFFF", "#000000")) ) expect_equal( prMergeClr(c("#000000", "#FFFFFF", "#FFFFFF")), prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000")) ) expect_equal( prMergeClr(c("#000000", "#FFFFFF", "#000000")), prMergeClr(c("#FFFFFF", "#000000", "#FFFFFF")) ) }) test_that("Test prAddSemicolon2StrEnd", { test_str <- "background: white" expect_equal( prAddSemicolon2StrEnd(test_str), paste0(test_str, ";") ) test_str <- c("", "", `background-color` = "none") expect_equivalent( prAddSemicolon2StrEnd(test_str), paste0(test_str[3], ";") ) expect_equal( names(prAddSemicolon2StrEnd(test_str)), names(test_str[3]) ) }) test_that("Problem with naming in stringr 1.0.0", { style_bug <- structure(c("", "font-weight: 900;", "#f7f7f7"), .Names = c("", "", "background-color") ) expect_false(is.null(names(prAddSemicolon2StrEnd(style_bug)))) expect_match(prGetStyle(style_bug), regexp = "^font-weight: 900; background-color: #f7f7f7" ) }) test_that("Handling data.frames with factors", { tmp <- data.frame( a = 1:3, b = factor( x = 1:3, labels = c( "Unique_Factor_1", "Factor_2", "Factor_3" ) ) ) str <- htmlTable(tmp) expect_true(grepl("Unique_Factor_1", str)) tmp <- data.frame( a = 1.23, b = factor( x = 1, labels = c("1.2") ) ) %>% txtRound() expect_true(tmp$a == "1", tmp$b == "1.2") }) context("htmlTable - empty table") test_that("has header elements", { empty_dataframe <- data.frame( a = numeric(), b = factor(levels = c( "level one", "level two" )) ) expect_warning({ table_str <- htmlTable(empty_dataframe) }) th_cell_regex <- function(content) str_interp("[^<]*]*>${CONTENT}", list(CONTENT = content)) expect_match(table_str, str_interp("[^<]*${CELL1}${CELL2}[^<]*", list(CELL1 = th_cell_regex("a"), CELL2 = th_cell_regex("b")))) expect_match(table_str, "[^<]+") expect_warning({ table_str <- htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c( "white", "gray" ), caption = "This is a caption", tfoot = "This is a footnote" ) }) expect_match(table_str, str_interp("${CELL_LABEL}${CELL1}${CELL2}[^<]*", list(CELL_LABEL = th_cell_regex("Row number"), CELL1 = th_cell_regex("a"), CELL2 = th_cell_regex("b")))) expect_match(table_str, "[^<]+") expect_match(table_str, "]+>\\s*This is a footnote", perl = TRUE) expect_match(table_str, "]+>\\s*This is a caption", perl = TRUE) }) test_that("An empty dataframe returns an empty table with a warning", { empty_dataframe <- data.frame( a = numeric(), b = factor(levels = c( "level one", "level two" )) ) expect_warning(htmlTable(empty_dataframe), regexp = "empty_dataframe") empty_matrix <- empty_dataframe %>% as.matrix() expect_warning(htmlTable(empty_matrix), regexp = "empty_matrix") expect_warning(htmlTable(empty_dataframe)) expect_warning(htmlTable(empty_dataframe, cgroup = "Spanner", n.cgroup = 2 )) expect_warning(htmlTable(empty_dataframe, cgroup = "Spanner", n.cgroup = 2, caption = "Caption", tfoot = "Footnote" )) expect_warning(htmlTable(empty_dataframe, col.rgroup = c( "white", "gray" ) )) expect_warning(htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c( "white", "gray" ) )) expect_warning(htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c( "white", "gray" ), caption = "This is a caption", tfoot = "This is a footnote" )) }) htmlTable/tests/testthat/test-htmlTable_dates.R0000644000176200001440000000604114646650173021401 0ustar liggesusersrequire(testthat) require(lubridate, quietly = TRUE, warn.conflicts = FALSE) require(htmlTable, quietly = TRUE, warn.conflicts = FALSE) require(chron, quietly = TRUE, warn.conflicts = FALSE) context('dates within htmlTable') # A simple example test_that("should be converted into strings (if fails check availability of chron package)", { skip_if_not_installed("lubridate") skip_if_not_installed("chron") # Below example is created using lemna's example: # library(lubridate) # library(chron) # df_dates <- data.frame(ID = 1:3, # contact_Date = c(today(), # today() - 1, # today() - 2)) # # df_dates$contact_posix <- strptime(as.POSIXct(df_dates$contact_Date), # format = "%Y-%m-%d") # df_dates$contact_chron <- chron(as.character(df_dates$contact_Date), # format = "Y-m-d", # out.format = "Y-m-d") df_dates <- structure(list(contact_Date = structure(c(17092, 17091, 17090), class = "Date"), contact_posix = structure(list(sec = c(0, 0, 0), min = c(0L, 0L, 0L), hour = c(0L, 0L, 0L), mday = c(18L, 17L, 16L), mon = c(9L, 9L, 9L), year = c(116L, 116L, 116L), wday = c(2L, 1L, 0L), yday = c(291L, 290L, 289L), isdst = c(1L, 1L, 1L), zone = c("CEST", "CEST", "CEST"), gmtoff = c(NA_integer_, NA_integer_, NA_integer_)), .Names = c("sec", "min", "hour", "mday", "mon", "year", "wday", "yday", "isdst", "zone", "gmtoff"), class = c("POSIXlt", "POSIXt")), contact_chron = structure(c(17092, 17091, 17090), format = "Y-m-d", origin = structure(c(1, 1, 1970), .Names = c("month", "day", "year")), class = c("dates", "times"))), .Names = c("contact_Date", "contact_posix", "contact_chron"), row.names = c(NA, -3L), class = "data.frame") table_str <- htmlTable(df_dates, rnames = FALSE) expect_match(table_str, "[^<]+]+>2016-10-16[^<]+]+>2016-10-16[^<]+]+>(20|)16-10-16") }) htmlTable/tests/testthat/htmlTable_addHtmlTableStyle.R0000644000176200001440000000217613730316012022657 0ustar liggesuserslibrary(testthat) library(XML) test_that("Standard addHtmlTableStyle",{ mx <- matrix(1:6, ncol = 3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_true(mx %>% addHtmlTableStyle(align = "r|r") %>% hasHtmlTableStyle("align")) style <- mx %>% addHtmlTableStyle(align = "r|r", # Check partial match.arg for "bottom" pos.caption = "bot") %>% getHtmlTableStyle() expect_list(style) expect_equal(style$align, "r|r") expect_equal(style$pos.caption, "bottom") expect_error(mx %>% addHtmlTableStyle(pos.caption = "invalid option"), regexp = "pos.caption") }) test_that("Wrap addHtmlTable should work", { firstWrapper <- function(x, css = c("large", "small")) { css.table <- match.arg(css) addHtmlTableStyle(x, css.table = css.table) } v <- firstWrapper(x = mtcars, css = "large") expect_equal(getHtmlTableStyle(v)$css.table, "large") secondWrapper <- function(x) { value <- "small" firstWrapper(x, css = value) } v <- secondWrapper(x = mtcars) expect_equal(getHtmlTableStyle(v)$css.table, "small") }) htmlTable/tests/testthat/test-htmlTable-dimnames.R0000644000176200001440000000502613407215301021776 0ustar liggesuserslibrary(testthat) context("htmlTable - dimnames") test_that("First dimname should be converted to rgroup, tspanner or rowlabel", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] basic_label <- table(var1, var2) %>% htmlTable(css.rgroup = "background: blue") expect_match(basic_label, "]+background: blue[^>]+>var1", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  A", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  B", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  C", info = "Expect the variable name to appear as an rgroup") tspanner_label <- table(var1, var2) %>% htmlTable(rgroup=c("alt"), n.rgroup=c(3), css.tspanner = "background: red", css.rgroup = "background: blue") expect_match(tspanner_label, "]+background: red[^>]+>var1", info = "Expect the variable name to appear as an tspanner") expect_match(tspanner_label, "]+background: blue[^>]+>alt", info = "Expect the rgroup name to appear as usual") expect_match(tspanner_label, "]+>  A") expect_match(tspanner_label, "]+>  B") expect_match(tspanner_label, "]+>  C") rowlabel_label <- table(var1, var2) %>% htmlTable(rgroup=c("alt"), n.rgroup=c(3), tspanner=c("alt2"), n.tspanner = c(3), css.tspanner = "background: red", css.rgroup = "background: blue") expect_match(rowlabel_label, "]+background: red[^>]+>alt2", info = "Expect the variable name to appear as an tspanner") expect_match(rowlabel_label, "]+background: blue[^>]+>alt", info = "Expect the rgroup name to appear as usual") expect_match(rowlabel_label, "]+>  A") expect_match(rowlabel_label, "]+>  B") expect_match(rowlabel_label, "]+>  C") }) test_that("Second dimname should be converted to cgroup", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] basic_label <- table(var1, var2) %>% htmlTable expect_match(basic_label, "]+>var2", info = "Expect the variable name to appear as a cgroup") }) htmlTable/tests/testthat/test-htmlTable_styles.R0000644000176200001440000000563213701421460021613 0ustar liggesuserslibrary(testthat) library(XML) context("htmlTable - styles check") test_that("Check that row styles are present",{ mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } css.cell = rep("font-size: 1em", times = ncol(mx) + 1) css.cell[1] = "font-size: 2em" out <- htmlTable(mx, css.cell=css.cell, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) for (n in rownames(mx)) { expect_match(out, sprintf("\n[^<]*]+>%s", n)) } for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ expect_match(out, sprintf("\n[^<]*]+>%s", mx[nr, nc]) ) } } }) test_that("Check prPrepareCss",{ mx <- matrix(1:5, ncol = 5, nrow = 1) rownames(mx) <- "1st" colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:ncol(mx), "th")), "hdr") css.cell = rep("font-size: 1em", times = ncol(mx) + 1) css.cell[1] = "font-size: 2em" out <- prPrepareCss(mx, css = css.cell, header = names(mx), rnames = rownames(mx)) expect_equal(dim(out), dim(mx)) css.cell = matrix("padding-left: .5em;", nrow = nrow(mx) + 1, ncol = ncol(mx)) out <- prPrepareCss(mx, css = css.cell, header = colnames(mx), rnames = rownames(mx)) expect_equal(dim(out), dim(mx)) }) test_that("Test prGetStyle merge funciton", { styles <- c(background = "black", border ="1px solid grey") expect_equivalent(length(prGetStyle(styles)), 1) expect_match(prGetStyle(styles), "background: black;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles, a=2), "border: [^;]+grey;") expect_error(prGetStyle(styles, "invalid style")) expect_error(prGetStyle(styles, "invalid style:")) expect_error(prGetStyle(styles, ":invalid style")) expect_match(prGetStyle(styles, "valid: style"), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style")), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style", valid1= "style")), "valid: style; valid1: style;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2")), "valid: style2;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2"), "valid: style3"), "valid: style3;") }) test_that("Later style has precedence", { styles <- c(background = "black", border ="1px solid grey") expect_match(prGetStyle(border = "2px solid red", styles), styles["border"]) expect_match(prGetStyle(styles, border = "2px solid red"), "2px solid red") }) htmlTable/tests/testthat/test-txtFrmt.R0000644000176200001440000002026414646647673017773 0ustar liggesuserslibrary(testthat) context('txtInt') test_that("Add zero", { expect_equal(txtInt(5), "5") expect_equal(txtInt(106), "106") expect_equal(txtInt(1006), "1,006") expect_equal(txtInt(c(5, 106, 10006)), c("5", "106", "10,006")) expect_equal(txtInt(1000, language = "se", html = TRUE), "1000") expect_equal(txtInt(10000, language = "se", html = TRUE), "10 000") expect_equal(txtInt(10000, language = "se", html = FALSE), "10 000") mtrx <- matrix(seq(from = 10, to = 10000, length.out = 3*6), ncol = 3, nrow = 6) mtrx <- round(mtrx) int_mtrx <- txtInt(mtrx) expect_equal(dim(mtrx), dim(int_mtrx)) expect_equal(int_mtrx[3,1], txtInt(mtrx[3,1])) expect_equal(txtInt(NA), "") }) test_that("Throw nsmall warning", { expect_warning(txtInt(.5), regexp = "The function can only be served integers") expect_silent(txtInt(.5, nsmall = 1)) expect_warning(txtInt(c(.5, .5)), regexp = "The function can only be served integers") expect_silent(txtInt(c(.5, .5), nsmall = 2)) }) context('txtPval') test_that("Add zero", { expect_equal(txtPval(.5, lim.2dec = 10^-1), "0.50") expect_equal(txtPval(.06, lim.2dec = 10^-1), "0.06") expect_equal(txtPval(.06, lim.2dec = 10^-2), "0.060") expect_equal(txtPval(.06451, lim.2dec = 10^-3), "0.065") expect_equal(txtPval(.00006451, lim.sig = 10^-3), "< 0.001") expect_warning(txtPval("a", lim.sig = 10^-3)) }) context('txtRound') test_that("Numerical matrices",{ test_mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow = TRUE) expect_equivalent(txtRound(test_mx, 1), t(apply(test_mx, 1, function(x) sprintf("%.1f", x)))) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,1], sprintf("%.1f", test_mx[2,1])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[1,1], sprintf("%.1f", test_mx[1,1])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,3], sprintf("%.1f", test_mx[2,3])) rownames(test_mx) <- letters[1:nrow(test_mx)] colnames(test_mx) <- LETTERS[1:ncol(test_mx)] expect_equivalent(txtRound(test_mx, 1, excl.cols = "A")[3,"A"], as.character(test_mx[3,"A"])) expect_equivalent(txtRound(test_mx, 1, excl.cols = "A")[3,"C"], sprintf("%.1f", test_mx[3,"C"])) expect_equivalent(txtRound(test_mx, 1, excl.rows = "a")["a", 3], as.character(test_mx["a", 3])) expect_equivalent(txtRound(test_mx, 1, excl.rows = "a")["c", 3], sprintf("%.1f", test_mx["c", 3])) expect_equivalent(txtRound(matrix(c(NA, 2.22), ncol = 1), 1)[1,1], "") expect_equivalent(txtRound(matrix(c(NA, 2.22), ncol = 1), 1, txt.NA = "missing")[1,1], "missing") expect_error(txtRound(test_mx, digits = c(2, 3, 4, 5))) expect_error(txtRound(test_mx, digits = c(2, 3))) }) test_that("Character matrices",{ test_mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow = TRUE) ch_test_mx <- cbind(test_mx, "a") expect_equivalent(txtRound(ch_test_mx, 1)[,1:ncol(test_mx)], t(apply(test_mx, 1, function(x) sprintf("%.1f", x)))) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,1], sprintf("%.1f", test_mx[2,1])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[1,1], sprintf("%.1f", test_mx[1,1])) }) test_that("Supplying a data.frame",{ skip_if_not_installed("tidyselect") test_df <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow = TRUE) %>% as.data.frame() test_df$text = LETTERS[1:nrow(test_df)] expect_equal(dim(txtRound(test_df, digits = 1)), dim(test_df)) expect_equivalent(as.matrix(txtRound(test_df, digits = 1)[,1:3]), t(apply(test_df[,1:3], 1, function(x) sprintf("%.1f", x)))) expect_equal(txtRound(test_df, digits = 1)$text, test_df$text) }) test_that("Supplying a table",{ out <- txtRound(table(1:4, 4:1)) expect_equal(nrow(out), 4) expect_equal(ncol(out), 4) }) test_that("Supplying a vector for the digits",{ w <- matrix((1:8)/7, ncol = 4) w_out <- txtRound(w, digits = 1:4) for (digits in 1:4) expect_equivalent(w_out[,digits], sprintf(paste0("%.", digits, "f"), w[,digits]), paste("Expected the number of digits to be", digits)) }) test_that("The txtRound should accept without warning a vector",{ w <- c(.1, .2, .7) expect_silent(w_out <- txtRound(w)) expect_equivalent(w_out, c("0", "0", "1")) w_out <- txtRound(w, digits = 0:2) expect_equivalent(w_out, c("0", "0.2", "0.70")) expect_error(txtRound(w, digits = 0:20)) }) test_that("The txtRound should apply a txtInt to the integer section when activated", { expect_error(txtRound(123333.123, digits = 1, txtInt_args = 1)) expect_equal(txtRound(123333.123, digits = 1, txtInt_args = list()), "123,333.1") expect_equal(txtRound(123333, digits = 0, txtInt_args = list()), "123,333") expect_equal(txtRound(123333, digits = 0, txtInt_args = list()), "123,333") expect_equal(txtRound(123333, digits = 0, txtInt_args = list(language = "sv", html = FALSE)), "123 333") expect_equal(txtRound(c(1, 1e4, 2e5), digits = 0, txtInt_args = list(language = "sv", html = FALSE)), c("1", "10 000", "200 000")) }) test_that("Numbers that round to 0 should not have -, i.e. no -0.0",{ expect_equal(txtRound(matrix(-.01), digits = 1), matrix("0.0")) expect_equal(txtRound(matrix("-.01"), digits = 0), matrix("0")) }) test_that("Character vectors work", { test_str <- c("AA 2 2A", "-1.2 aaa", "-1", "2.8888") correct_str <- c("2.0", "-1.2", "-1.0", "2.9") for (i in 1:length(test_str)) { expect_equivalent(txtRound(test_str[i], digits = 1), correct_str[i], info = paste("Test case", i)) } }) test_that("Keep minimila digits", { expect_equal(txtRound(c(0.1, 0.01, 0.001), digits = 2), c("0.10", "0.01","0.00")) expect_equal(txtRound(c(0.1, 0.01, 0.0018, 0.0012, 0.00012), digits = 2, digits.nonzero = 3), c("0.10", "0.01","0.002","0.001","0.00")) expect_equal(txtRound(c(10.1, 0.1, 0.0012, 0.0012), digits = c(0, 2, 2, 2), digits.nonzero = c(1,2,2,3)), c("10", "0.10", "0.00", "0.001")) }) test_that("Peter's issues raised in #34", { expect_silent(txtRound(c(1, 2, 3, 4))) expect_silent(txtRound(c(1, 2, 3, NA))) expect_silent(txtRound(c(NA, NA, NA, NA))) }) test_that("Negative numbers - issue #76", { expect_equal(txtRound(-1.1111, digits = 2), "-1.11") expect_equal(txtRound(-0.000000011, digits = 2, digits.nonzero = 4), "0.00") expect_equal(txtRound(-0.00011, digits = 2, digits.nonzero = 4), "-0.0001") }) test_that("Scientific notation",{ expect_equal(txtRound("1.1234", 1), "1.1") expect_equal(txtRound("1.1234e1", 1), "1.12e+01") expect_equal(txtRound("1.1234e+01", 1), "1.12e+01") expect_equal(txtRound("1.1234321e2", 2), "1.1234e+02") # Doesn't work due to depares(substitute()) limitations # expect_equal(txtRound(1.1234321e2, 2), "1.1234e+02") expect_equal(txtRound(1.1234321e2, 2, scientific = TRUE), "1.1234e+02") expect_equal(txtRound("1.1234321e2", 2, scientific = FALSE), "112.34") }) htmlTable/tests/testthat/test-htmlTable_rgroup_tspanner.R0000644000176200001440000002140213407215301023507 0ustar liggesuserslibrary(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, "]*>]*>rgroup 1") expect_match(out, "]*>[^<]*]*>  Row A") expect_match(out, "]*>]*>rgroup 2") expect_match(out, "]*>[^<]*]*>  Row B") out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2), padding.rgroup = "ll") expect_match(out, "]*>]*>rgroup 1") expect_match(out, "]*>[^<]*]*>llRow A") out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2), tspanner = paste("tspanner", 1:2), n.tspanner = rep(1, 2), padding.tspanner = "ii", padding.rgroup = "ll") expect_match(out, "]*>]*>iirgroup 1") 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("[^<]*]*>%d", add_mtrx[2,]), collapse = ""), "[^<]*]+>rgroup 2", paste(sprintf("[^<]*]*>%d", add_mtrx[1,]), collapse = ""), "[^<]*]+>rgroup 1", "[^<]*% mutate_at(vars(starts_with("cgroup")), ~glue("{name} cg", name = .)) %>% mutate(rgroup = glue("{name}_rg", name = rgroup), header = glue("{name}_h", name = header)) table_str <- mx %>% tidyHtmlTable(header = header, rowlabel = 'row', label = "test_table") parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] expect_equal(ncol(parsed_table), 4) expect_equal(nrow(parsed_table), length(mx$value)) expect_equal(parsed_table %>% filter(row == 3) %>% pluck("2_h") %>% as.character(), mx %>% filter(name == 3) %>% pluck("value") %>% as.character()) expect_equal(parsed_table %>% filter(row == 4) %>% pluck("3_h") %>% as.character(), mx %>% filter(name == 4) %>% pluck("value") %>% as.character()) expect_equal(parsed_table %>% filter(row == 5) %>% pluck("4_h") %>% as.character(), mx %>% filter(name == 5) %>% pluck("value") %>% as.character()) table_str <- mx %>% tidyHtmlTable(header = header, rgroup = rgroup, label = "test_table") parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] expect_equal(ncol(parsed_table), 4) expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique)) table_str <- mx %>% tidyHtmlTable(header = header, rgroup = rgroup, hidden_rgroup = "1_rg", label = "test_table") parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] expect_equal(ncol(parsed_table), 4) expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique) - 1) expect_match(table_str, "2_rg") expect_false(grepl("1_rg", table_str)) table_str <- mx %>% tidyHtmlTable(header = header, tspanner = rgroup, hidden_tspanner = "1_rg", label = "test_table") expect_match(table_str, "2_rg") expect_false(grepl("1_rg", table_str)) table_str <- mx %>% tidyHtmlTable(header = header, rgroup = rgroup, cgroup = cgroup1, label = "test_table") parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] expect_equal(colnames(parsed_table) %>% keep(~grepl("[0-9]", .)) %>% length, unique(mx$header) %>% length) expect_equal(ncol(parsed_table), 5) expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique)) table_str <- mx %>% tidyHtmlTable(header = header, rgroup = rgroup, cgroup = starts_with("cgroup"), label = "test_table") parsed_table <- readHTMLTable(as.character(table_str))[["test_table"]] expect_equal(colnames(parsed_table) %>% keep(~grepl("[0-9]", .)) %>% length, unique(mx$header) %>% length) # Each cgroup generates a empty cell in-between which is how we detect the # cgroup as it adds these for layout purpose expect_equal(ncol(parsed_table), 3 + 1 + 2) expect_equal(nrow(parsed_table), length(mx$value) + length(mx$rgroup %>% unique)) }) htmlTable/tests/testthat/test-txtMergeLines.R0000644000176200001440000000116713407215301021063 0ustar liggesuserslibrary(testthat) context("Test txtMergeLines") test_that("Check one argument with multiple new lines",{ out <- txtMergeLines("a b") expect_equal(length(gregexpr("
", out)[[1]]), 1) out <- txtMergeLines("a b c") expect_equal(length(gregexpr("
", out)[[1]]), 2) }) test_that("Check multiple arguments",{ out <- txtMergeLines("a", "b") expect_equal(length(gregexpr("
", out)[[1]]), 1) out <- txtMergeLines("a", "b", "c") expect_equal(length(gregexpr("
", out)[[1]]), 2) })htmlTable/tests/testthat/test-htmlTable-input_checks.R0000644000176200001440000000054313701421460022661 0ustar liggesuserslibrary(testthat) library('magrittr', warn.conflicts = FALSE) library('XML', warn.conflicts = FALSE) # Check that a css.cell passes without errors test_that("Check css.cell input", { expect_match(matrix(1:6, ncol=3) %>% addHtmlTableStyle(css.cell="background: red") %>% htmlTable, "background: red") }) htmlTable/tests/testthat/test-tidyHtmlTable_sorting.R0000644000176200001440000002526714646647673022646 0ustar liggesuserslibrary(testthat) library(dplyr) library(tibble) library(purrr) library(glue) library(XML) library(xml2) library(stringr) test_that("Correct table sort", { skip_if_not_installed("tidyr") mtcatr_proc_data <- structure( list(cyl = c("4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders"), gear = c("3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears"), per_metric = c("hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec"), summary_stat = c("Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max"), value = c(97, NA, 97, 97, 21.5, NA, 21.5, 21.5, 20, NA, 20, 20, 76, 20.1, 52, 109, 26.9, 4.8, 21.4, 33.9, 19.6, 1.5, 18.5, 22.9, 102, 15.6, 91, 113, 28.2, 3.1, 26, 30.4, 16.8, 0.1, 16.7, 16.9, 107.5, 3.5, 105, 110, 19.8, 2.3, 18.1, 21.4, 19.8, 0.6, 19.4, 20.2, 116.5, 7.5, 110, 123, 19.8, 1.6, 17.8, 21, 17.7, 1.1, 16.5, 18.9, 175, NA, 175, 175, 19.7, NA, 19.7, 19.7, 15.5, NA, 15.5, 15.5, 194.2, 33.4, 150, 245, 15.1, 2.8, 10.4, 19.2, 17.1, 0.8, 15.4, 18, 299.5, 50.2, 264, 335, 15.4, 0.6, 15, 15.8, 14.6, 0.1, 14.5, 14.6)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -96L)) out_str <- mtcatr_proc_data %>% arrange(per_metric, summary_stat) %>% tidyHtmlTable(header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric, skip_removal_warning = TRUE, label = "test_table") read_html(out_str) %>% xml_find_first("//thead") %>% xml_find_all(".//tr/th") %>% xml_contents() %>% as_list() %>% unlist() %>% str_trim %>% keep(~. != "") %>% expect_equivalent(c(paste(c(4, 6, 8), "Cylinders"), paste(3:5, "Gears"), paste(3:5, "Gears"), paste(c(3, 5), "Gears"))) read_html(out_str) %>% xml_find_all("//table") %>% xml_find_first("//tbody") %>% xml_find_all(".//tr/*[1]") %>% xml_contents() %>% as_list() %>% unlist() %>% keep(~!stringr::str_detect(., "^\\s")) %>% expect_equivalent(mtcatr_proc_data %>% distinct(per_metric) %>% arrange(per_metric) %>% extract2(1)) out_str <- mtcatr_proc_data %>% arrange(desc(per_metric), summary_stat) %>% tidyHtmlTable(header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric, skip_removal_warning = TRUE) read_html(out_str) %>% xml_find_all("//table") %>% xml_find_first("//tbody") %>% xml_find_all(".//tr/*[1]") %>% xml_contents() %>% as_list() %>% unlist() %>% keep(~!stringr::str_detect(., "^\\s")) %>% expect_equivalent(mtcatr_proc_data %>% distinct(per_metric) %>% arrange(per_metric) %>% extract2(1) %>% rev) out_str <- mtcatr_proc_data %>% arrange(cyl, gear) %>% tidyHtmlTable(header = summary_stat, cgroup = per_metric, rnames = gear, rgroup = cyl, skip_removal_warning = TRUE, label = "test_table", rowlabel = "row") read_html(out_str) %>% xml_find_first("//thead") %>% xml_find_all(".//tr/th") %>% xml_contents() %>% as_list() %>% unlist() %>% str_trim %>% keep(~. != "") %>% expect_equivalent(c("hp", "mpg", "qsec", "row", rep(c("Max", "Mean", "Min", "SD"), times = 3))) parsed_table <- readHTMLTable(as.character(out_str))[["test_table"]] group_idx_of_interest <- which(parsed_table$row == "8 Cylinders") subtable <- parsed_table[(group_idx_of_interest + 1):nrow(parsed_table),] subdata <- mtcatr_proc_data %>% filter(cyl == "8 Cylinders") check_subdata <- function(pm, st, gr_regexp, no) { subdata %>% filter(per_metric == pm & summary_stat == st & str_detect(gear, gr_regexp)) %>% pluck("value") %>% as.character() %>% if_else(is.na(.), "", .) %>% expect_equal(subtable[str_detect(subtable$row, gr_regexp), which(colnames(subtable) == st)[no]] %>% as.character()) } check_subdata(pm = "hp", st = "Max", gr_regexp = "3", no = 1) check_subdata(pm = "mpg", st = "Max", gr_regexp = "3", no = 2) check_subdata(pm = "qsec", st = "Max", gr_regexp = "3", no = 3) check_subdata(pm = "qsec", st = "Min", gr_regexp = "3", no = 3) check_subdata(pm = "qsec", st = "Mean", gr_regexp = "3", no = 3) check_subdata(pm = "qsec", st = "Mean", gr_regexp = "5", no = 3) check_subdata(pm = "qsec", st = "SD", gr_regexp = "5", no = 3) check_subdata(pm = "hp", st = "SD", gr_regexp = "5", no = 1) out_str <- mtcatr_proc_data %>% arrange(desc(cyl), gear) %>% mutate(per_metric = factor(per_metric, levels = c("qsec", "hp", "mpg"))) %>% tidyHtmlTable(header = summary_stat, cgroup = per_metric, rnames = gear, rgroup = cyl, skip_removal_warning = TRUE, label = "test_table", rowlabel = "row") parsed_table <- readHTMLTable(as.character(out_str))[["test_table"]] group_idx_of_interest <- which(parsed_table$row == "6 Cylinders") end_group_idx_of_interest <- which(parsed_table$row == "4 Cylinders") subtable <- parsed_table[(group_idx_of_interest + 1):(end_group_idx_of_interest - 1),] subdata <- mtcatr_proc_data %>% filter(cyl == "6 Cylinders") check_subdata(pm = "qsec", st = "SD", gr_regexp = "4", no = 1) check_subdata(pm = "hp", st = "SD", gr_regexp = "4", no = 2) check_subdata(pm = "mpg", st = "SD", gr_regexp = "4", no = 3) check_subdata(pm = "mpg", st = "SD", gr_regexp = "5", no = 3) check_subdata(pm = "mpg", st = "Max", gr_regexp = "5", no = 3) })htmlTable/tests/testthat/test-theming.R0000644000176200001440000000163513701421460017726 0ustar liggesusersrequire(testthat) context('Theming for htmlTable') # A simple example test_that("Get current themes", { theme <- getHtmlTableTheme() expect_list(theme, names = "unique") valid_names <- Filter(function(x) !(x %in% c("theme", "")), names(as.list(setHtmlTableTheme))) expect_true(all(names(theme) %in% valid_names)) }) test_that("Set current theme", { newTheme <- setHtmlTableTheme(align = "l") theme <- getHtmlTableTheme() expect_equal(newTheme, theme) expect_equal(theme$align, "l") }) test_that("Style assertions", { expect_error(prAssertStyles(list("a")), regexp = "Must have names") expect_error(prAssertStyles(list(css.rgroup = "height: 100px", css.rnames = "width")), regexp = "css.rnames") expect_true(prAssertStyles(list(css.rnames = "width: 100px"))) expect_error(prAssertStyles(list(css.rnames = "width: 100px", css.tspanner = list(a = 2))), regexp = "list") }) htmlTable/tests/testthat/ters-htmlTable_cell_styles_via_prPrepareCSS.R0000644000176200001440000000213413701421460026032 0ustar liggesuserslibrary(testthat) test_that("Test cell styles", { mx <- matrix(1:3, nrow = 2, ncol = 3, byrow = TRUE) mx_head <- LETTERS[1:ncol(mx)] mx_rnames <- LETTERS[1:nrow(mx)] expect_equal( dim(prPrepareCss(mx, "")), dim(mx) ) expect_equal( dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx) ) expect_equal( dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx) ) expect_equal( dim(prPrepareCss(mx, rep("", times = ncol(mx)))), dim(mx) ) expect_error(prPrepareCss(mx, rep("", times = nrow(mx)))) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow = 2, ncol = 4, byrow = TRUE) expect_equal( prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)[2, 1], "b" ) expect_error(prPrepareCss(mx, mx_cell.style)) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow = 3, ncol = 4, byrow = TRUE) expect_equal( prPrepareCss(mx, mx_cell.style, header = mx_head, rnames = mx_rnames )[2, 1], "b" ) expect_error(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)) }) htmlTable/tests/testthat/test-tidyHtmlTable_Hmisc_latex.R0000644000176200001440000001522314646647673023410 0ustar liggesuserslibrary(testthat) library(dplyr) library(tibble) library(purrr) library(glue) library(XML) library(xml2) library(stringr) test_that("Works with Hmisc::latex", { mtcatr_proc_data <- structure( list(cyl = c("4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "4 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "6 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders", "8 Cylinders"), gear = c("3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "4 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "3 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears", "5 Gears"), per_metric = c("hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec", "hp", "hp", "hp", "hp", "mpg", "mpg", "mpg", "mpg", "qsec", "qsec", "qsec", "qsec"), summary_stat = c("Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max", "Mean", "SD", "Min", "Max"), value = c(97, NA, 97, 97, 21.5, NA, 21.5, 21.5, 20, NA, 20, 20, 76, 20.1, 52, 109, 26.9, 4.8, 21.4, 33.9, 19.6, 1.5, 18.5, 22.9, 102, 15.6, 91, 113, 28.2, 3.1, 26, 30.4, 16.8, 0.1, 16.7, 16.9, 107.5, 3.5, 105, 110, 19.8, 2.3, 18.1, 21.4, 19.8, 0.6, 19.4, 20.2, 116.5, 7.5, 110, 123, 19.8, 1.6, 17.8, 21, 17.7, 1.1, 16.5, 18.9, 175, NA, 175, 175, 19.7, NA, 19.7, 19.7, 15.5, NA, 15.5, 15.5, 194.2, 33.4, 150, 245, 15.1, 2.8, 10.4, 19.2, 17.1, 0.8, 15.4, 18, 299.5, 50.2, 264, 335, 15.4, 0.6, 15, 15.8, 14.6, 0.1, 14.5, 14.6)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -96L)) skip_if_not_installed("tidyr") skip_if_not_installed("Hmisc") expect_output(mtcatr_proc_data %>% arrange(desc(cyl), gear) %>% mutate(per_metric = factor(per_metric, levels = c("qsec", "hp", "mpg"))) %>% tidyHtmlTable(header = summary_stat, cgroup = per_metric, rnames = gear, rgroup = cyl, skip_removal_warning = TRUE, label = "test_table", rowlabel = "row", table_fn = Hmisc::latex, file = ""), regexp = "8 Cylinders") })htmlTable/tests/testthat.R0000644000176200001440000000005313701421460015307 0ustar liggesuserslibrary(testthat) test_check('htmlTable') htmlTable/tests/visual_tests/0000755000176200001440000000000013730316012016051 5ustar liggesusershtmlTable/tests/visual_tests/word_test.Rmd0000644000176200001440000000665613701421460020546 0ustar liggesusers--- title: "Pandoc test" output: html_document editor_options: chunk_output_type: inline --- ```{r echo=FALSE} knitr::opts_chunk$set(echo = FALSE, message=FALSE, warning=FALSE) ``` ```{r} library(htmlTable) library(magrittr) mx <- matrix(1:6, ncol=3) htmlTable(mx, caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", tfoot = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?") set.seed(1) mx <- matrix(runif(3*10)*10, ncol=3) %>% set_colnames(LETTERS[1:3]) %>% set_rownames(LETTERS[1:10]) txtRound(mx, 3) %>% htmlTable( align = "clr", caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", tfoot = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. † Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? ‡ Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?") htmlTable(mx, rgroup = c("Lorem", "ipsum", "dolor"), n.rgroup = c(2, 3), cgroup = c("", "Test"), n.cgroup = 1, align = "llr", caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.") ``` htmlTable/tests/visual_tests/word_test.html0000644000176200001440000233775313662300310020773 0ustar liggesusers Pandoc test
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.
1 3 5
2 4 6
Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.
A B C
A 2.655 2.060 9.347
B 3.721 1.766 2.121
C 5.729 6.870 6.517
D 9.082 3.841 1.256
E 2.017 7.698 2.672
F 8.984 4.977 3.861
G 9.447 7.176 0.134
H 6.608 9.919 3.824
I 6.291 3.800 8.697
J 0.618 7.774 3.403
Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt.
† Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur?
‡ Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.
  Test
A   B C
Lorem
  A 2.655086631421   2.05974574899301 9.34705231105909
  B 3.7212389963679   1.76556752528995 2.12142521282658
ipsum
  C 5.72853363351896   6.87022846657783 6.51673766085878
  D 9.08207789994776   3.84103718213737 1.25555095961317
  E 2.01681931037456   7.69841419998556 2.67220668727532
dolor
  F 8.98389684967697   4.97699242085218 3.86114092543721
  G 9.44675268605351   7.17618508264422 0.133903331588954
  H 6.60797792486846   9.91906094830483 3.82387957070023
  I 6.2911404389888   3.80035179434344 8.6969084572047
  J 0.617862704675645   7.77445221319795 3.4034899668768
htmlTable/tests/visual_tests/htmlTable_vtests.R0000644000176200001440000001663013730316012021526 0ustar liggesusersoptions(htmlTable.pretty_indentation = TRUE) mx <- paste("value ", 1:6) %>% matrix(ncol = 3) colnames(mx) <- c("A", "B", "C") %>% paste("header", .) rownames(mx) <- letters[1:2] ## col.rgroup does not break css.group setHtmlTableTheme(theme = "Google") mx %>% addHtmlTableStyle(css.rgroup = "font-weight:900; background-color:#f2f2f2;", align = "|l|r|c|r|", spacer.celltype = "skip") %>% htmlTable(n.rgroup = c(2), rgroup = c("Nice!"), n.cgroup = list(c(1, 2), c(2,1)), cgroup = list(c("1:1", "1:2-3"), c("2:1-2", "2:3"))) mx %>% addHtmlTableStyle(css.cgroup = "font-weight:900; background-color:#f2f2f2; vertical-align:middle;", align = "|l|r|c|r|", spacer.celltype = "single_empty") %>% htmlTable(n.rgroup = c(2), rgroup = c("Nice!"), n.cgroup = list(c(1, 2), c(2,1)), cgroup = list(c("1:1", "1:2-3"), c("2:1-2", "2:3"))) mx %>% addHtmlTableStyle(align = "|l|r|c|r|", align.header = "|c|c|c|", spacer.celltype = "double") %>% htmlTable(n.rgroup = c(2), rgroup = c("Nice!"), n.cgroup = list(c(1, 2), c(2,1)), cgroup = list(c("1:1", "1:2-3"), c("2:1-2", "2:3"))) mx %>% set_colnames(c("A
first", "B", "C") %>% paste("header", .)) %>% addHtmlTableStyle(align = "|l|r|c|r|", spacer.celltype = "double") %>% htmlTable(n.rgroup = c(2), rgroup = c("Vertical alignment in header check"), n.cgroup = list(c(1, 2), c(2,1)), cgroup = list(c("1:1
vertical check", "1:2-3"), c("2:1-2", "2:3"))) colnames(mx) <- NULL htmlTable(mx) htmlTable(mx[1,,drop = FALSE]) htmlTable(mx, n.rgroup = 2, rgroup = "A") htmlTable(mx, tspanner = "AA", n.tspanner = 2, n.rgroup = 2, rgroup = "A") htmlTable(mx, tspanner = "AA", n.tspanner = 2, padding.tspanner = "  ", n.rgroup = 2, rgroup = "A") htmlTable(mx, tspanner = "AA", n.tspanner = 2) htmlTable(mx, n.rgroup = 2, rgroup = "A", padding.rgroup = "") # This will cause the table to look strange # but forcing >/< is a bigger constraint # that may be undesirable for more advanced users. mx[1,1] <- "< = <" mx[1,2] <- "22" mx[1,3] <- "3" mx[2,1] <- "" htmlTable(mx) mx <- matrix(1:9, ncol = 3) colnames(mx) <- LETTERS[1:3] rownames(mx) <- letters[1:3] mx_3_times <- rbind(mx, mx, mx) htmlTable(mx_3_times, css.tspanner.sep = "border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times = 3), n.rgroup = rep(c(1,2), times = 3), tspanner = c("First", "Second", "Third"), n.tspanner = rep(nrow(mx), times = 3), rowlabel = '', col.rgroup = c('white','lightblue1'), tfoot = "Some footer text", caption = "Caption text") htmlTable(mx_3_times, css.tspanner.sep = c("border-top: 2px solid red;", "border-top: 2px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times = 3), n.rgroup = rep(c(1,2), times = 3), tspanner = c("First", "Second", "Third"), n.tspanner = rep(nrow(mx), times = 3), rowlabel = '', col.rgroup = c('white','lightblue1'), tfoot = "Some footer text", caption = "Caption text") htmlTable(mx_3_times, css.tspanner.sep = c("border-top: 2px solid red;", "border-top: 2px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times = 3), n.rgroup = rep(c(1,2), times = 3), tspanner = c("First", "Second", "Third"), n.tspanner = rep(nrow(mx), times = 3), rowlabel = '', col.rgroup = c('white','lightblue1'), col.columns = c('none','#CCCCCC'), tfoot = "Some footer text", caption = "Caption text") htmlTable(mx_3_times, css.tspanner.sep = c("border-top: 2px solid red;", "border-top: 12px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times = 3), n.rgroup = rep(c(1,2), times = 3), tspanner = c("First", "Second", "Third"), n.tspanner = rep(nrow(mx), times = 3), rowlabel = '', tfoot = "Some footer text", caption = "Caption text") htmlTable(mx_3_times, css.tspanner = "color: purple; font-weight: bold;", css.tspanner.sep = "border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times = 3), n.rgroup = rep(c(1,2), times = 3), tspanner = c("First", "Second", "Third"), n.tspanner = rep(nrow(mx), times = 3), rowlabel = '', tfoot = "Some footer text", caption = "Caption text") htmlTable(mx_3_times, padding.tspanner = "+", padding.rgroup = "-", css.tspanner = "color: purple; font-weight: bold;", css.tspanner.sep = "border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times = 3), n.rgroup = rep(c(1,2), times = 3), tspanner = c("First", "Second", "Third"), n.tspanner = rep(nrow(mx), times = 3), rowlabel = '', tfoot = "† Some footnote ‡ Another footnote", caption = "Caption text") rbind( `Group A` = c(20, 380), `Group B` = c(110, 1230), `Group C` = c(2, 56), `Group D` = c(17, 33), `Group A` = c(40, 360), `Group B` = c(230, 1100), `Group C` = c(8, 50), `Group D` = c(10, 40) ) %>% apply(1, function(x) { sapply(x, function(count) c( txtInt(count), sprintf("(%s)", txtRound(count/sum(x) * 100, 1)))) %>% c(txtInt(sum(x)), .) }) %>% t %>% htmlTable(header = c("Total", rep(c("No", "(%)"), times = 2)), n.cgroup = list(c(1, 2, 2)), cgroup = list(c("", "Cases", "Controls")), rgroup = rep(c("Aspirin", "Intermittent compression"), times = 2), n.rgroup = rep(2, times = 4), tspanner = c("First experiment", "Second experiment"), n.tspanner = c(2), align = "r", caption = "Extremely fake data") library(tidyverse) mtcars %>% as_tibble(rownames = "rnames") %>% pivot_longer(names_to = "per_metric", cols = c(hp, mpg, qsec)) %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1), .groups = 'drop') %>% pivot_longer(names_to = "summary_stat", cols = c(Mean, SD, Min, Max)) %>% ungroup() %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) %>% arrange(per_metric, summary_stat) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric, skip_removal_warning = TRUE, caption = "A full example of how to apply the tidyverse workflow to generate a table") htmlTable/tests/visual_tests/pandoc_test.Rmd0000644000176200001440000000173413701421460021027 0ustar liggesusers--- title: "Pandoc test" output: html_document editor_options: chunk_output_type: inline --- ```{r} library(htmlTable) library(magrittr) mx <- matrix(1:4, ncol = 2) %>% set_colnames(c("A åäö¨", "B")) %>% set_rownames(letters[1:2]) mx %>% addHtmlTableStyle(align = "r|r") %>% htmlTable(cgroup = c("Some c-group", ""), n.cgroup = 1) ``` ```{r} mx[1] <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" colnames(mx)[1] <- c("A") rownames(mx)[1] <- letters[1] interactiveTable(mx) ``` ```{r} mx <- matrix(rep(mx[1], 6), ncol = 2) interactiveTable(mx) ``` htmlTable/tests/testInteractive.R0000644000176200001440000000210113407215301016616 0ustar liggesuserslibrary(htmlTable) interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2), minimized.columns = 2) interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2, button = TRUE) knitr::knit_print(interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2)) htmlTable:::print.interactiveTable( interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2, button = TRUE)) htmlTable/MD50000644000176200001440000002346514647053220012513 0ustar liggesuserscc89c0cd91a5e0de88e0f9311f7c04c2 *DESCRIPTION 33aa6a5904fd484d5a525fdc6ea0a76e *NAMESPACE 0a0be00f0deb39be34f95096338dd91e *NEWS.md 0cca60556d4211fccb36ecec6e2d60e0 *R/concatHtmlTables.R 58950cade6d54ec53878d569f0236cec *R/data-SCB.R de0e53716a5120f2bb1947d1233bffa9 *R/deprecated.R bf6d4cdb695b643f8b7e2c936b38ed63 *R/htmlTable.R 48c561b8540d2c1f37278f72948646bc *R/htmlTableWidget.R a12bebef3938512b14a52dffa8827157 *R/htmlTable_helpers_addSemicolon2StrEnd.R 5f02207fefc70185267488ac3b07969a *R/htmlTable_helpers_attr4RgroupAdd.R 37e77f6d1243e045494f20d26127658d *R/htmlTable_helpers_convertDfFactors.R a8eddadf58d3bc4a4baa1bdff703dd00 *R/htmlTable_helpers_escapeHtml.R 66cb3f64e1b6a30ffea53cc78598532c *R/htmlTable_helpers_getAlign.R 66c476d63fdea6c112b00917befd8cd6 *R/htmlTable_helpers_getRowlabelPos.R bfe60277acc46e54e8a235a0179a3408 *R/htmlTable_helpers_getStyle.R 39ec7ff2899db0b81fc0886b2b1f0164 *R/htmlTable_helpers_isNotebook.R 955725c406e04787920f3a0ec96f627b *R/htmlTable_helpers_mergeClr.R 735b0fe57dbf96260d36f8643b40d6a8 *R/htmlTable_helpers_prepInputMatrixDimensions.R 3b48339d1c3fe42e45c819549183fb0b *R/htmlTable_helpers_prepareAlign.R 878249f3136eccbc9b8f32e0f0c6c735 *R/htmlTable_helpers_prepareCgroup.R 3709324279b7828b9a4960085dd73f15 *R/htmlTable_helpers_prepareColors.R 55fe8ad030642fd56a3c5cff1885c2e5 *R/htmlTable_helpers_prepareCss.R 46d588c72ff525ed0a578fc0368d9147 *R/htmlTable_helpers_skipRownames.R b974519a8845d007ab5d67e41d01528f *R/htmlTable_helpers_tblNo.R d0d9f2192c135ffc4b15904fffe4504c *R/htmlTable_render_addCells.R cdf08dea56db3953fc1d1054ce3152f4 *R/htmlTable_render_getCgroupHeader.R 3811613d76e6afe26baf64e1f66175f1 *R/htmlTable_render_getRgroupLine.R f9a0db7b2b5b074105e653cfcc6651dc *R/htmlTable_render_getThead.R 125a13c0a483f7539c736abb1b6a1cd1 *R/htmlTable_render_knit_print.R 2f94bbeb6bd4e2a48dff81855fc60e0b *R/htmlTable_render_prAddEmptySpacerCell.R 3327895c3def1a82925d5ebe46b35265 *R/htmlTable_render_print.R 3224056c9825b3db586bc405c6b2a9b0 *R/htmlTable_style_assertions.R c4817e3b15d3c8a125b37ed1a53db938 *R/htmlTable_style_handlers.R f472747427fbf1a6ec9cd07055465816 *R/htmlTable_theme.R 93360d08ec4a65705d54339c711777a1 *R/interactiveTable.R ec6bba19a763a389aa7e320d063e29b4 *R/prepGroupCounts.R c6b79388ed70f1054802ab7ee74a99fb *R/tblNo.R b414d232802166e707e39593f0bc02a5 *R/tidyHtmlTable.R 2542e9e8e7398983a55ee50e1d8fcb65 *R/tidyHtmlTable_helpers_bindDataListIntoColumns.r 6d42882eb3dbca0bbac4e281028322b2 *R/tidyHtmlTable_helpers_checkUniqueness.r 05503328001943ad4db644d95d5c19b9 *R/tidyHtmlTable_helpers_extractElementsAndConvertToTbl.R 5380de329b16f46815ea16862e8739a1 *R/tidyHtmlTable_helpers_getColTbl.R b310ddcb035daa9b56f0f805dd6b0060 *R/tidyHtmlTable_helpers_getRowTbl.r 21d71bb5ca4c4f361e76f6d4abae3909 *R/tidyHtmlTable_helpers_innerJoinByCommonCols.r 5d0ef174020123e8e5f779988c763856 *R/tidyHtmlTable_helpers_prAssertAndRetrieveValue.R 021dd5fd1b89f8d71e78092f332c410d *R/tidyHtmlTable_helpers_removeRowsWithNA.r a28b351171fd663879d45748c0b2d5a5 *R/tidyHtmlTable_helpers_safeLoadPkg.R d2b32e4d3aa12a70cbe38b5e7a9d3207 *R/tidyHtmlTable_helpers_simplify_arg_list.R e32dd0e30337522871def7b5d62cf155 *R/txtFrmt.R 66aed7e991496d8ad1429a7a2bbf1b20 *R/txtFrmt_round.R 59222991397a0b630b32a6bad45cc0c0 *R/txtFrmt_round_data.frame.R 448a5ec9d8f13be68edc2aac4967c244 *R/vector2string.R 50ef9e1fcbeab122eb72e3d29aabe4cb *README.md 37397c2822e4b2e339d13590c8dc4e63 *build/vignette.rds e38a7a346e35171e1b34f7712b29dd82 *data/SCB.rda 731f269961f88758baba04ec76b3a49e *inst/doc/complex_tables.R 4be339abdb3bd0a529b53545227bc554 *inst/doc/complex_tables.Rmd ff34224a9f1a2e6f322d23f129fb4b48 *inst/doc/complex_tables.html bb028ce36930c690cba6ad9fe9b8ba1c *inst/doc/general.R 3a9629596d0caaa798881337b9c05aad *inst/doc/general.Rmd 6d07ce7c4c76aca340159a4b33b7c858 *inst/doc/general.html f4c843a1176f4bc59840501d037dcad5 *inst/doc/text_formatters.R 77683ef100bd4a9f3115ebd7f3c2bb0e *inst/doc/text_formatters.Rmd 584ffe5b296ced2736c867a891a68a56 *inst/doc/text_formatters.html c99b4d8a518e20a89a3a18646af0b3a8 *inst/doc/tidyHtmlTable.R 08b7cd5b0a36eed44e0ea98fde751a42 *inst/doc/tidyHtmlTable.Rmd 4406ca24401d082abdc99c7fc030b94f *inst/doc/tidyHtmlTable.html 4f65ed52c60f1f85cb43740666ed3c82 *inst/examples/concatHtmlTables_example.R 8e55a3031e1e5fb4765e104befa34226 *inst/examples/data-SCB_example.R f67d4dc8d31555e99ece94ea926de958 *inst/examples/htmlTable_example.R 3d9fbff0715d20add5ee6d8b32c1bd61 *inst/examples/interactiveTable_example.R 28dac3d055bb72bf156187fc888ba9ed *inst/examples/tidyHtmlTable_example.R 02be25da98a52b5cf49b4df8d5e0de2e *inst/html_components/button.html 132f309e3f83db888152d7106ec41bcf *inst/htmlwidgets/htmlTableWidget.js 9d64ab9c68200839f89866984786eec8 *inst/htmlwidgets/htmlTableWidget.yaml 6e908243e42ce0b91a3de48b1e453df3 *inst/htmlwidgets/lib/jquery/jquery-AUTHORS.txt 2c872dbe60f4ba70fb85356113d8b35e *inst/htmlwidgets/lib/jquery/jquery.min.js 36cb4d79c25bf7b3aefbe78327681a0f *inst/htmlwidgets/lib/table_pagination/table_pagination.css d677798e4c1f10fb8f9f4d623564a414 *inst/htmlwidgets/lib/table_pagination/table_pagination.js d2ca198a2b8d36ed4a82c76ce10de625 *inst/javascript/button.js 1b709ec9de931d7f62fd71c56686d268 *inst/javascript/toggler.js cfe22f78a65ce29c735c587f2d66259e *man/SCB.Rd cc67933382c1e01e6081793c60172189 *man/addStyles.Rd e8f635609ce74cf17bcfc4ca2a25a001 *man/concatHtmlTables.Rd 7789f1c3890b9aa99dc74e4d7adb156c *man/getHtmlTableStyle.Rd 9a53e995d36ea30db33ab8eccb316906 *man/getHtmlTableTheme.Rd e70a10b1194e05436748ffdccface93a *man/hasHtmlTableStyle.Rd 92d1bd002aec906fa962543e17a86030 *man/htmlTable.Rd 8ca2ec117b63d6019cc74df23c65b771 *man/htmlTableWidget-shiny.Rd b753e6c0e431bc34e7eb5b2ac8aa6f1c *man/htmlTableWidget.Rd bd134090e424ac5e21a8b7ff79402b78 *man/innerJoinByCommonCols.Rd 3e629563798db13ccc8c3fbad4e3e229 *man/interactiveTable.Rd 6d73e0e13b17b0dde6aa0e8ac62198ce *man/outputInt.Rd 438d459f825d6e46236f8322a762c0fd *man/prAddCells.Rd 4f77ae8175c9ed504a1169e4ccadb516 *man/prAddEmptySpacerCell.Rd 284235fd66794bb1c3483d406dafea61 *man/prAddSemicolon2StrEnd.Rd 6f5ea08de0a78491e18d45c57ac4d571 *man/prAttr4RgroupAdd.Rd e98f14ce1d397874716731cf607660f2 *man/prBindDataListIntoColumns.Rd 1961494c0ed62e14bdbd08b4bb1b7c99 *man/prConvertDfFactors.Rd e8ea4fdcd362aacee4a536fb8b76621a *man/prEscapeHtml.Rd df1f5912a183604ef8561c4d054028fb *man/prExtractElementsAndConvertToTbl.Rd d8812da209edb8a30c57d771a9468b26 *man/prGetAlign.Rd 6f1c8001382f27236e67c16b60680822 *man/prGetCgroupHeader.Rd 8c7444ffda7be2c86ec378dba2456025 *man/prGetRgroupLine.Rd 8846ae8c783ea088c1e1625cb8d38672 *man/prGetRowlabelPos.Rd 17d61f0b76ffbb46864d54a2a7560ec6 *man/prGetScriptString.Rd 40a0392019b216f1e8629adcf390ef8e *man/prGetStyle.Rd 403520fc548c223ce709c4c4b97b82da *man/prGetThead.Rd 7c72432a2db14d73ba9a2ac9ebdc3d47 *man/prIsNotebook.Rd cb408208bcfa0b483d3d78eb7c3c9ef7 *man/prMergeClr.Rd 54e5f18b55f19b6bcb3a9d2036822b8e *man/prPrepInputMatrixDimensions.Rd f38b228126cb8c19e8ae0e469d154d98 *man/prPrepareAlign.Rd 2610a9afa1280e3d71796229b8dfd637 *man/prPrepareCgroup.Rd 37cb9c41bae1c0e10b6037d58f323da1 *man/prPrepareColors.Rd 371e3a85ff36ebeb673ba3a04ef8009d *man/prPrepareCss.Rd adc172aa11b4cb6c1ab3b2ba9b4202f7 *man/prSkipRownames.Rd a228c6dbfd4b5d6c3901761df3300d6c *man/prTblNo.Rd 649378a1159eeb0e73b69f8b54b7ad53 *man/prepGroupCounts.Rd 34c598a635042e5e92f063b629773f81 *man/pvalueFormatter.Rd 076504f2a833991fcec96076f4a8802e *man/setHtmlTableTheme.Rd bd24c775f958d90e4b60a25d47168e88 *man/splitLines4Table.Rd 4231fba8eb25c3ca2e76118821abebd7 *man/tblNoLast.Rd 8b2aeea0964bc63c8f6695506f753497 *man/tblNoNext.Rd ddffb9e15534b719a90700dace207276 *man/tidyHtmlTable.Rd 8afad6f94acfbf713a0498cd541a29ce *man/txtInt.Rd 2252743dfe1ab7200fb3a743f28a15b8 *man/txtMergeLines.Rd 00f1b02e09950502a4e5a3090476fb4f *man/txtPval.Rd f0d89426c6dc5d888b86641cc7f8d4ed *man/txtRound.Rd 6a4815e021f9919310030b27d726eb10 *man/vector2string.Rd 97e588c07c3f56549f7f555ce9435f5a *tests/testInteractive.R 9107723799c9b294c18abddcc5c2aa3f *tests/testthat.R d6f9101b3c5f86a58795822db200865b *tests/testthat/htmlTable_addHtmlTableStyle.R 6ac9e1e46cdd45f6b3068925c33a04be *tests/testthat/structure.tex bf00fb34a4369747bb8897181eb6fa96 *tests/testthat/ters-htmlTable_cell_styles_via_prPrepareCSS.R 143947f822f6d4d110d85263c162649f *tests/testthat/test-htmlTable-dimnames.R 87ce747995ab93542fb5d068a4c3d48c *tests/testthat/test-htmlTable-input_checks.R cebb969e0c90b3f35c491a0c4b2dbacc *tests/testthat/test-htmlTable.R b3d97a87eb9c11bc1316ce692e7eb956 *tests/testthat/test-htmlTable_cgroup.R 621deabac4bd881ce9068a0cb7dc1063 *tests/testthat/test-htmlTable_dates.R 811c90d48a828a181e9f88b0bbbcc633 *tests/testthat/test-htmlTable_escape_html.R 297550643a58a2ca2096d02b6abdf0c6 *tests/testthat/test-htmlTable_rgroup_tspanner.R 7f93f98e0e60d718e5325906585ab007 *tests/testthat/test-htmlTable_styles.R 329931dd4fa34307a266ed6eff882b5c *tests/testthat/test-htmlTable_total.R ea26eb027ce5c586bd7d6394ce8721bf *tests/testthat/test-interactiveTable.R 27826a3da249973a733e7211227a8b60 *tests/testthat/test-theming.R 90329a7dfed371d221315a0b182a1ef8 *tests/testthat/test-tidyHtmlTable.R 248d00c5b14dab11106940f00cfa0fdf *tests/testthat/test-tidyHtmlTable_Hmisc_latex.R 2bc59829a88c3ef9a2f1962182f4e867 *tests/testthat/test-tidyHtmlTable_sorting.R 9cc3eb8239f4502e26540089d1397ff4 *tests/testthat/test-txtFrmt.R 994d6e332d8a5c81bff240129144fc81 *tests/testthat/test-txtMergeLines.R bb1e39d05a591f95ccd2870af313b52c *tests/visual_tests/htmlTable_vtests.R 67a35c5f46a8b9f6f93e95498564649f *tests/visual_tests/pandoc_test.Rmd 280e41fe9c38ad69709bc46de9df1740 *tests/visual_tests/word_test.Rmd 49908b458668813b33221f390e018122 *tests/visual_tests/word_test.html 4be339abdb3bd0a529b53545227bc554 *vignettes/complex_tables.Rmd c6bf870ed5887e59df7400b57148f149 *vignettes/custom.css 3a9629596d0caaa798881337b9c05aad *vignettes/general.Rmd 77683ef100bd4a9f3115ebd7f3c2bb0e *vignettes/text_formatters.Rmd 08b7cd5b0a36eed44e0ea98fde751a42 *vignettes/tidyHtmlTable.Rmd htmlTable/R/0000755000176200001440000000000014517464356012406 5ustar liggesusershtmlTable/R/htmlTable_helpers_prepareColors.R0000644000176200001440000000305413701421460021050 0ustar liggesusers#' Prepares the alternating colors #' #' @param clr The colors #' @param n The number of rows/columns applicable to the color #' @param ng The n.rgroup/n.cgroup argument if applicable #' @param gtxt The rgroup/cgroup texts #' @return `character` A vector containing hexadecimal colors #' @import magrittr #' @keywords internal #' @importFrom grDevices col2rgb prPrepareColors <- function(clr, n = NULL, ng = NULL, gtxt) { clr <- sapply(clr, function(a_clr) { if (a_clr == "none") { return(a_clr) } if (grepl("^#[0-9ABCDEFabcdef]{3,3}$", a_clr)) { a_clr %<>% substring(first = 2) %>% strsplit(split = "") %>% unlist() %>% sapply(FUN = rep, times = 2) %>% paste(collapse = "") %>% tolower() %>% paste0("#", .) } else { a_clr %<>% col2rgb %>% as.hexmode() %>% as.character() %>% paste(collapse = "") %>% paste0("#", .) } }, USE.NAMES = FALSE) if (!is.null(ng)) { # Split groups into separate if the gtxt is "" if (any(gtxt == "")) { tmp <- c() for (i in 1:length(ng)) { if (gtxt[i] != "" && !is.na(gtxt[i])) { tmp <- c( tmp, ng[i] ) } else { tmp <- c( tmp, rep(1, ng[i]) ) } } ng <- tmp } clr <- rep(clr, length.out = length(ng)) attr(clr, "groups") <- Map(rep, clr, length.out = ng) } else if (!is.null(n)) { clr <- rep(clr, length.out = n) } return(clr) } htmlTable/R/tidyHtmlTable_helpers_getRowTbl.r0000644000176200001440000000075014165130172021035 0ustar liggesusersgetRowTbl <- function(x) { out <- prExtractElementsAndConvertToTbl(x, elements = c("tspanner", "rgroup", "rnames", "rnames_unique") ) %>% dplyr::arrange() %>% # This is necessary in order to not generate NA values when setting # hidden elements to "" and this can't be in prExtractElementsAndConvertToTbl # as we need to be able to sort according to the column in getColTbl dplyr::mutate_if(is.factor, as.character) out$r_idx <- 1:nrow(out) return(out) } htmlTable/R/tidyHtmlTable_helpers_extractElementsAndConvertToTbl.R0000644000176200001440000000047113701421460025162 0ustar liggesusers#' Extract the elements and generate a table with unique elements #' #' @param x `list` with columns to be joined #' @param elements `char` vector with the elements to select prExtractElementsAndConvertToTbl <- function(x, elements) { x[elements] %>% prBindDataListIntoColumns() %>% dplyr::distinct() } htmlTable/R/htmlTable_helpers_prepareCss.R0000644000176200001440000000707613701421460020347 0ustar liggesusers#' Prepares the cell style #' #' @param css The CSS styles that are to be converted into #' a matrix. #' @param name The name of the CSS style that is prepared #' @inheritParams htmlTable #' @return `matrix` #' @keywords internal prPrepareCss <- function(x, css, rnames, header = NULL, name = deparse(substitute(css)), style_list = NULL) { if (is.null(style_list)) { css.header <- rep("", times = ncol(x)) css.rnames <- rep("", times = nrow(x) + !is.null(header)) } else { css.header <- rep(ifelse(is.null(style_list$css.header), "", style_list$css.header), times = ncol(x)) css.rnames <- rep(ifelse(is.null(style_list$css.rnames), "", style_list$css.rnames), times = nrow(x) + !missing(header)) } if (is.matrix(css)) { if (any(grepl("^[^:]*[a-zA-Z]+[:]*:", css))) { rownames(css) <- NULL colnames(css) <- NULL } if (ncol(css) == ncol(x) + 1 && !prSkipRownames(rnames)) { if (!is.null(header)) { if (nrow(css) == nrow(x) + 1) { css.rnames <- css[, 1] } else if (nrow(css) == nrow(x)) { css.rnames[2:length(css.rnames)] <- css[, 1] } else { stop( "There is an invalid number of rows for the ", name, " matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name, " has '", nrow(css), "' rows", " and there is a header" ) } } else if (nrow(x) == nrow(css)) { css.rnames <- css[, 1] } else { stop( "There is an invalid number of rows for the ", name, " matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name, " has '", nrow(css), "' rows", " (there is no header)" ) } css <- css[, -1, drop = FALSE] } else if (ncol(css) != ncol(x)) { stop( "There is an invalid number of columns for the ", name, " matrix.", " Your x argument has '", ncol(x), "' columns", " while your ", name, " has '", ncol(css), "' columns", " and there are ", ifelse(prSkipRownames(rnames), "no", "" ), " rownames." ) } if (nrow(css) == nrow(x) + 1 && !is.null(header)) { for (i in 1:length(css.header)) { css.header[i] <- prGetStyle(css.header[i], css[1, i]) } css <- css[-1, , drop = FALSE] } else if (nrow(css) != nrow(x)) { stop( "There is an invalid number of rows for the ", name, " matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name, " has '", nrow(css), "' rows", " and there is ", ifelse(is.null(header), "no", "a"), " header" ) } } else if (is.vector(css)) { if (length(css) == ncol(x) + 1) { css.rnames <- rep(css[1], nrow(x) + prSkipRownames(rnames)) css <- css[-1] } else if (length(css) == 1) { css.rnames <- rep(css, times = nrow(x) + !is.null(header)) } else if (length(css) != ncol(x)) { stop( "The length of your ", name, " vector '", length(css), "'", " does not correspond to the column length '", ncol(x), "'", " (there are ", ifelse(prSkipRownames(rnames), "no", "" ), " rownames)" ) } css <- matrix(css, nrow = nrow(x), ncol = ncol(x), byrow = TRUE ) } return(structure(css, rnames = css.rnames, header = css.header, class = class(css) )) } htmlTable/R/htmlTable_helpers_prepInputMatrixDimensions.R0000644000176200001440000000156113730316012023433 0ustar liggesusers#' Makes sure the input is correct #' #' Checks and converts dimensions into something the #' [htmlTable()] is comfortable with. #' #' @inheritParams htmlTable #' @keywords internal #' @family hidden helper functions for htmlTable prPrepInputMatrixDimensions <- function(x, header = NULL) { if (!is.null(dim(x))) { if (length(dim(x)) != 2) { stop( "Your table variable seems to have the wrong dimension,", " length(dim(x)) = ", length(dim(x)), " != 2" ) } return(x) } preset_styles <- getHtmlTableStyle(x) if (!is.numeric(x) && !is.character(x)) { x <- as.character(x) } ncol <- length(x) if (!is.null(header)) { ncol <- length(header) } ret <- matrix(x, ncol = ncol) # We need to make sures that the style info has been retained throughout attr(ret, style_attribute_name) <- preset_styles return(ret) } htmlTable/R/htmlTable_helpers_attr4RgroupAdd.R0000644000176200001440000001045113701421460021075 0ustar liggesusers#' Get the add attribute element #' #' Gets the add element attribute if it exists. If non-existant it will #' return NULL. #' #' @param rgroup_iterator The rgroup number of interest #' @param no_cols The `ncol(x)` of the core htmlTable x argument #' @inheritParams htmlTable #' @keywords internal #' @importFrom stats na.omit prAttr4RgroupAdd <- function(rgroup, rgroup_iterator, no_cols) { if (is.null(attr(rgroup, "add"))) { return(NULL) } add_elmnt <- attr(rgroup, "add") if (is.null(names(add_elmnt))) { if (is.null(dim(add_elmnt)) && length(add_elmnt) == sum(rgroup != "")) { if (!is.list(add_elmnt)) { add_elmnt <- as.list(add_elmnt) } names(add_elmnt) <- (1:length(rgroup))[rgroup != ""] } else if (!is.null(dim(add_elmnt)) && ncol(add_elmnt) %in% c(1, no_cols)) { # Convert matrix to stricter format tmp <- list() for (i in 1:nrow(add_elmnt)) { if (ncol(add_elmnt) == 1) { tmp[[i]] <- add_elmnt[i, ] } else { tmp2 <- as.list(add_elmnt[i, ]) names(tmp2) <- 1:no_cols tmp[[i]] <- tmp2 } } if (nrow(add_elmnt) == sum(rgroup != "")) { names(tmp) <- (1:length(rgroup))[rgroup != ""] } else if (!is.null(rownames(add_elmnt))) { names(tmp) <- rownames(add_elmnt) } else { stop( "You have provided a matrix as the add attribute to rgroups without rows that either match the number of rgroups available '", length(rgroup[rgroup != ""]), "'", " (you provided '", nrow(add_elmnt), "' rows).", " And you also failed to have rownames." ) } add_elmnt <- tmp } else { stop( "The length of the rgroup 'add' attribute must either match", " (1) the length of the rgroup", " (2) or have names corresponding to the mapping integers" ) } } if (!is.list(add_elmnt) && !is.vector(add_elmnt)) { stop("The rgroup mus either be a list or a vector") } add_pos <- ifelse(grepl( "^[123456789][0-9]*$", names(add_elmnt) ), as.integer(names(add_elmnt)), NA ) if (any(is.na(add_pos))) { # Look for rgroup names that match to those not # found through the integer match # If found the number is assigned to the add_pos available_rgroups <- rgroup if (!all(is.na(add_pos))) { available_rgroups <- available_rgroups[-na.omit(add_pos)] } for (missing_pos in which(is.na(add_pos))) { row_label <- names(add_elmnt) if (row_label %in% available_rgroups) { available_rgroups <- available_rgroups[available_rgroups != row_label] pos <- which(rgroup == row_label) if (length(pos) > 1) { stop( "There seem to be two identical row groups ('", row_label, "')", " that you whish to assign a add columns to through the 'add'", " attribute for the rgroup element." ) } else { add_pos[missing_pos] <- pos } } } if (any(is.na(add_pos))) { failed_elements <- paste(names(add_elmnt)[is.na(add_pos)], collapse = "', '") available <- paste(rgroup, collapse = "', '") stop( "Failed to find matchin rgroup elements for: ", "'", failed_elements, "'", " from availabel rgroups: ", "'", available, "'" ) } names(add_elmnt) <- add_pos } if (!is.list(add_elmnt)) { add_elmnt <- as.list(add_elmnt) } if (any(add_pos < 1)) { stop("The rgroup 'add' attribute cannot have integer names below 1") } if (any(!add_pos <= length(rgroup)) || any(rgroup[add_pos] == "")) { no_rgroups_empty <- paste(which(rgroup == ""), collapse = ", ") prob_positions <- paste(add_pos[add_pos > length(rgroup) | add_pos %in% which(rgroup == "")], collapse = "', '") stop( "The rgroup 'add' attribute cannot have integer names indicating", " positions larger than the length of the rgroup", " (=", length(rgroup), ") or matches", " one of the empty groups (no. ", no_rgroups_empty, ").", " The problematic position(s):", " '", prob_positions, "'" ) } # Return the matching iterator if (rgroup_iterator %in% names(add_elmnt)) { return(add_elmnt[[as.character(rgroup_iterator)]]) } return(NULL) } htmlTable/R/htmlTable_render_addCells.R0000644000176200001440000000722213730316012017557 0ustar liggesusers#' Add a cell #' #' Adds a row of cells `val...` to a table string for #' [htmlTable()] #' #' @inheritParams htmlTable #' @param rowcells The cells with the values that are to be added #' @param cellcode Type of cell, can either be `th` or `td` #' @param style The cell style #' @param cgroup_spacer_cells The number of cells that occur between #' columns due to the cgroup arguments. #' @param has_rn_col Due to the alignment issue we need to keep track #' of if there has already been printed a rowname column or not and therefore #' we have this has_rn_col that is either 0 or 1. #' @param offset For rgroup rows there may be an offset != 1 #' @param style_list The style_list #' @return `string` Returns the string with the new cell elements #' @keywords internal #' @family hidden helper functions for htmlTable #' @importFrom stringr str_interp prAddCells <- function(rowcells, cellcode, style_list, style, prepped_cell_css, cgroup_spacer_cells, has_rn_col, offset = 1, style_list_align_key = "align") { cell_str <- "" style <- prAddSemicolon2StrEnd(style) previous_was_spacer_cell <- FALSE for (nr in offset:length(rowcells)) { cell_value <- rowcells[nr] # We don't want missing to be NA in a table, it should be empty if (is.na(cell_value)) { cell_value <- "" } followed_by_spacer_cell <- nr != length(rowcells) && nr <= length(cgroup_spacer_cells) && cgroup_spacer_cells[nr] > 0 align_style <- prGetAlign(style_list[[style_list_align_key]], index = nr + has_rn_col, style_list = style_list, followed_by_spacer_cell = followed_by_spacer_cell, previous_was_spacer_cell = previous_was_spacer_cell) cell_style <- c(prepped_cell_css[nr], style) if (!is.null(style_list$col.columns)) { cell_style %<>% c(`background-color` = style_list$col.columns[nr]) } cell_str %<>% paste(str_interp("<${CELL_TAG} style='${STYLE}'>${CONTENT}", list(CELL_TAG = cellcode, STYLE = prGetStyle(cell_style, align_style), CONTENT = cell_value)), sep = "\n\t\t") # Add empty cell if not last column if (followed_by_spacer_cell) { align_style <- prGetAlign(style_list[[style_list_align_key]], index = nr + has_rn_col, style_list = style_list, spacerCell = TRUE, followed_by_spacer_cell = followed_by_spacer_cell, previous_was_spacer_cell = previous_was_spacer_cell) # The same style as previous but without align borders cell_style <- c( prepped_cell_css[nr], style, align_style ) spanner_style <- style if (!is.null(style_list$col.columns)) { if (style_list$col.columns[nr] == style_list$col.columns[nr + 1]) { spanner_style %<>% c(`background-color` = style_list$col.columns[nr]) } } cell_str %<>% paste("\n\t\t") %>% prAddEmptySpacerCell(style_list = style_list, cell_style = prGetStyle(cell_style, spanner_style), colspan = cgroup_spacer_cells[nr], cell_tag = cellcode, align_style = align_style) } previous_was_spacer_cell <- followed_by_spacer_cell } return(cell_str) } htmlTable/R/tidyHtmlTable_helpers_prAssertAndRetrieveValue.R0000644000176200001440000000156413701421460024017 0ustar liggesusersprAssertAndRetrieveValue <- function(x, value, name = deparse(substitute(value)), maxCols = 1, optional = FALSE) { if (missing(value)) { if (is.null(x[[name]])) { if (optional) { return(NULL) } stop( "You have not provided an argument", " and the data frame does not have a '", name, "' column" ) } return(x[[name]]) } # We are one-caller removed from the original call so we need to # do this nasty hack to get the parameter of the parent function orgName <- eval(substitute(substitute(value)), envir = parent.frame()) value <- dplyr::select(x, {{orgName}}) stopifnot(ncol(value) <= maxCols) if (maxCols > 1) { return(value) } return(value[[1]]) } htmlTable/R/deprecated.R0000644000176200001440000000202713701421460014611 0ustar liggesusers# Deprecated function names #' See [txtMergeLines()] #' #' @param ... passed onto [txtMergeLines()] #' @examples #' \dontrun{ #' # Deprecated function #' splitLines4Table("hello", "world") #' } #' @keywords internal #' @export splitLines4Table <- function(...){ warning("splitLines4Table is deprecated, use txtMergeLines() instead") txtMergeLines(...) } #' Deprecated use [txtInt()] instead. #' #' @param ... Passed to [txtInt()] #' #' @examples #' \dontrun{ #' # Deprecated function #' outputInt(123456) #' } #' #' @keywords internal #' @export outputInt <- function(...){ warning("outputInt is deprecated, use txtInt() instead.") txtInt(...) } #' Deprecated use [txtPval()] instead #' #' @param ... Currently only used for generating warnings of deprecated call #' @examples #' \dontrun{ #' # Deprecated function #' pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) #' } #' @export #' @keywords internal pvalueFormatter <- function(...){ warning("pvalueFormatter is deprecated, use txtPval() instead.") txtPval(...) } htmlTable/R/tblNo.R0000644000176200001440000000357413701421460013577 0ustar liggesusers#' Gets the last table number #' #' The function relies on `options("table_counter")` #' in order to keep track of the last number. #' #' @param roman Whether or not to use roman numbers instead #' of arabic. Can also be set through `options(table_caption_no_roman = TRUE)` #' #' @export #' @examples #' org_opts <- options(table_counter=1) #' tblNoLast() #' options(org_opts) #' @family table functions #' @importFrom utils as.roman tblNoLast <- function(roman = getOption("table_counter_roman", FALSE)){ last_no <- getOption("table_counter") if (is.logical(last_no) || is.null(last_no)){ stop("You cannot call the get last figure number", " when there has been no prior figure registerd.", " In other words, you need to call the fiCapNo()", " on a figure before you call this function.", " If you want the next number then call figCapNoNext()", " instead of this function.") } if (roman) last_no <- as.character(as.roman(last_no)) return(last_no) } #' Gets the next table number #' #' The function relies on `options("table_counter")` #' in order to keep track of the last number. #' #' @inheritParams tblNoLast #' @export #' @examples #' org_opts <- options(table_counter=1) #' tblNoNext() #' options(org_opts) #' @family table functions #' @importFrom utils as.roman tblNoNext <- function(roman = getOption("table_counter_roman", FALSE)){ last_no <- getOption("table_counter") if (is.logical(last_no)){ if (last_no == FALSE) stop("You cannot call the get last figure number", " when you have explicitly set the fig_cap_no", " option to false.") last_no <- 0 }else if (is.null(last_no)){ last_no <- 0 } next_no <- last_no + 1 if (roman) next_no <- as.character(as.roman(next_no)) return(next_no) } htmlTable/R/htmlTable_render_knit_print.R0000644000176200001440000000023713701421460020226 0ustar liggesusers#' @rdname htmlTable #' @importFrom knitr knit_print #' @importFrom knitr asis_output #' @export knit_print.htmlTable <- function(x, ...) { asis_output(x) } htmlTable/R/htmlTable_helpers_getAlign.R0000644000176200001440000000433513730316012017763 0ustar liggesusers#' Gets alignment #' #' @param index The index of the align parameter of interest #' @family hidden helper functions for #' @keywords internal #' @inheritParams addHtmlTableStyle prGetAlign <- function(align, index, style_list = NULL, spacerCell = FALSE, followed_by_spacer_cell = FALSE, previous_was_spacer_cell = FALSE) { segm_rgx <- "[^lrc]*[rlc][^lrc]*" res_align <- align align <- "" # Loop to remove every element prior to the one of interest for (i in 1:index) { if (nchar(res_align) == 0) { stop("Requested column outside of span, ", index, " > ", i) } rmatch <- regexpr(segm_rgx, res_align) lrc_data <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) } styles <- c() border_in_spacer_cell <- FALSE if (!is.null(style_list) && style_list$spacer.celltype == "double_cell") { border_in_spacer_cell = TRUE } border_position <- NULL if (grepl("^\\|", lrc_data)) { border_position <- "left" } if (grepl("\\|$", lrc_data)) { border_position <- c(border_position, "right") } border_style <- list(default = getOption("htmlTable.css.border", default = "1px solid black")) if (!is.null(border_position)) { for (pos in border_position) { border_name <- paste0("border-", pos) border_style[[pos]] <- getOption(paste0("htmlTable.css.", border_name), default = border_style$default) if (!spacerCell && (!border_in_spacer_cell || (!followed_by_spacer_cell && pos == "right") || (!previous_was_spacer_cell && pos == "left"))) { styles[border_name] <- border_style[[pos]] } } } if (grepl("l", lrc_data)) { styles["text-align"] <- "left" } if (grepl("c", lrc_data)) { styles["text-align"] <- "center" } if (grepl("r", lrc_data)) { styles["text-align"] <- "right" } return(structure(styles, has_border = !is.null(border_position), border_position = border_position, border_style = border_style)) } htmlTable/R/htmlTable_helpers_escapeHtml.R0000644000176200001440000000102413701421460020310 0ustar liggesusers#' Remove html entities from table #' #' Removes the htmlEntities from table input data. Note that #' this also replaces $ signs in order to remove the MathJax #' issue. #' #' @importFrom htmltools htmlEscape #' #' @inheritParams htmlTable #' @return `x` without the html entities #' @family hidden helper functions for htmlTable prEscapeHtml <- function(x) { attributes_x <- attributes(x) x <- lapply(x, htmlEscape) x <- lapply(x, function(x) str_replace_all(x, "\\$", "$")) attributes(x) <- attributes_x return(x) } htmlTable/R/htmlTable_helpers_prepareCgroup.R0000644000176200001440000002056513701421460021054 0ustar liggesusers #' Prepares the cgroup argument #' #' Due to the complicated structure of multilevel cgroups there #' some preparation for the cgroup options is required. #' #' @inheritParams htmlTable #' @return `list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)` #' @keywords internal #' @family hidden helper functions for htmlTable prPrepareCgroup <- function(x, cgroup = NULL, n.cgroup = NULL, style_list){ cgroup_spacer_cells <- rep(0, times = (ncol(x) - 1)) # The cgroup is by for compatibility reasons handled as a matrix if (is.list(cgroup)) { if (!is.list(n.cgroup)) stop("If cgroup is a list then so must n.cgroup") if (length(n.cgroup) != length(cgroup)) stop("Different length of cgroup and n.cgroup") if (!all(sapply(cgroup, is.vector))) stop("The cgroup list consist of vectors") lengths <- sapply(n.cgroup, sum) if (any(is.na(lengths))) stop("The cgroup has invalid lengths!") for (i in 1:length(cgroup)) { if (length(cgroup[[i]]) != length(n.cgroup[[i]])) stop("The cgroup and n.cgroup elemennt's lengths don't match for the ", i, "th element") } ncols <- max(lengths, na.rm = TRUE) if (any(sapply(lengths, function(l) ncol(x) %% l != 0))) { stop("Invalid size of lists: ", vector2string(lengths), " each element should be be able to evenly divide ", ncol(x)) } cgroup_mtrx <- matrix(nrow = length(cgroup), ncol = ncols) n.cgroup_mtrx <- matrix(nrow = length(cgroup), ncol = ncols) for (i in 1:length(cgroup)) { for (ii in 1:length(cgroup[[i]])) { cgroup_mtrx[i, ii] <- cgroup[[i]][ii] n.cgroup_mtrx[i, ii] <- n.cgroup[[i]][ii] } } cgroup <- cgroup_mtrx n.cgroup <- n.cgroup_mtrx } else if (!is.matrix(cgroup)) { cgroup <- matrix(cgroup, nrow = 1) if (is.null(n.cgroup)) { n.cgroup <- matrix(NA, nrow = 1) } else { if (any(n.cgroup < 1)) { warning("You have provided cgroups with less than 1 element,", " these will therefore be removed: ", paste(sprintf("'%s' = %d", cgroup, n.cgroup)[n.cgroup < 1], collapse = ", ")) cgroup <- cgroup[,n.cgroup >= 1, drop = FALSE] n.cgroup <- n.cgroup[n.cgroup >= 1] } if (ncol(cgroup) != length(n.cgroup)) { n.cgroup <- n.cgroup[n.cgroup > 0] if (ncol(cgroup) < length(n.cgroup)) stop("You have provided too many n.cgroup,", " it should have the same length or one less than the cgroup (", ncol(cgroup), ")", " but it has the length of ", length(n.cgroup)) if (ncol(cgroup) - 1 < length(n.cgroup)) stop("You have provided too few n.cgroup,", " it should have the ate the length or one less than the cgroup (", ncol(cgroup), ")", " but it has the length of ", length(n.cgroup)) if (ncol(cgroup) - 1 == length(n.cgroup)) n.cgroup <- c(n.cgroup, ncol(x) - sum(n.cgroup)) } n.cgroup <- matrix(n.cgroup, nrow = 1) } } else if (is.null(n.cgroup)) { stop("If you specify the cgroup argument as a matrix you have to", " at the same time specify the n.cgroup argument.") } # Go bottom up as the n.cgroup can be based on the previous # n.cgroup row. for (i in nrow(cgroup):1) { # The row is empty and filled with NA's then we check # that it is possible to evenly split the cgroups among # the columns of the table if (all(is.na(n.cgroup[i,])) && ncol(x) %% length(cgroup[i,]) == 0){ # This generates the n.cgroup if this is missing n.cgroup[i,] <- rep(ncol(x)/length(cgroup[i,]), times=length(cgroup[i,])) }else if(any(n.cgroup[i,!is.na(n.cgroup[i,])] < 1)){ stop("You have in n.cgroup row no ", i, " cell(s) with < 1") }else if(sum(n.cgroup[i,], na.rm=TRUE) != ncol(x)){ ncgroupFixFromBelowGroup <- function(nc, i){ if (i+1 > nrow(nc)) stop("You have provided an invalid nc", " where it has fewer rows than the one of interest") # Select those below that are not missing row_below <- nc[i + 1, !is.na(nc[i + 1, ])] # The first position to start start_pos <- 1 # This is a slightly complicated run that took a while to figure out # and I'm still afraid of ever having to debug this section. for (ii in 1:ncol(nc)){ if (!is.na(nc[i, ii])){ # Need to find where to begin tha addition pos <- ifelse(any(start_pos > cumsum(row_below)), tail(which(start_pos > cumsum(row_below)), 1) + 1, 1) # Change the value to the rows below values that add up to this row # if the nc value is 1 and start position is 1 -> 1:(1+1-1) -> 1:1 -> 1 # if the nc value is 2 and start position is 2 -> 2:(2+2-1) -> 2:3 # if the nc value is 2 and start position is 1 -> 1:(1+2-1) -> 1:2 nc[i, ii] <- sum(row_below[pos:(pos + nc[i, ii] - 1)]) # Update the new start position: # if first run and nc is 2 then 1 + 2 -> 3 i.e. # next run the start_pos is 3 and lets say that nc is 3 then 3 + 3 -> 6 start_pos <- start_pos + nc[i, ii] } } # Return the full object return(nc) } # This grouping can be based upon the next row if (i < nrow(cgroup) && sum(n.cgroup[i, ], na.rm = TRUE) == sum(!is.na(n.cgroup[i + 1, ]))) { n.cgroup <- ncgroupFixFromBelowGroup(n.cgroup, i) }else{ stop(sprintf("Your columns don't match in the n.cgroup for the %d header row, i.e. %d != %d", i, sum(n.cgroup[i,], na.rm=TRUE), ncol(x))) } } if (!all(is.na(n.cgroup[i, ]) == is.na(cgroup[i, ]))){ stop("On header row (the cgroup argument) no ", i, " you fail to get the NA's matching.", "\n The n.cgroup has elements no:", sprintf(" '%s'", paste(which(is.na(n.cgroup[i, ])), collapse=", ")), " missing while cgroup has elements no:", sprintf(" '%s'", paste(which(is.na(cgroup[i, ])), collapse=", ")), " missing.", "\n If the NA's don't occur at the same point", " the software can't decide what belongs where.", "\n The full cgroup row: ", paste(cgroup[i, ], collapse=", "), "\n The full n.cgroup row: ", paste(n.cgroup[i, ], collapse=", "), "\n Example: for a two row cgroup it would be:", " n.cgroup = rbind(c(1, NA), c(2, 1)) and", " cgroup = rbind(c('a', NA), c('b', 'c'))") } # Add a spacer cell for each cgroup. If two cgroups # on different rows have the same separation then it # is enough to have one spacer. for (ii in 1:(length(n.cgroup[i, ])-1)){ if (!is.na(n.cgroup[i, ii]) && sum(n.cgroup[i, 1:ii], na.rm=TRUE) <= length(cgroup_spacer_cells)) cgroup_spacer_cells[sum(n.cgroup[i, 1:ii], na.rm=TRUE)] <- 1 } } # Get alignment if (is.null(style_list$align.cgroup)) { style_list$align.cgroup <- apply(n.cgroup, 1, function(nc) paste(rep("c", times=sum(!is.na(nc))), collapse="")) style_list$align.cgroup <- matrix(style_list$align.cgroup, ncol = 1) } else { if (NROW(style_list$align.cgroup) != nrow(n.cgroup)) stop("You have different dimensions for your style_list$align.cgroup and your cgroups, ", NROW(style_list$align.cgroup), " (just) !=", nrow(n.cgroup), " (n.cgroup)") # An old leftover behaviour from the latex() function if (NCOL(style_list$align.cgroup) > 1) style_list$align.cgroup <- apply(style_list$align.cgroup, 1, function(x) paste(ifelse(is.na(x), "", x), collapse="")) style_list$align.cgroup <- mapply(prPrepareAlign, align = style_list$align.cgroup, x = apply(n.cgroup, 1, function(nc) sum(!is.na(nc))), rnames=FALSE) style_list$align.cgroup <- matrix(style_list$align.cgroup, ncol=1) } style_list$css.cgroup <- prPrepareCss(x = cgroup, css = style_list$css.cgroup) return(list(cgroup = cgroup, n.cgroup = n.cgroup, align.cgroup = style_list$align.cgroup, cgroup_spacer_cells = cgroup_spacer_cells, css.cgroup = style_list$css.cgroup)) } htmlTable/R/htmlTable_render_print.R0000644000176200001440000000537713701421460017213 0ustar liggesusers#' @rdname htmlTable #' @param useViewer If you are using RStudio there is a viewer thar can render #' the table within that is envoced if in [base::interactive()] mode. #' Set this to `FALSE` if you want to remove that functionality. You can #' also force the function to call a specific viewer by setting this to a #' viewer function, e.g. `useViewer = utils::browseURL` if you want to #' override the default RStudio viewer. Another option that does the same is to #' set the `options(viewer=utils::browseURL)` and it will default to that #' particular viewer (this is how RStudio decides on a viewer). #' *Note:* If you want to force all output to go through the #' [base::cat()] the set `[options][base::options](htmlTable.cat = TRUE)`. #' @export #' @importFrom utils browseURL print.htmlTable <- function(x, useViewer, ...) { args <- attr(x, "...") # Use the latest ... from the print call # and override the original htmlTable call ... # if there is a conflict print_args <- list(...) for (n in names(print_args)) { args[[n]] <- print_args[[n]] } # Since the print may be called from another print function # it may be handy to allow functions to use attributes for the # useViewer parameter if (missing(useViewer)) { if ("useViewer" %in% names(args) && (is.logical(args$useViewer) || is.function(args$useViewer))) { useViewer <- args$useViewer args$useViewer <- NULL } else { useViewer <- TRUE } } if (interactive() && !getOption("htmlTable.cat", FALSE) && (is.function(useViewer) || useViewer != FALSE)) { if (is.null(args$file)) { args$file <- tempfile(fileext = ".html") } htmlPage <- paste("", "", "", "", "", "
", enc2utf8(x), "
", "", "", sep = "\n" ) # We only want to use those arguments that are actually in cat # anything else that may have inadvertadly slipped in should # be ignored or it will be added to the output cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(htmlPage, cat_args)) if (is.function(useViewer)) { useViewer(args$file) } else { viewer <- getOption("viewer") if (!is.null(viewer) && is.function(viewer)) { # (code to write some content to the file) viewer(args$file) } else { utils::browseURL(args$file) } } } else { cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(x, cat_args)) } invisible(x) } htmlTable/R/htmlTable_style_assertions.R0000644000176200001440000000227213701421460020121 0ustar liggesusersprAssertStyleNames <- function(x, message) { if (any(x == "")) { stop(message, " Empty names not allowed.") } invalid_names <- prGetInvalidStyleNames(x) if (length(invalid_names) > 0) { stop(message, " See name(s): ", paste(invalid_names, collapse = ", ")) } } prGetInvalidStyleNames <- function(x) { valid_names <- Filter( function(x) !(x %in% c("theme", "")), names(formals(setHtmlTableTheme)) ) checked_names <- args %in% valid_names return(args[!checked_names]) } prAssertStyles <- function(style_list) { assert_list(style_list, names = "named", .var.name = deparse(substitute(style_list))) css_styles <- names(style_list)[startsWith(names(style_list), "css.")] for (style in css_styles) { prAssertStyle(style_list[[style]], name = style) } return(TRUE) } prAssertStyle <- function(elmnt, name) { assert_character(elmnt, min.chars = 0, min.len = 1, .var.name = name ) elmnts2check <- Filter( function(x) nchar(x) > 0, elmnt ) if (name != "css.class" && is.null(names(elmnts2check)) && length(elmnts2check) > 0) { assert_true(all(sapply(elmnts2check, function(e) grepl(":", e))), .var.name = name ) } } htmlTable/R/htmlTable_helpers_skipRownames.R0000644000176200001440000000050613730316012020707 0ustar liggesusers#' Returns if rownames should be printed for the htmlTable #' #' @inheritParams htmlTable #' @keywords internal prSkipRownames <- function(rnames) { if (missing(rnames) || is.null(rnames) || length(rnames) == 0) { return(TRUE) } if (length(rnames) == 1 && rnames == FALSE) { return(TRUE) } return(FALSE) } htmlTable/R/htmlTable_render_getCgroupHeader.R0000644000176200001440000001213113730316012021107 0ustar liggesusers#' Retrieve a header row #' #' This function retrieves a header row, i.e. a row #' within the `` elements on top of the table. Used by #' [htmlTable()]. #' #' @param cgroup_vec The `cgroup` may be a `matrix`, this is #' just one row of that `matrix` #' @param n.cgroup_vec The same as above but for the counter #' @param cgroup_vec.just The same as above bot for the justification #' @param row_no The row number within the header group. Useful for multi-row #' headers when we need to output the `rowlabel` at the `pos.rowlabel` #' level. #' @param style_list The list with all the styles #' @param top_row_style The top row has a special style depending on #' the `ctable` option in the `htmlTable` call. #' @param cgroup_spacer_cells The spacer cells due to the multiple cgroup levels. #' With multiple rows in cgroup we need to keep track of how many spacer cells #' occur between the columns. This variable contains is of the size `ncol(x)-1` #' and 0 if there is no cgroup element between. #' @return `string` #' @keywords internal #' @inheritParams htmlTable #' @family hidden helper functions for htmlTable #' @importFrom stringr str_interp prGetCgroupHeader <- function(x, cgroup_vec, n.cgroup_vec, cgroup_vec.just, row_no, top_row_style, rnames, rowlabel = NULL, cgroup_spacer_cells, style_list, prepped_cell_css, css_4_cgroup_vec) { header_str <- "\n\t" if (row_no == 1) { ts <- top_row_style } else { ts <- "" } if (!is.null(rowlabel)) { if (row_no == style_list$pos.rowlabel) { header_str %<>% sprintf( "%s\n\t\t%s", ., prGetStyle( c(`font-weight` = 900), ts, attr(prepped_cell_css, "rnames")[1] ), rowlabel ) } else { header_str %<>% sprintf( "%s\n\t\t", ., prGetStyle(ts) ) } } else if (!prSkipRownames(rnames)) { header_str %<>% sprintf( "%s\n\t\t", ., prGetStyle(ts) ) } for (i in 1:length(cgroup_vec)) { if (!is.na(n.cgroup_vec[i])) { start_column <- ifelse(i == 1, 1, sum(n.cgroup_vec[1:(i - 1)], na.rm = TRUE) + 1 ) # 10 3-1 # 0 0 1 colspan <- n.cgroup_vec[i] + ifelse(start_column > length(cgroup_spacer_cells) || n.cgroup_vec[i] == 1, 0, ifelse(start_column == 1, sum(cgroup_spacer_cells[1:(n.cgroup_vec[i] - 1)]), ifelse(sum(n.cgroup_vec[1:i], na.rm = TRUE) == ncol(x), sum(cgroup_spacer_cells[start_column:length(cgroup_spacer_cells)]), sum(cgroup_spacer_cells[start_column:((start_column - 1) + (n.cgroup_vec[i] - 1))]) ) ) * prGetEmptySpacerCellSize(style_list = style_list) ) header_align <- prGetAlign(cgroup_vec.just, index = i, style_list = style_list) if (nchar(cgroup_vec[i]) == 0) { # Removed as this may now be on purpose || is.na(cgroup_vec[i])) header_values <- list(COLSPAN = colspan, STYLE = prGetStyle(c(`font-weight` = 900), ts, header_align, css_4_cgroup_vec[i]), CONTENT = "") } else { header_values <- list(COLSPAN = colspan, STYLE = prGetStyle(c(`font-weight` = 900, `border-bottom` = "1px solid grey"), ts, header_align, css_4_cgroup_vec[i]), CONTENT = cgroup_vec[i]) } header_str %<>% paste(str_interp("${CONTENT}", header_values), sep = "\n\t\t") # If not last then add a filler cell between the row categories # this is also the reason that we need the cgroup_spacer_cells if (i != sum(!is.na(cgroup_vec))) { bottom_border_style = str_interp("border-bottom: ${STYLE};", list(STYLE = style_list$spacer.css.cgroup.bottom.border)) header_str %<>% prAddEmptySpacerCell(style_list = style_list, cell_style = prGetStyle(bottom_border_style, ts), align_style = header_align, cell_tag = "th") } } } header_str %<>% paste0("\n\t") return(header_str) } htmlTable/R/htmlTable_helpers_tblNo.R0000644000176200001440000000207013701421460017303 0ustar liggesusers#' Gets the table counter string #' #' Returns the string used for htmlTable to number the different tables. #' Uses options `table_counter`, `table_counter_str`, #' and `table_counter_roman` to produce the final string. You #' can set each option by simply calling `options()`. #' #' @param caption The caption if any #' @return `string` Returns a string formatted according to #' the table_counter_str and table_counter_roman. The number is #' decided by the table_counter variable #' @keywords internal #' @family hidden helper functions for htmlTable #' @importFrom utils as.roman prTblNo <- function(caption = NULL) { tc <- getOption("table_counter", FALSE) if (tc == FALSE) { if (is.null(caption)) { return("") } else { return(caption) } } table_template <- getOption("table_counter_str", "Table %s: ") out <- sprintf( table_template, ifelse(getOption("table_counter_roman", FALSE), as.character(as.roman(tc)), as.character(tc) ) ) if (!is.null(caption)) { out <- paste(out, caption) } return(out) } htmlTable/R/htmlTable_helpers_convertDfFactors.R0000644000176200001440000000101413701421460021476 0ustar liggesusers#' Convert all factors to characters to print them as they expected #' #' @inheritParams htmlTable #' @return The data frame with factors as characters prConvertDfFactors <- function(x) { if (!"data.frame" %in% class(x)) { return(x) } i <- sapply(x, function(col) { ( ( !is.numeric(col) && !is.character(col) ) || ( inherits(col, "times") # For handlin Chron input ) ) }) if (any(i)) { x[i] <- lapply(x[i], as.character) } return(x) } htmlTable/R/htmlTableWidget.R0000644000176200001440000000457613701421460015604 0ustar liggesusers#' htmlTable with pagination widget #' #' This widget renders a table with pagination into an htmlwidget #' #' @param x A data frame to be rendered #' @param number_of_entries a numeric vector with the number of entries per page to show. #' If there is more than one number given, the user will be able to show the number #' of rows per page in the table. #' @param ... Additional parameters passed to htmlTable #' @inheritParams htmlwidgets::createWidget #' @import htmlwidgets #' @return an htmlwidget showing the paginated table #' @export htmlTableWidget <- function(x, number_of_entries = c(10, 25, 100), width = NULL, height = NULL, elementId = NULL, ...) { rendered_table <- htmlTable(x, ...) # forward options and variables using the input list: input <- list( thetable = rendered_table, options = list(number_of_entries = number_of_entries) ) # create widget htmlwidgets::createWidget( name = "htmlTableWidget", x = input, width = width, height = height, package = "htmlTable", elementId = elementId ) } #' Shiny bindings for htmlTableWidget #' #' Output and render functions for using htmlTableWidget within Shiny #' applications and interactive Rmd documents. #' #' @param outputId output variable to read from #' @param width,height Must be a valid CSS unit (like `'100%'`, `'400px'`, `'auto'`) or a number, #' which will be coerced to a string and have `'px'` appended. #' @param expr An expression that generates a [htmlTableWidget()] #' @param env The environment in which to evaluate `expr`. #' @param quoted Is `expr` a quoted expression (with `quote()`)? This #' is useful if you want to save an expression in a variable. #' #' @name htmlTableWidget-shiny #' #' @examples #' \dontrun{ #' # In the UI: #' htmlTableWidgetOutput("mywidget") #' # In the server: #' renderHtmlTableWidget({ #' htmlTableWidget(iris) #' }) #' } #' @export htmlTableWidgetOutput <- function(outputId, width = "100%", height = "400px") { htmlwidgets::shinyWidgetOutput(outputId, "htmlTableWidget", width, height, package = "htmlTable") } #' @rdname htmlTableWidget-shiny #' @export renderHtmlTableWidget <- function(expr, env = parent.frame(), quoted = FALSE) { if (!quoted) { expr <- substitute(expr) } # force quoted htmlwidgets::shinyRenderWidget(expr, htmlTableWidgetOutput, env, quoted = TRUE) } htmlTable/R/htmlTable.R0000644000176200001440000011666614517464356014465 0ustar liggesusers#' Output an HTML table #' #' Generates advanced HTML tables with column and row groups #' for a dense representation of complex data. Designed for #' maximum compatibility with copy-paste into word processors. #' For styling, see [addHtmlTableStyle()] and [setHtmlTableTheme()]. #' *Note:* If you are using \pkg{tidyverse} and \pkg{dplyr} you may #' want to check out [tidyHtmlTable()] that automates many of the arguments #' that `htmlTable` requires. #' #' @section Multiple rows of column spanners `cgroup`: #' #' If you want to have a column spanner in multiple levels (rows) you can #' set the `cgroup` and `n.cgroup` arguments to a `matrix` or `list`. #' #' For different level elements, set absent ones to NA in a matrix. For example, #' `cgroup = rbind(c("first", "second", NA), c("a", "b", "c"))`. #' And the corresponding `n.cgroup` would be `n.cgroup = rbind(c(1, 2, NA), c(2, 1, 2))`. #' for a table consisting of 5 columns. The "first" spans the first two columns, #' the "second" spans the last three columns, "a" spans the first two, "b" #' the middle column, and "c" the last two columns. #' #' Using a list is recommended to avoid handling `NA`s. #' #' For an empty `cgroup`, use `""`. #' #' @section The `rgroup` argument: #' #' The `rgroup` groups rows seamlessly. Each row in a group is indented by two #' spaces (unless the rgroup is `""`) and grouped by its rgroup element. The `sum(n.rgroup)` #' should be \if{html}{\out{≤}}\eqn{\leq} matrix rows. If fewer, remaining rows are padded with an empty rgroup (`""`). If `rgroup` #' has one more element than `n.rgroup`, the last `n.rgroup` is computed as `nrow(x) - sum(n.rgroup)` #' for a smoother table generation. #' #' @section The add attribute to `rgroup`: #' #' To add an extra element at the `rgroup` level/row, use `attr(rgroup, 'add')`. #' The value can either be a `vector`, a `list`, #' or a `matrix`. See `vignette("general", package = "htmlTable")` for examples. #' #' * A `vector` of either equal number of `rgroup`s to the number #' of `rgroup`s that aren't empty, i.e. `rgroup[rgroup != ""]`. Or a named vector where #' the name must correspond to either an `rgroup` or to an `rgroup` number. #' * A `list` that has exactly the same requirements as the vector. #' In addition to the previous we can also have a list with column numbers within #' as names within the list. #' * A `matrix` with the dimension `nrow(x) x ncol(x)` or #' `nrow(x) x 1` where the latter is equivalent to a named vector. #' If you have `rownames` these will resolve similarly to the names to the #' `list`/`vector` arguments. The same thing applies to `colnames`. #' #' @section Important \pkg{knitr}-note: #' #' This function will only work with \pkg{knitr} outputting *HTML*, i.e. #' markdown mode. As the function returns raw HTML-code #' the compatibility with non-HTML formatting is limited, #' even with [pandoc](https://pandoc.org/). #' #' Thanks to the the [knitr::knit_print()] and the [knitr::asis_output()] #' the `results='asis'` is *no longer needed* except within for-loops. #' If you have a knitr-chunk with a for loop and use `print()` to produce #' raw HTML you must set the chunk option `results='asis'`. *Note*: #' the print-function relies on the [base::interactive()] function #' for determining if the output should be sent to a browser or to the terminal. #' In vignettes and other directly knitted documents you may need to either set #' `useViewer = FALSE` alternatively set `options(htmlTable.cat = TRUE)`. #' #' @section RStudio's notebook: #' #' RStudio has an interactive notebook that allows output directly into the document. #' In order for the output to be properly formatted it needs to have the `class` #' of `html`. The `htmlTable` tries to identify if the environment is a #' notebook document (uses the \pkg{rstudioapi} and identifies if its a file with and `Rmd` #' file ending or if there is an element with `html_notebook`). If you don't want this #' behavior you can remove it using the `options(htmlTable.skip_notebook = TRUE)`. #' #' @section Table counter: #' #' If you set the option table_counter you will get a Table 1,2,3 #' etc before each table, just set `options(table_counter=TRUE)`. If #' you set it to a number then that number will correspond to the start of #' the table_counter. The `table_counter` option will also contain the number #' of the last table, this can be useful when referencing it in text. By #' setting the option `options(table_counter_str = "Table %s: ")` #' you can manipulate the counter table text that is added prior to the #' actual caption. Note, you should use the [sprintf()] `%s` #' instead of `%d` as the software converts all numbers to characters #' for compatibility reasons. If you set `options(table_counter_roman = TRUE)` #' then the table counter will use Roman numerals instead of Arabic. #' #' @section Empty data frames: #' An empty data frame will result in a warning and output an empty table, provided that #' `rgroup` and `n.rgroup` are not specified. All other row layout options will be ignored. #' #' @section Options: #' #' There are multiple options that can be set, here is a set of the perhaps most used #' * `table_counter` - logical - activates a counter for each table #' * `table_counter_roman` - logical - if true the counter is in Roman numbers, i.e. I, II, III, IV... #' * `table_counter_str` - string - the string used for generating the table counter text #' * `useViewer` - logical - if viewer should be used fro printing the table #' * `htmlTable.cat` - logical - if the output should be directly sent to `cat()` #' * `htmlTable.skip_notebook` - logical - skips the logic for detecting notebook #' * `htmlTable.pretty_indentation` - logical - there was some issues in previous Pandoc versions #' where HTML indentation caused everything to be interpreted as code. This seems to be fixed #' and if you want to look at the raw HTML code it is nice to have this set to `TRUE` so that #' the tags and elements are properly indented. #' * `htmlTableCompat` - string - see parameter description #' #' @section Other: #' #' *Copy-pasting:* As you copy-paste results into Word you need to keep #' the original formatting. Either right click and choose that paste option or click #' on the icon appearing after a paste. Currently the following compatibilities #' have been tested with MS Word 2016: #' #' * **Internet Explorer** (v. 11.20.10586.0) Works perfectly when copy-pasting into Word #' * **RStudio** (v. 0.99.448) Works perfectly when copy-pasting into Word. #' *Note:* can have issues with multi-line `cgroup`s - #' see [bug](https://bugs.chromium.org/p/chromium/issues/detail?id=305130) #' * **Chrome** (v. 47.0.2526.106) Works perfectly when copy-pasting into Word. #' *Note:* can have issues with multi-line `cgroup`s - #' see [bug](https://bugs.chromium.org/p/chromium/issues/detail?id=305130) #' * **Firefox** (v. 43.0.3) Works poorly - looses font-styling, lines and general feel #' * **Edge** (v. 25.10586.0.0) Works poorly - looses lines and general feel #' #' *Direct word processor opening:* Opening directly in Libre Office or Word is no longer #' recommended. You get much prettier results using the cut-and-paste option. #' #' *Google docs*: Copy-paste directly into a Google docs document is handled rather well. This #' seems to work especially well when the paste comes directly from a Chrome browser. #' #' *Note* that when using complex `cgroup` alignments with multiple levels #' not every browser is able to handle this. For instance the RStudio #' webkit browser seems to have issues with this and a #' [bug has been filed](https://bugs.chromium.org/p/chromium/issues/detail?id=305130). #' #' As the table uses HTML for rendering you need to be aware of that headers, #' row names, and cell values should try respect this for optimal display. Browsers #' try to compensate and frequently the tables still turn out fine but it is #' not advised. Most importantly you should try to use #' `<` instead of `<` and #' `>` instead of `>`. You can find a complete list #' of HTML characters [here](https://ascii.cl/htmlcodes.htm). #' #' Lastly, I want to mention that function was inspired by the [Hmisc::latex()] #' that can be an excellent alternative if you wish to switch to PDF-output. #' For the sibling function [tidyHtmlTable()] you can directly switch between #' the two using the `table_fn` argument. #' #' @param x The matrix/data.frame with the data. For the `print` and `knit_print` #' it takes a string of the class `htmlTable` as `x` argument. #' @param header A vector of character strings specifying column #' header, defaulting to [`colnames(x)`][base::colnames] #' @param rnames Default row names are generated from [`rownames(x)`][base::colnames]. If you #' provide `FALSE` then it will skip the row names. *Note:* For `data.frames` #' if you do [`rownames(my_dataframe) <- NULL`][base::colnames] it still has #' row names. Thus you need to use `FALSE` if you want to #' supress row names for `data.frames`. #' @param rowlabel If the table has row names or `rnames`, #' `rowlabel` is a character string containing the #' column heading for the `rnames`. #' @param caption Adds a table caption. #' @param tfoot Adds a table footer (uses the `` HTML element). The #' output is run through [txtMergeLines()] simplifying the generation #' of multiple lines. #' @param label A text string representing a symbolic label for the #' table for referencing as an anchor. All you need to do is to reference the #' table, for instance `see table 2`. This is #' known as the element's id attribute, i.e. table id, in HTML linguo, and should #' be unique id for an HTML element in contrast to the `css.class` element attribute. #' @param rgroup A vector of character strings containing headings for row groups. #' `n.rgroup` must be present when `rgroup` is given. See #' detailed description in section below. #' @param n.rgroup An integer vector giving the number of rows in each grouping. If `rgroup` #' is not specified, `n.rgroup` is just used to divide off blocks of rows by horizontal #' lines. If `rgroup` is given but `n.rgroup` is omitted, `n.rgroup` will #' default so that each row group contains the same number of rows. If you want additional #' rgroup column elements to the cells you can sett the "add" attribute to `rgroup` through #' `attr(rgroup, "add")`, see below explaining section. #' @param cgroup A vector, matrix or list of character strings defining major column header. The default #' is to have none. These elements are also known as *column spanners*. If you want a column *not* #' to have a spanner then put that column as "". If you pass cgroup and `n.crgroup` as #' matrices you can have column spanners for several rows. See cgroup section below for details. #' @param n.cgroup An integer vector, matrix or list containing the number of columns for which each element in #' cgroup is a heading. For example, specify `cgroup=c("Major_1","Major_2")`, #' `n.cgroup=c(3,3)` if `"Major_1"` is to span columns 1-3 and #' `"Major_2"` is to span columns 4-6. #' `rowlabel` does not count in the column numbers. You can omit `n.cgroup` #' if all groups have the same number of columns. If the `n.cgroup` is one less than #' the number of columns in the matrix/data.frame then it automatically adds those. #' @param tspanner The table spanner is somewhat of a table header that #' you can use when you want to join different tables with the same columns. #' @param n.tspanner An integer vector with the number of rows or `rgroup`s in the original #' matrix that the table spanner should span. If you have provided one fewer n.tspanner elements #' the last will be imputed from the number of `rgroup`s (if you have provided `rgroup` and #' `sum(n.tspanner) < length(rgroup)`) or the number of rows in the table. #' @param cspan.rgroup The number of columns that an `rgroup` should span. It spans #' by default all columns but you may want to limit this if you have column colors #' that you want to retain. #' @param total The last row is sometimes a row total with a border on top and #' bold fonts. Set this to `TRUE` if you are interested in such a row. If you #' want a total row at the end of each table spanner you can set this to `"tspanner"`. #' @param ... Passed on to `print.htmlTable` function and any argument except the #' `useViewer` will be passed on to the [base::cat()] functions arguments. #' *Note:* as of version 2.0.0 styling options are still allowed but it is recommended #' to instead preprocess your object with [addHtmlTableStyle()]. #' @param ctable If the table should have a double top border or a single a' la LaTeX ctable style #' @param compatibility Is default set to `LibreOffice` as some #' settings need to be in old HTML format as Libre Office can't #' handle some commands such as the css caption-alignment. Note: this #' option is not yet fully implemented for all details, in the future #' I aim to generate a HTML-correct table and one that is aimed #' at Libre Office compatibility. Word-compatibility is difficult as #' Word ignores most settings and destroys all layout attempts #' (at least that is how my 2010 version behaves). You can additinally use the #' `options(htmlTableCompat = "html")` if you want a change to apply #' to the entire document. #' MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). #' To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. #' To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"". #' @param escape.html logical: should HTML characters be escaped? Defaults to FALSE. #' @return Returns a formatted string representing an HTML table of class `htmlTable`. #' #' @example inst/examples/htmlTable_example.R #' #' @seealso [addHtmlTableStyle()], #' [setHtmlTableTheme()], #' [tidyHtmlTable()]. #' [txtMergeLines()], #' [Hmisc::latex()] #' #' @export #' @rdname htmlTable #' @family table functions htmlTable <- function(x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL, tfoot = NULL, label = NULL, # Grouping rgroup = NULL, n.rgroup = NULL, cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL, total = NULL, ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ...) { UseMethod("htmlTable") } #' @export htmlTable.data.frame <- function(x, ...) { # deal gracefully with an empty data frame - issue a warning. if (nrow(x) == 0) { warning(paste(deparse(substitute(x)), "is an empty object")) } htmlTable.default(prConvertDfFactors(x), ...) } #' @export htmlTable.matrix <- function(x, ...) { # deal gracefully with an empty matrix - issue a warning. if (nrow(x) == 0) { warning(paste(deparse(substitute(x)), "is an empty object")) } # Default to a sum-row when provided a table that dots <- list(...) if (all(class(x) %in% c("table", "matrix", "array")) && !is.null(rownames(x)) && grepl("^sum$", tail(rownames(x), 1), ignore.case = TRUE) && is.null(dots$total)) { dots$total <- TRUE } dots$x <- x do.call(htmlTable.default, dots) } `.` <- "magrittr CMD check issue" #' @importFrom stringr str_replace str_replace_all str_trim #' @importFrom htmltools htmlEscape #' @import checkmate #' @import magrittr #' @rdname htmlTable #' @export htmlTable.default <- function(x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL, tfoot = NULL, label = NULL, # Grouping rgroup = NULL, n.rgroup = NULL, cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL, total = NULL, ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ...) { if (isTRUE(escape.html)) { x <- prEscapeHtml(x) } x <- prPrepInputMatrixDimensions(x, header = header) dots <- list(...) style_dots <- names(dots) %in% Filter( function(x) !(x %in% c("", "x")), formals(addHtmlTableStyle) %>% names() ) if (sum(style_dots) > 0) { style_dots_list <- dots[style_dots] dots <- dots[!style_dots] style_dots_list$x <- x x <- do.call(addHtmlTableStyle, style_dots_list) } style_list <- prGetAttrWithDefault(x, which = style_attribute_name, default = getHtmlTableTheme() ) if (is.null(rgroup) && !is.null(n.rgroup)) { # Add "" rgroups corresponding to the n.rgroups rgroup <- rep("", length.out = length(n.rgroup)) } # Unfortunately in knitr there seems to be some issue when the # rnames is specified immediately as: rnames=rownames(x) if (is.null(rnames)) { if (any(is.null(rownames(x)) == FALSE)) { rnames <- rownames(x) } if (any(is.null(rownames(x))) && !is.null(rgroup)) { warning( "You have not specified rnames but you seem to have rgroups.", " If you have the first column as rowname but you want the rgroups", " to result in subhedings with indentation below then, ", " you should change the rnames to the first column and then", " remove it from the table matrix (the x argument object)." ) } } if (!is.null(rowlabel) && prSkipRownames(rnames)) { stop( "You can't have a row label and no rownames.", " Either remove the rowlabel argument", ", set the rnames argument", ", or set the rownames of the x argument." ) } if (is.null(header) && !is.null(colnames(x))) { header <- colnames(x) } else if (!is.null(header)) { if (length(header) != ncol(x)) { stop( "You have a header with ", length(header), " cells", " while your output matrix has only ", ncol(x), " columns" ) } } # Fix alignment to match with the matrix style_list$align <- prPrepareAlign(style_list$align, x = x, rnames = rnames) style_list$align.header <- prPrepareAlign(style_list$align.header, x = x, rnames = rnames, default_rn = "c") if (tolower(compatibility) %in% c( "libreoffice", "libre office", "open office", "openoffice", "word", "ms word", "msword" )) { compatibility <- "LibreOffice" } if (!is.null(rgroup)) { if (is.null(n.rgroup)) { stop("You need to specify the argument n.rgroup if you want to use rgroups") } if (any(n.rgroup < 1)) { warning( "You have provided rgroups with less than 1 elements,", " these will therefore be removed: ", paste(sprintf("'%s' = %d", rgroup, n.rgroup)[n.rgroup < 1], collapse = ", " ) ) rgroup <- rgroup[n.rgroup >= 1] n.rgroup <- n.rgroup[n.rgroup >= 1] } # Sanity check for rgroup if (sum(n.rgroup) > nrow(x)) { stop( "Your rows are fewer than suggested by the n.rgroup,", " i.e. ", sum(n.rgroup), "(n.rgroup) > ", nrow(x), "(rows in x)" ) } if (sum(n.rgroup) < nrow(x) && (length(n.rgroup) == length(rgroup) - 1 || length(n.rgroup) == length(rgroup))) { # Add an empty rgroup if missing if (length(n.rgroup) == length(rgroup)) { rgroup <- c(rgroup, "") } # Calculate the remaining rows and add those n.rgroup <- c(n.rgroup, nrow(x) - sum(n.rgroup)) } else if (sum(n.rgroup) != nrow(x)) { stop("Your n.rgroup doesn't add up") } # Sanity checks style_list$css.rgroup and prepares the style if (length(style_list$css.rgroup) > 1 && length(style_list$css.rgroup) != length(rgroup)) { stop(sprintf( "You must provide the same number of styles as the rgroups, %d != %d", length(style_list$css.rgroup), length(rgroup) )) } else if (length(style_list$css.rgroup) == 1) { style_list$css.rgroup <- prGetStyle(style_list$css.rgroup) if (length(rgroup) > 0) { style_list$css.rgroup <- rep(style_list$css.rgroup, length.out = length(rgroup)) } } else { for (i in 1:length(style_list$css.rgroup)) { style_list$css.rgroup[i] <- prGetStyle(style_list$css.rgroup[i]) } } # Sanity checks style_list$css.rgroup.sep and prepares the style if (length(style_list$css.rgroup.sep) > 1 && length(style_list$css.rgroup.sep) != length(rgroup) - 1) { stop(sprintf( "You must provide the same number of separators as the rgroups - 1, %d != %d", length(style_list$css.rgroup.sep), length(rgroup) - 1 )) } else if (length(style_list$css.rgroup.sep) == 1) { style_list$css.rgroup.sep <- prAddSemicolon2StrEnd(style_list$css.rgroup.sep) if (length(rgroup) > 0) { style_list$css.rgroup.sep <- rep(style_list$css.rgroup.sep, length.out = length(rgroup)) } } else { for (i in 1:length(style_list$css.rgroup.sep)) { style_list$css.rgroup.sep[i] <- prAddSemicolon2StrEnd(style_list$css.rgroup.sep[i]) } } cspan.rgroup <- rep(cspan.rgroup, length.out = length(rgroup)) } ## this will convert color names to hexadecimal (easier for user) ## but also leaves hex format unchanged style_list$col.rgroup <- prPrepareColors(style_list$col.rgroup, n = nrow(x), ng = n.rgroup, gtxt = rgroup) style_list$col.columns <- prPrepareColors(style_list$col.columns, ncol(x)) if (!is.null(tspanner)) { # Sanity checks style_list$css.tspanner and prepares the style if (length(style_list$css.tspanner) > 1 && length(style_list$css.tspanner) != length(tspanner)) { stop(sprintf( "You must provide the same number of styles as the tspanners, %d != %d", length(style_list$css.tspanner), length(tspanner) )) } else if (length(style_list$css.tspanner) == 1) { style_list$css.tspanner <- prAddSemicolon2StrEnd(style_list$css.tspanner) if (length(tspanner) > 0) { style_list$css.tspanner <- rep(style_list$css.tspanner, length.out = length(tspanner)) } } else { for (i in 1:length(style_list$css.tspanner)) { style_list$css.tspanner[i] <- prAddSemicolon2StrEnd(style_list$css.tspanner[i]) } } # Sanity checks style_list$css.tspanner.sep and prepares the style if (length(style_list$css.tspanner.sep) > 1 && length(style_list$css.tspanner.sep) != length(tspanner) - 1) { stop(sprintf( "You must provide the same number of separators as the tspanners - 1, %d != %d", length(style_list$css.tspanner.sep), length(tspanner) - 1 )) } else if (length(style_list$css.tspanner.sep) == 1) { style_list$css.tspanner.sep <- prGetStyle(style_list$css.tspanner.sep) if (length(tspanner) > 0) { style_list$css.tspanner.sep <- rep(style_list$css.tspanner.sep, length.out = length(tspanner) - 1) } } else { for (i in 1:length(style_list$css.tspanner.sep)) { style_list$css.tspanner.sep[i] <- prGetStyle(style_list$css.tspanner.sep[i]) } } } # Convert dimnames to something useful if (!is.null(names(dimnames(x)))) { # First dimname is always the variable name for the row dimname4row <- names(dimnames(x))[1] if (!is.null(dimname4row) && dimname4row != "") { # Use rgroup or tspanner as this is visually more separated than rowlabel # if these are available if (is.null(rgroup)) { rgroup <- dimname4row n.rgroup <- nrow(x) } else if (is.null(tspanner)) { tspanner <- dimname4row n.tspanner <- nrow(x) } else if (is.null(rowlabel)) { rowlabel <- dimname4row } } # Second dimname is always the variable name for the columns dimname4col <- names(dimnames(x))[2] if (!is.null(dimname4col) && dimname4col != "") { # Use rgroup or tspanner as this is visually more separated than rowlabel # if these are available if (is.null(cgroup)) { cgroup <- dimname4col n.cgroup <- ncol(x) # If this is a addmargins object we shouldn't have the cspanner including the # sum marker if (!is.null(total) && total && grepl("^sum$", tail(colnames(x), 1), ignore.case = TRUE)) { cgroup %<>% c("") n.cgroup <- c(n.cgroup[1] - 1, 1) } } } } # Sanity check for tspanner if (!is.null(tspanner)) { if (is.null(n.tspanner)) { stop("You need to specify the argument n.tspanner if you want to use table spanners") } if (any(n.tspanner < 1)) { stop( "You have provided invalid number of rows in the n.tspanner argument - minimum is 1, you have: ", vector2string(n.tspanner), " where no. ", vector2string(which(n.tspanner)), " was less than 1" ) } if (length(n.tspanner) == length(tspanner) - 1) { if (is.null(rgroup) || sum(n.tspanner) > length(rgroup)) { n.tspanner <- append(n.tspanner, nrow(x) - sum(n.tspanner)) } else { n.tspanner <- append(n.tspanner, length(rgroup) - sum(n.tspanner)) } } if (any(n.tspanner < 1)) { stop("You have more tspannners than n.tspanner while the number of rows doesn't leave room for more tspanners") } if (sum(n.tspanner) != nrow(x)) { if (is.null(rgroup)) { stop(sprintf( "Your rows don't match in the n.tspanner, i.e. %d != %d", sum(n.tspanner), nrow(x) )) } if (sum(n.tspanner) != length(rgroup)) { stop(sprintf( "Your rows don't match either the total number of rows '%d' or the number of rgroups '%d' the sum of n.tspanner %d", nrow(x), length(rgroup), sum(n.tspanner) )) } org_nt <- n.tspanner for (i in 1:length(n.tspanner)) { offset <- sum(org_nt[0:(i - 1)]) + 1 n.tspanner[i] <- sum(n.rgroup[offset:(offset + org_nt[i] - 1)]) } } # Make sure there are no collisions with rgrou if (!is.null(n.rgroup)) { for (i in 1:length(n.tspanner)) { rows <- sum(n.tspanner[1:i]) if (!rows %in% cumsum(n.rgroup)) { stop( "There is no splitter that matches the table spanner ", tspanner[i], " (no. ", i, ") with rgroup splits.", " The missing row splitter should be on row number ", rows, " and is not in the n.rgroup list: ", vector2string(n.rgroup), " note, it should match the cumulative sum n.rgroup", vector2string(cumsum(n.rgroup)) ) } } } } # With multiple rows in cgroup we need to keep track of # how many spacer cells occur between the groups cgroup_spacer_cells <- rep(0, times = (ncol(x) - 1)) # Sanity check for cgroup if (!is.null(cgroup)) { ret <- prPrepareCgroup( x = x, cgroup = cgroup, n.cgroup = n.cgroup, style_list = style_list ) cgroup <- ret$cgroup n.cgroup <- ret$n.cgroup cgroup_spacer_cells <- ret$cgroup_spacer_cells style_list$align.cgroup <- ret$align.cgroup style_list$css.cgroup <- ret$css.cgroup } style_list$pos.rowlabel <- prGetRowlabelPos(cgroup, style_list$pos.rowlabel, header) tc <- getOption("table_counter", FALSE) if (tc) { # Count which table it currently is if (is.numeric(tc)) { tc <- tc + 1 } else { tc <- 1 } options(table_counter = tc) } # The id works just as well as any anchor table_id <- getOption("table_counter", "") if (!is.null(label)) { table_id <- sprintf(" id='%s'", label) } else if (is.numeric(table_id)) { table_id <- paste0(" id='table_", table_id, "'") } else if (table_id == FALSE) { table_id <- "" } # A column counter that is used for total_columns <- ncol(x) + !prSkipRownames(rnames) if (!is.null(cgroup)) { if (!is.matrix(cgroup)) { total_columns <- total_columns + length(cgroup) - 1 } else { total_columns <- total_columns + sum(cgroup_spacer_cells) * prGetEmptySpacerCellSize(style_list = style_list) } } if (is.null(total) || (is.logical(total) && all(total == FALSE))) { total <- c() } else if (is.logical(total)) { if (length(total) == 1) { total <- nrow(x) } else if (length(total) == nrow(x)) { total <- which(total) } else if (!is.null(n.tspanner) && length(total) == length(n.tspanner)) { total <- cumsum(n.tspanner)[total] } else { stop( "You have provided an invalid 'total' argument:", " '", paste(total, collapse = "', '"), "'.", " Logical values accepted are either single TRUE elements", ", of the same length as the output matrix (", nrow(x), ")", ", or of the same length as the tspanner (", ifelse(is.null(n.tspanner), "not provided", length(n.tspanner)), ")." ) } } else if (is.numeric(total)) { if (any(!total %in% 1:nrow(x))) { stop( "You have indicated an invalid row as the total row.", " Valid rows are only 1 to ", nrow(x), " and you have provided invalid row(s): ", "'", paste(total[!total %in% 1:nrow(x)], collapse = "', '"), "'" ) } } else if (all(total == "tspanner")) { total <- cumsum(n.tspanner) } else { stop( "You have provided an invalid 'total' argument:", " '", paste(total, collapse = "', '"), "' ", " of the class ", paste(class(total), collapse = " & "), ".", " The function currently only accepts logical or numerical", " values." ) } style_list$css.total <- rep(style_list$css.total, length.out = length(total)) assert( check_matrix(style_list$css.cell), check_character(style_list$css.cell) ) prepped_cell_css <- prPrepareCss(x, css = style_list$css.cell, rnames = rnames, header = header, style_list = style_list ) ############################### # Start building table string # ############################### table_str <- str_interp( "", list( CLASS_NAME = paste(style_list$css.class, collapse = ", "), TABLE_CSS = paste(style_list$css.table, collapse = "; "), TABLE_ID = table_id ) ) # Theoretically this should be added to the table but the # import to word processors works then less well and therefore I've # constructed this work-around with borders for the top and bottom cells first_row <- TRUE if (isTRUE(ctable)) { top_row_style <- "border-top: 2px solid grey;" bottom_row_style <- "border-bottom: 2px solid grey;" } else if (any(ctable %in% c("single", "double"))) { ctable <- rep_len(ctable, 2L) ctable[ctable %in% "single"] <- "solid" top_row_style <- ifelse(ctable[1] == "solid", "border-top: 2px solid grey;", "border-top: 4px double grey;") bottom_row_style <- ifelse(ctable[2] == "solid", "border-bottom: 2px solid grey;", "border-bottom: 4px double grey;" ) } else { top_row_style <- "border-top: 4px double grey;" bottom_row_style <- "border-bottom: 1px solid grey;" } # Add caption according to standard HTML if (!is.null(caption)) { # Combine a table counter if provided caption <- paste0("\n\t", prTblNo(caption)) if (compatibility != "LibreOffice") { if (style_list$pos.caption %in% c("bottom", "below")) { table_str %<>% paste0("\n\t") } } if (!is.null(header) || !is.null(cgroup) || !is.null(caption)) { thead <- prGetThead( x = x, header = header, cgroup = cgroup, n.cgroup = n.cgroup, caption = caption, compatibility = compatibility, total_columns = total_columns, style_list = style_list, top_row_style = top_row_style, rnames = rnames, rowlabel = rowlabel, cgroup_spacer_cells = cgroup_spacer_cells, prepped_cell_css = prepped_cell_css, cell_style = cell_style ) first_row <- FALSE table_str %<>% paste0(thead) } table_str %<>% paste0("\n\t") if (is.null(rgroup)) { row_clrs <- style_list$col.rgroup } else { row_clrs <- unlist(attr(style_list$col.rgroup, "group")) } rgroup_iterator <- 0 tspanner_iterator <- 0 if (nrow(x) > 0) { for (row_nr in 1:nrow(x)) { rname_style <- attr(prepped_cell_css, "rnames")[row_nr] # First check if there is a table spanner that should be applied if (!is.null(tspanner) && (row_nr == 1 || row_nr > sum(n.tspanner[1:tspanner_iterator]))) { tspanner_iterator <- tspanner_iterator + 1 rs <- c( rname_style, style_list$css.tspanner[tspanner_iterator] ) # Use a separator from the one above if this # at least the second spanner. Graphically this # appears as if underneath the group while it's # actually above but this merges into one line if (tspanner_iterator > 1) { rs %<>% c(style_list$css.tspanner.sep[tspanner_iterator - 1]) } if (first_row) { rs %<>% c(top_row_style) } table_str %<>% sprintf( "%s\n\t", ., total_columns, prGetStyle(rs), tspanner[tspanner_iterator] ) first_row <- FALSE } # Add the row group if any # and it's: # - first row # - the row belongs to the next row group rgroup_sep_style <- FALSE if (!is.null(rgroup) && (row_nr == 1 || row_nr > sum(n.rgroup[1:rgroup_iterator]))) { rgroup_iterator <- rgroup_iterator + 1 rs <- c(rname_style, style_list$css.rgroup[rgroup_iterator], `background-color` = style_list$col.rgroup[rgroup_iterator] ) # Use a separator from the one above if this # at least the second group. Graphically this # appears as if underneath the group while it's # actually above but this merges into one line if (rgroup_iterator > 1) { rs <- c( rs, style_list$css.rgroup.sep[rgroup_iterator - 1] ) } # Only add if there is anything in the group if (is.na(rgroup[rgroup_iterator]) == FALSE && rgroup[rgroup_iterator] != "") { if (first_row) { rs <- c( rs, top_row_style ) } rgroup_str <- prGetRgroupLine( x = x, total_columns = total_columns, rgroup = rgroup, rgroup_iterator = rgroup_iterator, cspan = cspan.rgroup[rgroup_iterator], rnames = rnames, style = rs, cgroup_spacer_cells = cgroup_spacer_cells, style_list = style_list, prepped_row_css = prepped_cell_css[row_nr, ] ) table_str %<>% paste(rgroup_str) first_row <- FALSE } else if (rgroup_iterator > 1 && style_list$css.rgroup.sep[rgroup_iterator - 1] != "") { # Add the separator if the rgroup wasn't added so that it's included in the regular cells rgroup_sep_style <- style_list$css.rgroup.sep[rgroup_iterator - 1] } } cell_style <- rs <- paste("background-color:", row_clrs[row_nr]) if (first_row) { rs %<>% c(top_row_style) cell_style %<>% c(top_row_style) } else if (rgroup_sep_style != FALSE) { rs %<>% c(rgroup_sep_style) } first_row <- FALSE if (row_nr == nrow(x)) { cell_style %<>% c(bottom_row_style) } if (row_nr %in% total) { cell_style %<>% c(style_list$css.total[which(row_nr == total)]) } if (prGetStyle(rs) == "") { table_str %<>% paste0("\n\t") } else { table_str %<>% sprintf( "%s\n\t", ., prGetStyle(rs) ) } if (!prSkipRownames(rnames)) { pdng <- style_list$padding.tspanner # Minor change from original function. If the group doesn't have # a group name then there shouldn't be any indentation if (!is.null(rgroup) && rgroup_iterator > 0 && is.na(rgroup[rgroup_iterator]) == FALSE && rgroup[rgroup_iterator] != "") { pdng %<>% paste0(style_list$padding.rgroup) } # The padding doesn't work well with the Word import - well nothing really works well with word... # table_str <- sprintf("%s\n\t\t", table_str, rnames[row_nr]) table_str %<>% paste(str_interp( "", list( STYLE = prGetStyle(c(rname_style, cell_style), align = prGetAlign(style_list$align, index = 1, style_list = style_list) ), PADDING = pdng, NAME = rnames[row_nr] ) ), sep = "\n\t\t" ) } cell_str <- prAddCells( rowcells = x[row_nr, ], cellcode = "td", style_list = style_list, style = cell_style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames) * 1, prepped_cell_css = prepped_cell_css[row_nr, ] ) table_str %<>% paste0(cell_str, "\n\t") } } # Close body table_str %<>% paste0("\n\t") if (!is.null(caption) & compatibility == "LibreOffice" & style_list$pos.caption %in% c("bottom", "below")) { table_str %<>% sprintf( "%s\n\t", ., total_columns, caption ) } # Add footer if (!is.null(tfoot)) { table_str %<>% sprintf( "%s\n\t") } # Close table table_str %<>% paste0("\n
") } else { table_str %<>% paste0("\n\t") } table_str %<>% paste0(caption, "
%s
%s${PADDING}${NAME}
%s
", ., total_columns ) # Add the body table_str %<>% paste0("\n\t", txtMergeLines(tfoot)) table_str %<>% paste0("
") # Fix indentation issue with pandoc v1.13 - can be overridden if you want to look at a pretty `cat()` if (!getOption("htmlTable.pretty_indentation", default = FALSE)) { table_str %<>% gsub("\t", "", .) } # HTML favors UTF-8 and thus the string should be encoded as utf8 table_str <- enc2utf8(table_str) class(table_str) <- c("htmlTable", class(table_str)) attr(table_str, "...") <- dots attr(table_str, "html") <- TRUE # Add html class if this is a table inside a notebook for inline output if (!getOption("htmlTable.skip_notebook", FALSE) && prIsNotebook()) { class(table_str) <- c("html", class(table_str)) } return(table_str) } #' @importFrom methods setClass setClass("htmlTable", contains = "character")htmlTable/R/tidyHtmlTable_helpers_checkUniqueness.r0000644000176200001440000000150514165130172022260 0ustar liggesusers# This checks to make sure that the mapping columns of the tidy dataset # uniquely specify a given value checkUniqueness <- function(tidyTableDataList) { tidyTableData <- do.call(cbind, tidyTableDataList) dupes <- tidyTableData %>% duplicated() if (sum(dupes) != 0) { core_msg <- paste0("The input parameters ", paste(paste0("\"", names(tidyTableData), "\""), collapse = ", "), " do not specify unique rows, have you forgotten one?.") duplicated_rows <- paste0("The following rows are duplicated: ", paste(which(dupes), collapse = ", ")) if (is.null(tidyTableDataList$rnames_unique)) { core_msg <- paste(core_msg, "Check if you intended to provide the rnames_unique (see the help page).") } stop(core_msg, "\n", duplicated_rows) } } htmlTable/R/htmlTable_style_handlers.R0000644000176200001440000003157213730316012017532 0ustar liggesusers#' Add/set css and other style options #' #' This function is a preprocessing step before applying the [htmlTable()] function. #' You use this to style your tables with HTML cascading style sheet features. #' #' The function stores the current theme (see [setHtmlTableTheme()]) + custom styles #' to the provided object as an [base::attributes()]. It is stored under the element #' `htmlTable.style` in the form of a list object. #' #' @section The `css.cell` argument: #' #' The `css.cell` parameter allows you to add any possible CSS style #' to your table cells. `css.cell` can be either a vector or a matrix. #' #' If `css.cell` is a *vector*, it's assumed that the styles should be repeated #' throughout the rows (that is, each element in css.cell specifies the style #' for a whole column of 'x'). #' #' In the case of `css.cell` being a *matrix* of the same size of the `x` argument, #' each element of `x` gets the style from the corresponding element in css.cell. Additionally, #' the number of rows of `css.cell` can be `nrow(x) + 1` so the first row of of `css.cell` #' specifies the style for the header of `x`; also the number of columns of `css.cell` #' can be `ncol(x) + 1` to include the specification of style for row names of `x`. #' #' Note that the `text-align` CSS field in the `css.cell` argument will be overriden #' by the `align` argument. #' #' Excel has a specific css-style, `mso-number-format` that can be used for improving the #' copy-paste functionality. E.g. the style could be written as: `css_matrix <- #' matrix( data = "mso-number-format:\"\\@\"", nrow = nrow(df), ncol = ncol(df))` #' #' @param x The object that you later want to pass into [htmlTable()]. #' @param align A character strings specifying column alignments, defaulting to `'c'` #' to center. Valid chars for alignments are l = left, c = center and r = right. You can also specify #' `align='c|c'` and other LaTeX tabular formatting. If you want to set the alignment of the #' rownames this string needst to be `ncol(x) + 1`, otherwise it automatically #' pads the string with a left alignment for the rownames. #' @param align.header A character strings specifying alignment for column header, #' defaulting to centered, i.e. `[paste][base::paste](rep('c',ncol(x)),collapse='')`. #' @param align.cgroup The justification of the `cgroups` #' @param css.rgroup CSS style for the rgroup, if different styles are wanted for each of the #' rgroups you can just specify a vector with the number of elements. #' @param css.rgroup.sep The line between different rgroups. The line is set to the TR element #' of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with #' the expected function. This is only used for rgroups that are printed. You can specify #' different separators if you give a vector of rgroup - 1 length (this is since the first #' rgroup doesn't have a separator). #' @param css.tspanner The CSS style for the table spanner. #' @param css.tspanner.sep The line between different spanners. #' @param css.total The css of the total row if such is activated. #' @param css.cell The css.cell element allows you to add any possible CSS style to your #' table cells. See section below for details. #' @param css.header The header style, not including the cgroup style #' @param css.header.border_bottom The header bottom-border style, e.g. `border-bottom: 1px solid grey` #' @param css.cgroup The same as `css.class` but for cgroup formatting. #' @param css.class The html CSS class for the table. This allows directing html #' formatting through [CSS](https://www.w3schools.com/Css/) #' directly at all instances of that class. *Note:* unfortunately the #' CSS is frequently ignored by word processors. This option #' is mostly inteded for web-presentations. #' @param css.table You can specify the the style of the table-element using this parameter #' @param pos.rowlabel Where the rowlabel should be positioned. This value can be `"top"`, #' `"bottom"`, `"header"`, or a integer between `1` and `nrow(cgroup) + 1`. The options #' `"bottom"` and `"header"` are the same, where the row label is presented at the same level as #' the header. #' @param pos.caption Set to `"bottom"` to position a caption below the table #' instead of the default of `"top"`. #' @param col.rgroup Alternating colors (zebra striping/banded rows) for each `rgroup`; one or two colors #' is recommended and will be recycled. #' @param col.columns Alternating colors for each column. #' @param padding.rgroup Generally two non-breakings spaces, i.e. `  `, but some #' journals only have a bold face for the rgroup and leaves the subelements unindented. #' @param padding.tspanner The table spanner is usually without padding but you may specify padding #' similar to `padding.rgroup` and it will be added to all elements, including the rgroup elements. #' This allows for a 3-level hierarchy if needed. #' @param spacer.celltype When using cgroup the table headers are separated through a empty #' HTML cell that is by default filled with ` ` (no-breaking-space) that prevents the cell #' from collapsing. The purpose of this is to prevent the headers underline to bleed into one #' as the underline is for the entire cell. You can alter this behavior by changing this option, #' valid options are `single_empty`, `skip`, `double_cell`. The `single_empty` is the default, #' the `skip` lets the header bleed into one and skips entirely, `double_cell` is for having #' two cells so that a vertical border ends up centered (specified using the `align` option). #' The arguments are matched internally using [base::match.arg] so you can specify only a part #' of the name, e.g. `"sk"` will match `"skip"`. #' @param spacer.css.cgroup.bottom.border Defaults to `none` and used for separating cgroup headers. #' Due to a browser bug this is sometimes ignored and you may therefore need to set this #' to `1px solid white` to enforce a white border. #' @param spacer.css If you want the spacer cells to share settings you can set it here #' @param spacer.content Defaults to ` ` as this guarantees that the cell is not collapsed #' and is highly compatible when copy-pasting to word processors. #' #' @return `x` with the style added as an attribute that the htmlTable then can use for formatting. #' @export #' #' @examples #' library(magrittr) #' matrix(1:4, ncol = 2) %>% #' addHtmlTableStyle(align = "c", css.cell = "background-color: orange;") %>% #' htmlTable(caption = "A simple style example") #' @rdname addStyles #' @family htmlTableStyle addHtmlTableStyle <- function(x, align = NULL, align.header = NULL, align.cgroup = NULL, # CSS stuff css.rgroup = NULL, css.rgroup.sep = NULL, css.tspanner = NULL, css.tspanner.sep = NULL, css.total = NULL, css.cell = NULL, css.cgroup = NULL, css.header = NULL, css.header.border_bottom = NULL, css.class = NULL, css.table = NULL, # Positions pos.rowlabel = NULL, pos.caption = NULL, # Colors col.rgroup = NULL, col.columns = NULL, # More alternatives padding.rgroup = NULL, padding.tspanner = NULL, spacer.celltype = NULL, spacer.css.cgroup.bottom.border = NULL, spacer.css = NULL, spacer.content = NULL) { style_list <- prGetAttrWithDefault(x, which = style_attribute_name, default = getHtmlTableTheme() ) style_list <- prValidateAndMergeStyles( org_style_list = style_list, styles_from_arguments = prGetArgumentList(match.call(), skip_elements = c("x")), overwrite = TRUE ) attr(x, style_attribute_name) <- style_list return(x) } #' @rdname addStyles appendHtmlTableStyle <- function(x, align = NULL, align.header = NULL, align.cgroup = NULL, # CSS stuff css.rgroup = NULL, css.rgroup.sep = NULL, css.tspanner = NULL, css.tspanner.sep = NULL, css.total = NULL, css.cell = NULL, css.cgroup = NULL, css.header = NULL, css.header.border_bottom = NULL, css.class = NULL, css.table = NULL, # Positions pos.rowlabel = NULL, pos.caption = NULL, # Colors col.rgroup = NULL, col.columns = NULL, # More alternatives padding.rgroup = NULL, padding.tspanner = NULL, spacer.celltype = NULL, spacer.css.cgroup.bottom.border = NULL, spacer.css = NULL, spacer.content = NULL) { style_list <- prGetAttrWithDefault(x, which = style_attribute_name, default = getHtmlTableTheme() ) style_list <- prValidateAndMergeStyles( org_style_list = style_list, styles_from_arguments = prGetArgumentList(match.call(), skip_elements = c("x")), overwrite = FALSE ) attr(x, style_attribute_name) <- style_list return(x) } #' Get style options for object #' #' A wrap around the [base::attr()] that retrieves the style #' attribute used by [htmlTable()] (`htmlTable.style`). #' #' @param x The object intended for [htmlTable()]. #' @return A `list` if the attribute exists, otherwise `NULL` #' @export #' @examples #' library(magrittr) #' #' mx <- matrix(1:4, ncol = 2) #' colnames(mx) <- LETTERS[1:2] #' mx %>% #' addHtmlTableStyle(align = "l|r") %>% #' getHtmlTableStyle() getHtmlTableStyle <- function(x) { attr(x, style_attribute_name, exact = TRUE) } #' Check if object has a style set to it #' #' If the attribute `htmlTable.style` is set it will check if #' the `style_name` exists and return a `logical`. #' #' @param x The object intended for [htmlTable()]. #' @param style_name A string that contains the style name. #' @return `logical` `TRUE` if the attribute and style is not `NULL` #' @export #' @family htmlTableStyle #' @examples #' library(magrittr) #' #' mx <- matrix(1:4, ncol = 2) #' colnames(mx) <- LETTERS[1:2] #' mx %>% #' addHtmlTableStyle(align = "l|r") %>% #' hasHtmlTableStyle("align") hasHtmlTableStyle <- function(x, style_name) { style <- getHtmlTableStyle(x) if (is.null(style)) { return(FALSE) } if (is.null(style[[style_name]])) { return(FALSE) } return(TRUE) } style_attribute_name <- "htmlTable.style" #' @importFrom stringr str_replace prValidateAndMergeStyles <- function(org_style_list, styles_from_arguments, overwrite) { assert_list(org_style_list) assert_list(styles_from_arguments) styles_from_arguments <- Filter(Negate(is.null), styles_from_arguments) if (length(styles_from_arguments) == 0) { return(org_style_list) } default_args <- list("pos.caption" = c("top", "bottom", "below"), "spacer.celltype" = c("single_empty", "skip", "double_cell")) style_list <- org_style_list for (n in names(styles_from_arguments)) { # We only merge css components when we're not replacing everything if (startsWith(n, "css") && n != "css.class" && !overwrite) { # The second argument takes precedence as the final style when conflicts arise style_list[[n]] <- prGetStyle(style_list[[n]], styles_from_arguments[[n]]) } else if (n %in% names(default_args)) { tryCatch({ style_list[[n]] <- match.arg(arg = styles_from_arguments[[n]], choices = default_args[[n]]) }, error = function(x) { x %>% extract2("message") %>% str_replace("^'arg'", sprintf("'%s'", argument_name = n)) %>% stop() }) } else { style_list[[n]] <- styles_from_arguments[[n]] } } return(style_list) } prGetAttrWithDefault <- function(x, which, default = NA) { if (which %in% names(attributes(x))) { return(attr(x, which)) } return(default) } htmlTable/R/vector2string.R0000644000176200001440000000225113701421460015323 0ustar liggesusers#' Collapse vector to string #' #' Merges all the values and outputs a string #' formatted as '1st element', '2nd element', ... #' #' @param x The vector to collapse #' @param collapse The string that separates each element #' @param quotation_mark The type of quote to use #' @return A string with `', '` separation #' @importFrom stringr str_replace_all #' @examples #' vector2string(1:4) #' vector2string(c("a", "b'b", "c")) #' vector2string(c("a", "b'b", "c"), quotation_mark = '"') #' @export vector2string <- function(x, quotation_mark = "'", collapse = sprintf("%s, %s", quotation_mark, quotation_mark)) { paste0( quotation_mark, paste(sapply(x, function(single_x) { str_replace_all( single_x, quotation_mark, sprintf("\\\\%s", quotation_mark) ) }, USE.NAMES = FALSE ), collapse = collapse ), quotation_mark ) } htmlTable/R/htmlTable_render_getRgroupLine.R0000644000176200001440000001143013730316012020626 0ustar liggesusers#' Gets the number of `rgroup` HTML line #' #' @param total_columns The total number of columns including the `rowlabel` and the #' spacer cells #' @param cspan The column span of the current `rgroup` #' @param style The css style corresponding to the `rgroup` css style that includes #' the color specific for the `rgroup`, i.e. `col.rgroup`. #' @param cgroup_spacer_cells The vector indicating the position of the `cgroup` #' spacer cells #' @param prepped_row_css The `css.cell` information for this particular row. #' @param rgroup_iterator An integer indicating the `rgroup` #' @inheritParams htmlTable #' @keywords internal prGetRgroupLine <- function(x, total_columns = NULL, rgroup = NULL, rgroup_iterator = NULL, cspan = NULL, rnames = NULL, style = NULL, cgroup_spacer_cells = NULL, style_list = NULL, prepped_row_css = NULL) { ret_str <- "" rgroup_elmnt <- rgroup[rgroup_iterator] add_elmnt <- prAttr4RgroupAdd( rgroup = rgroup, rgroup_iterator = rgroup_iterator, no_cols = ncol(x) ) ## this will allow either css.rgroup or col.rgroup to ## color the rgroup label rows if (is.numeric(cspan) && cspan < ncol(x) || !is.null(add_elmnt)) { filler_cells <- rep("", ncol(x)) if (!is.null(add_elmnt)) { if (!is.numeric(cspan)) { cspan <- ncol(x) + 1 * !prSkipRownames(rnames) } if (length(add_elmnt) > 1) { if (is.null(names(add_elmnt))) { stop( "The rgroup 'add' attribute element no '", rgroup_iterator, "'", " either be a single element or a named list/vector" ) } add_pos <- as.integer(names(add_elmnt)) if (any(is.na(add_pos)) || any(add_pos < 1) || any(add_pos > ncol(x))) { stop( "You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", " the attribute seeems to be a list but the names are invalid", " '", paste(names(add_elmnt), collapse = "', '"), "'", " they should be integers between 1 and ", ncol(x) ) } first_pos <- min(add_pos) - 1 + 1 * !prSkipRownames(rnames) if (is.null(cspan)) { cspan <- first_pos } else { cspan <- min( cspan, first_pos ) } for (ii in 1:length(add_pos)) { filler_cells[add_pos[ii]] <- add_elmnt[[ii]] } } else if (length(add_elmnt) == 1) { if (is.null(names(add_elmnt)) || names(add_elmnt) == "last") { add_pos <- ncol(x) } else { add_pos <- as.integer(names(add_elmnt)) if (is.na(add_pos) || add_pos < 1 || add_pos > ncol(x)) { stop( "You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", " the attribute seeems to be a list but the name is invalid", " '", names(add_elmnt), "'", " it should be an integer between 1 and ", ncol(x) ) } } first_pos <- add_pos - 1 + 1 * !prSkipRownames(rnames) if (is.null(cspan)) { cspan <- first_pos } else { cspan <- min( cspan, first_pos ) } filler_cells[add_pos] <- add_elmnt } else { stop( "The attribute to the rgroup '", rgroup_elmnt, "'", " does not have a length!" ) } } true_span <- cspan + sum(cgroup_spacer_cells[0:(cspan - 1 * !prSkipRownames(rnames))]) * prGetEmptySpacerCellSize(style_list = style_list) ret_str %<>% sprintf( "%s\n\t%s", ., true_span, prGetStyle(style), paste0( style_list$padding.tspanner, rgroup_elmnt ) ) cols_left <- ncol(x) - (cspan - 1 * !prSkipRownames(rnames)) cell_str <- prAddCells( rowcells = filler_cells, cellcode = "td", style_list = style_list, style = style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames) * 1, offset = ncol(x) - cols_left + 1, prepped_cell_css = prepped_row_css ) ret_str %<>% paste0(cell_str) ret_str %<>% paste0("") } else { ret_str %<>% sprintf( "%s\n\t%s", ., total_columns, prGetStyle(style), paste0( style_list$padding.tspanner, rgroup_elmnt ) ) } return(ret_str) } htmlTable/R/htmlTable_helpers_mergeClr.R0000644000176200001440000000201213701421460017761 0ustar liggesusers#' Merges multiple colors #' #' Uses the [`colorRampPalette()`][grDevices::colorRamp] for merging colors. #' *Note:* When merging more than 2 colors the order in the color #' presentation matters. Each color is merged with its neigbors before #' merging with next. If there is an uneven number of colors the middle #' color is mixed with both left and right side. #' #' @param clrs The colors #' @return `character` A hexadecimal color #' @import magrittr #' @keywords internal #' @importFrom grDevices colorRampPalette #' @importFrom utils head prMergeClr <- function(clrs) { if (length(clrs) == 1) { return(clrs) } if (length(clrs) == 2) { return(colorRampPalette(clrs)(3)[2]) } split_lngth <- floor(length(clrs) / 2) left <- head(clrs, split_lngth) right <- tail(clrs, split_lngth) if (length(clrs) %% 2 == 1) { left %<>% c(clrs[split_lngth + 1]) right %<>% c(clrs[split_lngth + 1], .) } left <- prMergeClr(left) right <- prMergeClr(right) return(prMergeClr(c(left, right))) } htmlTable/R/tidyHtmlTable_helpers_safeLoadPkg.R0000644000176200001440000000037413701421460021244 0ustar liggesusers# You need the suggested package for this function safeLoadPkg <- function(pkg) { if (!requireNamespace(pkg, quietly = TRUE)) { stop("The package ", pkg, " is needed for this function to work. Please install it.", call. = FALSE ) } } htmlTable/R/htmlTable_theme.R0000644000176200001440000002160313730316012015606 0ustar liggesusers#' Set or update theme for [htmlTable()] #' #' The theme guides many of the non-data objects visual appearance. The #' theme can be over-ridden by settings for each table. Too get a more complete #' understanding of the options, see [addHtmlTableStyle()]. #' #' @section Theme options: #' #' The styles available are: #' #' * `standard`: The traditional standard style used in [htmlTable()] since the early days #' * `Google docs`: A style that is optimized for copy-pasting into documents on Google drive. This #' is geared towards minimal padding and margins so that the table is as dense as possible. #' * `blank`: Just as the name suggests the style is completly empty in terms of CSS. Positions #' for rowlabel and caption are set to `bottom` as these cannot be blank. #' #' You can also provide your own style. Each style should be a names vector, e.g. `c(width = "100px", color = "red")` #' or just a real css string, `width: 100px; color: red;`. #' #' @param theme A `list` containing all the styles or a `string` that is matched to some of the preset style (See details #' below in the *Theme options* section). *Note*: the full name of the theme is not required as they are matched #' using [base::match.arg()]. #' @inheritParams addHtmlTableStyle #' #' @return An invisible `list` with the new theme #' @export #' @md #' #' @examples #' \dontrun{ #' setHtmlTableTheme("Google", align = "r") #' } setHtmlTableTheme <- function(theme = NULL, align = NULL, align.header = NULL, align.cgroup = NULL, # CSS stuff css.rgroup = NULL, css.rgroup.sep = NULL, css.tspanner = NULL, css.tspanner.sep = NULL, css.total = NULL, css.cell = NULL, css.cgroup = NULL, css.header = NULL, css.header.border_bottom = NULL, css.class = NULL, css.table = NULL, # Positions pos.rowlabel = NULL, pos.caption = NULL, # Colors col.rgroup = NULL, col.columns = NULL, # More alternatives padding.rgroup = NULL, padding.tspanner = NULL, spacer.celltype = NULL, spacer.css.cgroup.bottom.border = NULL, spacer.css = NULL, spacer.content = NULL) { if (!is.null(theme)) { if (is.character(theme)) { newTheme <- prGetThemeListObject(theme_name = theme) } else if (is.list(theme)) { if (any(names(theme) == "")) { stop("Theme contains unnamed elements") } prAssertStyleNames(names(theme), "You have invalid theme names.") newTheme <- theme } else { stop("The theme must either be a list or a valid predefined theme name") } } else { newTheme <- getHtmlTableTheme() } newTheme <- prValidateAndMergeStyles( org_style_list = newTheme, styles_from_arguments = prGetArgumentList(match.call(), c("", "theme")), overwrite = TRUE ) prAssertStyles(newTheme) options(htmlTable.theme = newTheme) return(invisible(newTheme)) } prGetArgumentList <- function(args, skip_elements) { if (!is.list(args)) { args <- as.list(args) } args <- args[Filter(function(x) !(x %in% skip_elements | x == ""), names(args))] Map(function(arg) { if (is.language(arg)) { value <- tryCatch(eval(arg), error = function(e) { for (i in 1:sys.nframe()) { value <- tryCatch(eval(arg, envir = parent.frame(n = i)), error = function(x) NULL) if (!is.null(value)) return(value) } }) if (is.null(value)) { stop("Could not find argument: ", as.character(arg)) } return(value) } return(arg) }, args) } #' Retrieve the [htmlTable()] theme list #' #' A wrapper for a [`getOption("htmlTable.theme")()`][base::options] call that #' returns the standard theme unless one is set. #' #' @return `list` with the styles to be applied to the table #' @export #' #' @examples #' getHtmlTableTheme() getHtmlTableTheme <- function() { getOption("htmlTable.theme", default = prGetThemeListObject(theme_name = "standard") ) } prGetThemeListObject <- function(theme_name = c("standard", "Google docs", "blank")) { theme_name <- match.arg(theme_name) common_non_css_elements <- list( align = "c", align.header = "c", # colors col.rgroup = "none", col.columns = "none", # More alternatives padding.rgroup = "  ", padding.tspanner = "", spacer.celltype = "single_empty", spacer.css.cgroup.bottom.border = "none", spacer.css = "", spacer.content = " " ) if (theme_name == "standard") { # This list is the reference with all the available theme elements standard_theme <- list( css.rgroup = getOption("htmlTable.css.rgroup", default = "font-weight: 900;"), css.rgroup.sep = getOption("htmlTable.css.rgroup.sep", default = ""), css.tspanner = getOption("htmlTable.css.tspanner", default = "font-weight: 900; text-align: left;" ), css.tspanner.sep = getOption("htmlTable.css.tspanner.sep", default = "border-top: 1px solid #BEBEBE;" ), css.total = getOption("htmlTable.css.total", default = "border-top: 1px solid #BEBEBE; font-weight: 900;" ), css.cell = getOption("htmlTable.css.cell", default = ""), css.cgroup = getOption("htmlTable.css.cgroup", default = ""), css.header = getOption("htmlTable.css.header", default = "font-weight: 900"), css.header.border_bottom = getOption("htmlTable.css.header.border_bottom", default = "border-bottom: 1px solid grey"), css.class = getOption("htmlTable.css.class", default = "gmisc_table"), css.table = getOption("htmlTable.css.table", default = "margin-top: 1em; margin-bottom: 1em;"), # Positions pos.rowlabel = "bottom", pos.caption = "top" ) return(prExtendlist( base = common_non_css_elements, extensions = standard_theme )) } if (theme_name == "Google docs") { doc_theme <- list( css.rgroup = getOption("htmlTable.css.rgroup", default = "font-weight: normal; margin: 0; padding: 0;"), css.rgroup.sep = getOption("htmlTable.css.rgroup.sep", default = ""), css.tspanner = getOption("htmlTable.css.tspanner", default = "font-weight: 900; text-align: left;" ), css.tspanner.sep = getOption("htmlTable.css.tspanner.sep", default = "border-top: 1px solid #BEBEBE;" ), css.total = getOption("htmlTable.css.total", default = "border-top: 1px solid #BEBEBE; font-weight: 900;" ), css.cell = getOption("htmlTable.css.cell", default = "margin: 0; padding: 0;"), css.cgroup = getOption("htmlTable.css.cgroup", default = "margin: 0; padding: 0; vertical-align: middle;"), css.header = getOption("htmlTable.css.header", default = "margin: 0; padding: 0; font-weight: 900; vertical-align: middle;"), css.header.border_bottom = getOption("htmlTable.css.header.border_bottom", default = "border-bottom: 1px solid grey"), css.class = getOption("htmlTable.css.class", default = "gmisc_table"), css.table = getOption("htmlTable.css.table", default = "margin-top: 1em; margin-bottom: 1em;"), spacer.celltype = "double_cell", spacer.css.cgroup.bottom.border = "1px solid white", spacer.content = "", spacer.css = "width: 2px;", # Positions pos.rowlabel = "bottom", pos.caption = "bottom" ) return(prExtendlist( base = common_non_css_elements, extensions = doc_theme )) } if (theme_name == "blank") { blank_theme <- list( css.rgroup = "", css.rgroup.sep = "", css.tspanner = "", css.tspanner.sep = "", css.total = "", css.cell = "", css.cgroup = "", css.header = "", # Not blank as it is part of core table css.header.border_bottom = "border-bottom: 1px solid grey", css.class = "", css.table = "", # Positions pos.rowlabel = "bottom", pos.caption = "bottom" ) return(prExtendlist( base = common_non_css_elements, extensions = blank_theme )) } } prExtendlist <- function(base, extensions) { for (n in names(extensions)) { base[[n]] <- extensions[[n]] } return(base) } htmlTable/R/tidyHtmlTable_helpers_removeRowsWithNA.r0000644000176200001440000000165313701421460022350 0ustar liggesusers# Removes rows containing NA values in any mapped columns from the tidy dataset removeRowsWithNA <- function(tidyTableDataList, skip_removal_warning = FALSE) { tidyTableData <- tidyTableDataList %>% tibble::as_tibble() hasNA <- tidyTableData %>% is.na() naPerRow <- hasNA %>% rowSums() keepIdx <- naPerRow == 0 removed <- sum(naPerRow > 0) if (removed != 0) { naPerCol <- hasNA %>% colSums() naColumns <- colnames(hasNA)[naPerCol > 0] if (!skip_removal_warning) { warning(paste0( "NA values were detected in the following columns of ", "the tidy dataset: ", paste(naColumns, collapse = ", "), ". ", removed, " row(s) in the tidy dataset were removed." )) } } return(sapply(tidyTableDataList, function(x) { if (is.data.frame(x)) { return(x %>% dplyr::filter(keepIdx)) } return(x[keepIdx]) }, simplify = FALSE )) } htmlTable/R/htmlTable_helpers_isNotebook.R0000644000176200001440000000177313701421460020352 0ustar liggesusers#' Detects if the call is made from within an RStudio Rmd file or a file #' with the html_notebook output set. #' @importFrom rstudioapi isAvailable getActiveDocumentContext #' @keywords internal prIsNotebook <- function() { if (!isAvailable()) { return(FALSE) } ctxt <- getActiveDocumentContext() if (grepl("\\.Rmd$", ctxt$path)) { return(prCheck4output2console(ctxt)) } # Look for html_notebook within the header if the file hasn't been saved contents <- ctxt$contents header <- grep("^---$", contents) if (length(header) == 2) { return(any(grepl( "html_notebook$", contents[min(header):max(header)] ))) } return(FALSE) } prCheck4output2console <- function(ctxt) { contents <- ctxt$contents header_boundary <- grep("^---$", contents) if (length(header_boundary) <= 1) { # Play it safe if the header is invalid return(TRUE) } header <- contents[header_boundary[1]:header_boundary[2]] return(!any(grepl("chunk_output_type: console", header))) }htmlTable/R/htmlTable_helpers_getRowlabelPos.R0000644000176200001440000000236713701421460021167 0ustar liggesusers #' Gets the rowlabel position #' #' @inheritParams htmlTable #' @return `integer` Returns the position within the header rows #' to print the `rowlabel` argument #' @keywords internal #' @family hidden helper functions for htmlTable prGetRowlabelPos <- function(cgroup = NULL, pos.rowlabel, header = NULL) { no_cgroup_rows <- ifelse(!is.null(cgroup), nrow(cgroup), 0 ) no_header_rows <- no_cgroup_rows + (!is.null(header)) * 1 if (is.numeric(pos.rowlabel)) { if (pos.rowlabel < 1) { stop("You have specified a pos.rowlabel that is less than 1: ", pos.rowlabel) } else if (pos.rowlabel > no_header_rows) { stop( "You have specified a pos.rowlabel that more than the max limit, ", no_header_rows, ", you have provided: ", pos.rowlabel ) } } else { pos.rowlabel <- tolower(pos.rowlabel) if (pos.rowlabel %in% c("top")) { pos.rowlabel <- 1 } else if (pos.rowlabel %in% c("bottom", "header")) { pos.rowlabel <- no_header_rows } else { stop( "You have provided an invalid pos.rowlabel text,", " only 'top', 'bottom' or 'header' are allowed,", " can't interpret '", pos.rowlabel, "'" ) } } return(pos.rowlabel) } htmlTable/R/htmlTable_helpers_getStyle.R0000644000176200001440000000711414517434555020050 0ustar liggesusers #' Gets the CSS style element #' #' A function for checking, merging, and more #' with a variety of different style formats. #' #' @param ... Styles can be provided as `vector`, `named vector`, or `string`. #' If you provide a name, e.g. `background: blue`, `align="center"`, #' the function will convert the `align` into proper `align: center`. #' @return `string` Returns the codes merged into one string with #' correct CSS ; and : structure. #' @keywords internal #' @import magrittr #' @family hidden helper functions for htmlTable prGetStyle <- function(...) { mergeNames <- function(sv) { sv <- sv[!is.na(sv)] if (!is.null(names(sv))) { sv <- mapply(function(n, v) { if (n == "") { return(v) } paste0(n, ": ", v) }, n = names(sv), v = sv, USE.NAMES = FALSE) } return(sv) } spltNames <- function(sv) { ret_sv <- c() for (i in 1:length(sv)) { ret_sv <- c( ret_sv, # Split on the ; in case it is not at the end/start unlist(strsplit(sv[i], "\\b;(\\b|\\W+)", perl = TRUE)) ) } return(ret_sv) } styles <- c() dots <- list(...) dots <- dots[sapply(dots, function(x) any(!is.na(x) & !is.null(x)))] if (length(dots) == 0) { return("") } for (i in 1:length(dots)) { element <- dots[[i]] if (length(element) == 1) { if (element == "") { next } if (!grepl("\\b[:](\\b|\\W+)", element, perl = TRUE)) { if (!is.null(names(element))) { element <- paste0(names(element), ": ", element) } else if (!is.null(names(dots)) && names(dots)[i] != "") { element <- paste0(names(dots)[i], ": ", element) } else if (element != "none") { stop( "The style should be formatted according to 'style_name: value'", " you have provided style '", element, "'" ) } } styles %<>% c(element) } else { if (!is.null(names(element))) { element <- mergeNames(element) } styles <- c( styles, spltNames(element) ) } } if (!all(grepl("^[^:]+:.+", styles))) { stop( "Invalid styles detected, one or more styles lack the needed style 'name: value': ", paste(paste0("'", styles[!grepl("^[^:]+:.+", styles)], "'"), collapse = ", ") ) } # Remove empty background colors - sometimes a background color appears with # just background-color:; for some unknown reason if (any(grepl("^background-color:( none|[ ]*;*$)", styles))) { styles <- styles[-grep("^background-color:( none|[ ]*;*$)", styles)] } # Merge background colors if (sum(grepl("^background-color:", styles)) > 1) { clrs <- styles[grep("^background-color:", styles)] clrs <- gsub("^background-color:[ ]*([^;]+);*", "\\1", clrs) clr <- prMergeClr(clrs) # Pick a color merge styles <- styles[-grep("^background-color:", styles)] styles <- c( styles, paste0("background-color: ", clr) ) } style_names <- gsub("^([^:]+).+", "\\1", styles) if (!any(duplicated(style_names))) { unique_styles <- styles } else { # Only select the last style if two of the same type # exist. This in order to avoid any conflicts. unique_styles <- c() for (n in unique(style_names)) { unique_styles <- c( unique_styles, styles[max(which(n == style_names))] ) } } unique_styles <- sapply(unique_styles, prAddSemicolon2StrEnd, USE.NAMES = FALSE) paste(unique_styles, collapse = " ") } htmlTable/R/concatHtmlTables.R0000644000176200001440000000204214165130172015737 0ustar liggesusers#' Function for concatenating [htmlTable()]s #' #' @param tables A list of [htmlTable()]s to be concatenated #' @param headers Either a string or a vector of strings that function as #' a header for each table. If none is provided it will use the names of #' the table list or a numeric number. #' @return [htmlTable()] class object #' @example inst/examples/concatHtmlTables_example.R #' @export concatHtmlTables <- function(tables, headers = NULL) { assert_list(tables) if (is.null(headers)) { if (!is.null(names(tables))) { headers = sprintf("

%s

", names(tables)) } else { headers = sprintf("

Table no. %d

", 1:length(tables)) } } else { headers = rep(headers, length.out = length(tables)) } ret = paste(headers[1], tables[[1]]) for (i in 2:length(tables)) { ret = paste0( ret, headers[i], tables[[i]] ) } # Copy all the attributes from the first table attributes(ret) <- attributes(tables[[1]]) class(ret) <- c('htmlTable', class(tables[[1]])) return(ret) } htmlTable/R/htmlTable_helpers_prepareAlign.R0000644000176200001440000000277213725113315020652 0ustar liggesusers#' Prepares the align to match the columns #' #' The alignment may be tricky and this function therefore simplifies #' this process by extending/shortening the alignment to match the #' correct number of columns. #' #' @param default_rn The default rowname alignment. This is an option #' as the header uses the same function and there may be differences in #' how the alignments should be implemented. #' @keywords internal #' @family hidden helper functions for htmlTable #' @inheritParams htmlTable prPrepareAlign <- function(align, x, rnames, default_rn = "l") { assert_character(align) if (length(align) > 1) { align <- paste(align, collapse = "") } segm_rgx <- "[^lrc]*[rlc][^lrc]*" no_elements <- length(strsplit(align, split = segm_rgx)[[1]]) no_cols <- ifelse(is.null(dim(x)), x, ncol(x)) if (!prSkipRownames(rnames)) { no_cols <- no_cols + 1 if (no_elements < no_cols) { align <- paste0(default_rn, align) } } res_align <- align align <- "" for (i in 1:no_cols) { rmatch <- regexpr(segm_rgx, res_align) tmp_lrc <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) align <- paste0( align, tmp_lrc ) if (nchar(res_align) < 1 && i != no_cols) { align <- paste0( align, paste(rep(tmp_lrc, times = no_cols - i), collapse = "") ) break } } structure(align, n = no_cols, class = class(align) ) } htmlTable/R/htmlTable_render_prAddEmptySpacerCell.R0000644000176200001440000000422313730316012022051 0ustar liggesusers#' Add an empty cell #' #' #' Depending on the `spacer.celltype` set in [addHtmlTableStyle()] we #' will use different spacer cells. #' #' @param cell_style The style of the current cell that should be applied to all cells #' @param align_style The style from [prGetAlign()] #' @param cell_tag What HTML tag to use #' @param colspan The number of rows each tag should span #' #' @return `string` #' @keywords internal #' @inheritParams htmlTable #' @family hidden helper functions for htmlTable #' @importFrom stringr str_interp str_replace prAddEmptySpacerCell <- function(x, style_list, cell_style, align_style, cell_tag = c("td", "th"), colspan = 1) { str_to_append <- switch(style_list$spacer.celltype, single_empty = "<${TAG} style='${CELL_STYLE}' colspan=${COLSPAN}>${CONTENT}", skip = "", double_cell = paste("<${TAG} style='${CELL_STYLE}${CELL_STYLE_BORDER}' colspan=${COLSPAN}>${CONTENT}", "<${TAG} style='${CELL_STYLE}' colspan=${COLSPAN}>${CONTENT}")) if (is.null(str_to_append)) { stop("The cell style has not been implemented") } border_style = "" if (attr(align_style, "has_border")) { border_style = paste("border-right:", attr(align_style, "border_style")$default) } variables <- list(TAG = match.arg(cell_tag), CELL_STYLE = prGetStyle(style_list$spacer.css, cell_style), COLSPAN = colspan, CONTENT = style_list$spacer.content, CELL_STYLE_BORDER = border_style) str_to_append %<>% str_interp(variables) paste0(x, str_to_append) } prGetEmptySpacerCellSize <- function(style_list) { no <- switch(style_list$spacer.celltype, single_empty = 1, skip = 0, double_cell = 2) if (is.null(no)) { stop("The cell style has not been implemented") } return(no) }htmlTable/R/tidyHtmlTable_helpers_getColTbl.R0000644000176200001440000000051113701421460020734 0ustar liggesusersgetColTbl <- function(x) { out <- prExtractElementsAndConvertToTbl(x, elements = c("cgroup", "header")) %>% dplyr::arrange_all() %>% # This is necessary in order to not generate NA values when setting # hidden elements to "" dplyr::mutate_if(is.factor, as.character) out$c_idx <- 1:nrow(out) return(out) } htmlTable/R/tidyHtmlTable_helpers_innerJoinByCommonCols.r0000644000176200001440000000041613701421460023341 0ustar liggesusers#' A simple function for joining two tables by their #' intersected columns #' #' @param x `data.frame` #' @param y `data.frame` #' @return `data.frame` innerJoinByCommonCols <- function(x, y) { by <- intersect(names(x), names(y)) dplyr::inner_join(x, y, by = by) } htmlTable/R/tidyHtmlTable_helpers_simplify_arg_list.R0000644000176200001440000000027713701421460022606 0ustar liggesusers# Converts arguments from ... into a list and removes those that have been set # to NULL simplify_arg_list <- function(...) { x <- list(...) idx <- sapply(x, is.null) return(x[!idx]) } htmlTable/R/data-SCB.R0000644000176200001440000000070514517434555014047 0ustar liggesusers#' Average age in Sweden #' #' For the vignettes there is a dataset downloaded by using the #' `get_pxweb_data()` call. The data is from #' SCB ([Statistics Sweden](https://www.scb.se//)) and downloaded #' using the [pxweb package](https://github.com/rOpenGov/pxweb): #' #' @example inst/examples/data-SCB_example.R #' #' @name SCB #' @docType data #' @author Max Gordon \email{max@@gforge.se} #' @references #' @keywords data NULLhtmlTable/R/txtFrmt_round.R0000644000176200001440000001665114165130172015402 0ustar liggesusers#' A convenient rounding function #' #' Regular round often looses trailing 0:s as these are truncated, this function #' converts everything to strings with all 0:s intact so that tables have the #' correct representation, e.g. `txtRound(1.01, digits = 1)` turns into `1.0`. #' #' @param x The value/vector/data.frame/matrix to be rounded #' @param digits The number of digits to round each element to. For `matrix` #' or `data.frame` input you can provide a `vector`/`list`. An unnamed `vector`/`list` #' must equal the length of the columns to round. If you provide a named vector you #' can provide specify per column the number of digits, and then use `.default` #' for those columns that we don't need to have separate values for. #' @param digits.nonzero The number of digits to keep if the result is close to #' zero. Sometimes we have an entire table with large numbers only to have a #' few but interesting observation that are really interesting #' @param txt.NA The string to exchange `NA` with #' @param dec The decimal marker. If the text is in non-English decimal #' and string formatted you need to change this to the appropriate decimal #' indicator. The option for this is `htmlTable.decimal_marker`. #' @param scientific If the value should be in scientific format. #' @param txtInt_args A list of arguments to pass to [txtInt()] if that is to be #' used for large values that may require a thousands separator. The option #' for this is `htmlTable.round_int`. If `TRUE` it will activate the `txtInt` #' functionality. #' @param ... Passed to next method #' @return `matrix/data.frame` #' #' @examples #' # Basic usage #' txtRound(1.023, digits = 1) #' # > "1.0" #' #' txtRound(pi, digits = 2) #' # > "3.14" #' #' txtRound(12344, digits = 1, txtInt_args = TRUE) #' # > "12,344.0" #' #' @export #' @rdname txtRound #' @importFrom stringr str_split str_replace #' @family text formatters txtRound <- function(x, ...){ UseMethod("txtRound") } #' @export #' @rdname txtRound txtRound.default = function(x, digits = 0, digits.nonzero = NA, txt.NA = "", dec = getOption("htmlTable.decimal_marker", default = "."), scientific = NULL, txtInt_args = getOption("htmlTable.round_int", default = NULL), ...){ if (length(digits) != 1 & length(digits) != length(x)) stop("You have ", length(digits), " digits specifications but a vector of length ", length(x), ": ", paste(x, collapse = ", ")) if (isTRUE(txtInt_args)) { txtInt_args = getOption("htmlTable.round_int", default = list()) } if (length(x) > 1) { return(mapply(txtRound.default, x = x, digits = digits, digits.nonzero = digits.nonzero, txt.NA = txt.NA, dec = dec, txtInt_args = rep(list(txtInt_args), times = length(x)), ...)) } if (!is.na(digits.nonzero)) { if (!is.numeric(digits.nonzero) || floor(digits.nonzero) != digits.nonzero ) { stop("The digits.nonzero should be an integer, you provided: ", digits.nonzero) } if (digits.nonzero < digits) { stop("The digits.nonzero must be larger than digits, as it is used for allowing more 0 when encountering small numbers.", " For instance, if we have 10.123 we rarely need more than 10.1 in form of digits while a for a small number", " such as 0.00123 we may want to report 0.001 (i.e. digits = 1, digits.nonzero = 3)") } } dec_str <- sprintf("^[^0-9\\%s-]*([\\-]{0,1}(([0-9]*|[0-9]+[ 0-9]+)[\\%s]|)[0-9]+(e[+]{0,1}[0-9]+|))(|[^0-9]+.*)$", dec, dec) if (is.na(x)) return(txt.NA) if (!is.numeric(x) && !grepl(dec_str, x)) return(x) if (is.character(x) && grepl(dec_str, x)) { if (dec != ".") x <- gsub(dec, ".", x) if (grepl("[0-9.]+e[+]{0,1}[0-9]+", x) && is.null(scientific)) { scientific <- TRUE } # Select the first occurring number # remove any spaces indicating thousands # and convert to numeric x <- sub(dec_str, "\\1", x) %>% gsub(" ", "", .) %>% as.numeric } if (!is.na(digits.nonzero)) { decimal_position <- floor(log10(abs(x))) if (decimal_position < -digits && decimal_position >= -digits.nonzero) { digits <- -decimal_position } } if (round(x, digits) == 0) x <- 0 if (!is.null(scientific) && scientific) { x <- round(x, digits) return(format(x, scientific = TRUE)) } ret <- sprintf(paste0("%.", digits, "f"), x) if (is.null(txtInt_args)) { return(ret) } stopifnot(is.list(txtInt_args)) separator <- str_replace(ret, "^[0-9]*([.,])[0-9]*$", "\\1") # There is no decimal if (separator == ret) { int_section <- as.numeric(ret) txtInt_args$x <- int_section return(do.call(txtInt, txtInt_args)) } ret_sections <- str_split(ret, paste0("[", separator, "]"))[[1]] if (length(ret_sections) == 1) { return(ret) } if (length(ret_sections) != 2) { return(ret) } int_section <- as.numeric(ret_sections[1]) txtInt_args$x <- int_section int_section <- do.call(txtInt, txtInt_args) return(paste0(int_section, separator, ret_sections[2])) } #' @rdname txtRound #' @export txtRound.table <- function(x, ...){ if (is.na(ncol(x))) { dim(x) <- c(1, nrow(x)) } return(txtRound.matrix(x, ...)) } #' @rdname txtRound #' @param excl.cols Columns to exclude from the rounding procedure when provided a matrix. #' This can be either a number or regular expression. Skipped if `x` is a vector. #' @param excl.rows Rows to exclude from the rounding procedure when provided a matrix. #' This can be either a number or regular expression. #' @export #' @examples #' #' # Using matrix #' mx <- matrix(c(1, 1.11, 1.25, #' 2.50, 2.55, 2.45, #' 3.2313, 3, pi), #' ncol = 3, byrow=TRUE) #' txtRound(mx, digits = 1) #' #> [,1] [,2] [,3] #' #> [1,] "1.0" "1.1" "1.2" #' #> [2,] "2.5" "2.5" "2.5" #' #> [3,] "3.2" "3.0" "3.1" txtRound.matrix <- function(x, digits = 0, excl.cols = NULL, excl.rows = NULL, ...){ if (length(dim(x)) > 2) stop("The function only accepts vectors/matrices/data.frames as primary argument") rows <- 1L:nrow(x) if (!is.null(excl.rows)) { if (is.character(excl.rows)) { excl.rows <- grep(excl.rows, rownames(x)) } if (length(excl.rows) > 0) rows <- rows[-excl.rows] } cols <- 1L:(ifelse(is.na(ncol(x)), 1, ncol(x))) if (!is.null(excl.cols)) { if (is.character(excl.cols)) { excl.cols <- grep(excl.cols, colnames(x)) } if (length(excl.cols) > 0) cols <- cols[-excl.cols] } if (length(cols) == 0) stop("No columns to round") if (length(rows) == 0) stop("No rows to round") ret_x <- x for (i in 1:length(cols)) { col <- cols[i] col_digits <- prPickDigits(colname = colnames(x)[col], colindex = i, total_cols = length(cols), digits = digits) ret_x[rows, col] <- mapply(txtRound, x = x[rows, col], digits = col_digits, ..., USE.NAMES = FALSE) } return(ret_x) } htmlTable/R/htmlTable_helpers_addSemicolon2StrEnd.R0000644000176200001440000000221513701421460022031 0ustar liggesusers#' Add a ; at the end #' #' The CSS expects a semicolon at the end of each argument #' this function just adds a semicolong if none is given #' and remove multiple semicolon if such exist #' #' @param my_str The string that is to be processed #' @return `string` #' @keywords internal #' @family hidden helper functions for htmlTable #' @importFrom utils tail prAddSemicolon2StrEnd <- function(my_str) { if (!is.null(names(my_str))) { tmp <- str_trim(my_str) names(tmp) <- names(my_str) my_str <- tmp } else { my_str <- str_trim(my_str) } my_str_n <- sapply(my_str, nchar, USE.NAMES = FALSE) if (any(my_str_n == 0)) { my_str <- my_str[my_str_n > 0] } if (length(my_str) == 0) { return("") } if (tail(strsplit(my_str, "")[[1]], 1) != ";") { n <- names(my_str) my_str <- sprintf("%s;", my_str) if (!is.null(n)) { names(my_str) <- n } } # Remove duplicated ; my_str <- gsub(";;+", ";", my_str) empty_str <- sapply(my_str, function(x) x == ";", USE.NAMES = FALSE) if (any(empty_str)) { my_str <- my_str[!empty_str] } if (length(my_str) == 0) { return("") } return(my_str) } htmlTable/R/interactiveTable.R0000644000176200001440000002130714517434555016017 0ustar liggesusers#' An interactive table that allows you to limit the size of boxes #' #' This function wraps the htmlTable and adds JavaScript code for toggling the amount #' of text shown in any particular cell. #' #' @param x The table to be printed #' @param ... The exact same parameters as [htmlTable()] uses #' @param txt.maxlen The maximum length of a text #' @param button Indicator if the cell should be clickable or if a button should appear with a plus/minus #' @param minimized.columns Notifies if any particular columns should be collapsed from start #' @param js.scripts If you want to add your own JavaScript code you can just add it here. #' All code is merged into one string where each section is wrapped in it's own #' `` element. #' @return An htmlTable with a javascript attribute containing the code that is then printed #' @export #' @example inst/examples/interactiveTable_example.R #' @rdname interactiveTable interactiveTable <- function(x, ..., txt.maxlen = 20, button = getOption("htmlTable.interactiveTable.button", default = FALSE), minimized.columns = NULL, js.scripts = c()) { UseMethod("interactiveTable") } getButtonDiv <- function(sign = "-") { template <- system.file("html_components/button.html", package = "htmlTable") if (template == "") { stop("Could not find the button template file") } template <- readChar(template, nchars = file.info(template)$size) gsub("%sign%", sign, template) %>% gsub("[\n\r]", " ", .) } #' @export #' @method interactiveTable default interactiveTable.default <- function(x, ..., txt.maxlen = 20, button = getOption("htmlTable.interactiveTable.button", default = FALSE), minimized.columns = NULL, js.scripts = c()) { if ("data.frame" %in% class(x)) { x <- prConvertDfFactors(x) } if (!is.null(minimized.columns)) { if (is.character(minimized.columns)) { if (minimized.columns != "last") { stop( "If you want to provide a character for columns you must", " provide 'last' - '", minimized.columns, "' has not yet", " been implemented." ) } minimized.columns <- ncol(x) } else if (is.logical(minimized.columns)) { minimized.columns <- which(minimized.columns) } else if (!is.numeric(minimized.columns)) { stop("Expecting the minimized columns to either be numbers or logical parameters") } else if (max(minimized.columns) > ncol(x)) { stop( "You can't minimize columns larger than the number of columns available.", "I.e. ", paste(minimized.columns[minimized.columns > ncol(x)], collapse = ", "), " > ", ncol(x) ) } if (!is.null(dim(minimized.columns))) { stop("Can only handle column vectors for minimization") } addon_elements <- paste( "... ", "" ) if (button) { addon_elements <- paste( addon_elements, getButtonDiv("+") ) } for (col_no in minimized.columns) { for (row_no in 1:nrow(x)) { if (nchar(x[row_no, col_no]) > txt.maxlen) { x[row_no, col_no] <- paste0( substr(x[row_no, col_no], 1, txt.maxlen), gsub("%span_inner_text%", x[row_no, col_no], addon_elements) ) } } } # Pass false to allow warning later on minimized.columns <- FALSE } tbl <- htmlTable(x, escape.html = FALSE, ...) return(interactiveTable(tbl, txt.maxlen = 20, button = button, minimized.columns = minimized.columns, js.scripts = js.scripts )) } #' @method interactiveTable htmlTable #' @rdname interactiveTable #' @export interactiveTable.htmlTable <- function(x, ..., txt.maxlen = 20, button = getOption("htmlTable.interactiveTable.button", default = FALSE), minimized.columns = NULL, js.scripts = c()) { if (!is.null(minimized.columns) && all(minimized.columns != FALSE)) { stop( "Can't minimize columns after creating the htmlTable.", " Try calling the function directly with the input data that you used for htmlTable" ) } class(x) <- c("interactiveTable", class(x)) if (button) { template <- system.file("javascript/button.js", package = "htmlTable") if (template == "") { stop("Could not find the javascript button template file") } template <- readChar(template, nchars = file.info(template)$size) attr(x, "javascript") <- c( js.scripts, template %>% gsub("%txt.maxlen%", txt.maxlen, .) %>% gsub("%btn%", getButtonDiv(), .) ) } else { template <- system.file("javascript/toggler.js", package = "htmlTable") if (template == "") { stop("Could not find the javascript toggler template file") } template <- readChar(template, nchars = file.info(template)$size) attr(x, "javascript") <- c( js.scripts, template %>% gsub("%txt.maxlen%", txt.maxlen, .) ) } return(x) } #' @rdname interactiveTable #' @importFrom knitr knit_print #' @importFrom knitr asis_output #' @export knit_print.interactiveTable <- function(x, ...) { if (getOption("interactiveTable_knitprint", FALSE)) { asis_output(x) } else { options(interactiveTable_knitprint = TRUE) asis_output(paste( x, attr(x, "javascript") )) } } #' Gets a string with all the scripts merged into one script tag #' #' Each element has it's own script tags in otherwise an error will cause #' all the scripts to fail. #' #' @param x An interactiveTable #' @return string #' @keywords internal prGetScriptString <- function(x) { scripts <- attr(x, "javascript") if (is.null(scripts)) { stop("You have provided an object of class ", class(x), " that does not contain a javascript attribute") } sapply(scripts, USE.NAMES = FALSE, FUN = function(s) { if (s == "") { return("") } paste( "" ) } ) %>% paste(collapse = "\n\n \n") } #' @rdname interactiveTable #' @inheritParams htmlTable #' @export print.interactiveTable <- function(x, useViewer, ...) { args <- attr(x, "...") # Use the latest ... from the print call # and override the original htmlTable call ... # if there is a conflict print_args <- list(...) for (n in names(print_args)) { args[[n]] <- print_args[[n]] } # Since the print may be called from another print function # it may be handy to allow functions to use attributes for the # useViewer parameter if (missing(useViewer)) { if ("useViewer" %in% names(args) && (is.logical(args$useViewer) || is.function(args$useViewer))) { useViewer <- args$useViewer args$useViewer <- NULL } else { useViewer <- TRUE } } if (interactive() && !getOption("htmlTable.cat", FALSE) && (is.function(useViewer) || useViewer != FALSE)) { if (is.null(args$file)) { args$file <- tempfile(fileext = ".html") } htmlPage <- paste("", "", "", "", "", "", "
", x, "
", prGetScriptString(x), "", "", sep = "\n" ) # We only want to use those arguments that are actually in cat # anything else that may have inadvertadly slipped in should # be ignored or it will be added to the output cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(htmlPage, cat_args)) if (is.function(useViewer)) { useViewer(args$file) } else { viewer <- getOption("viewer") if (!is.null(viewer) && is.function(viewer)) { # (code to write some content to the file) viewer(args$file) } else { utils::browseURL(args$file) } } } else { cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(x, cat_args)) cat(prGetScriptString(x)) } invisible(x) } htmlTable/R/tidyHtmlTable_helpers_bindDataListIntoColumns.r0000644000176200001440000000070713701421460023661 0ustar liggesusers#' Merge columns into a tibble #' #' Almost the same as [tibble::tibble()] but it solves the issue #' with some of the arguments being columns and some just being vectors. #' #' @param dataList `list` with the columns/data.frames #' @return `data.frame` object prBindDataListIntoColumns <- function(dataList) { stopifnot(is.list(dataList)) dataList %>% purrr::keep(~ !is.null(.)) %>% do.call(dplyr::bind_cols, .) %>% tibble::as_tibble() } htmlTable/R/tidyHtmlTable.R0000644000176200001440000002607214517463044015277 0ustar liggesusers#' Generate an htmlTable using tidy data as input #' #' This function maps columns from the input data, `x`, to [htmlTable()] parameters. #' It's designed to provide a fluent interface for those familiar with the `tidyverse` ecosystem. #' #' @param x Tidy data used to build the `htmlTable` #' @param value Column containing values for individual table cells. Defaults to "value" (same as [tidyr::pivot_wider]). #' @param header Column in `x` specifying column headings #' @param rnames Column in `x` specifying row names. Defaults to "name" (same as [tidyr::pivot_wider()]). #' @param rgroup Column in `x` specifying row groups. #' @param hidden_rgroup Strings indicating `rgroup` values to be hidden. #' @param cgroup Columns in `x` specifying the column groups. #' @param tspanner Column in `x` specifying `tspanner` groups. #' @param hidden_tspanner Strings indicating `tspanner` values to be hidden. #' @param skip_removal_warning Boolean to suppress warnings when removing `NA` columns. #' @param rnames_unique Designates unique row names when regular names lack uniqueness. #' @param table_fn Function to format the table, defaults to [htmlTable()]. #' @param ... Additional arguments passed to [htmlTable()]. #' #' @section Column-mapping: #' #' Columns from `x` are mapped (transformed) to specific parameters of the [htmlTable()] #' The following columns are converted to match the intended input structure: #' #' * `value` #' * `header` #' * `rnames` #' * `rgroup` #' * `cgroup` #' * `tspanner` #' #' Each combination of the variables in `x` should be unique to map correctly to the output table. #' #' @section Row uniqueness: #' #' Usually each row should have a unique combination of the mappers. #' Sometimes though rows come in a distinct order and the order identifies #' the row more than the name. E.g. if we are identifying bone fractures using the #' AO-classification we will have classes ranging in the form of: #' #' - A #' - A1 #' - A1.1 #' - A2 #' - A2.1 #' - A2.2 #' - B #' - ... #' #' we can simplify the names while retaining the key knowledge to: #' #' - A #' - .1 #' - ...1 #' - .2 #' - ...1 #' - ...2 #' - B #' - ... #' #' This will though result in non-unique rows and thus we need to provide the original #' names in addition to the `rnames` argument. To do this we have `rnames_unique` as a parameter, #' without this `tidyHtmlTable` we risk unintended merging of cells, generating > 1 value per cell. #' #' *Note* it is recommended that you verify with the full names just to make sure that #' any unexpected row order change has happened in the underlying pivot functions. #' #' @section Sorting: #' #' Rows can be pre-sorted using [dplyr::arrange()] before passing to `tidyHtmlTable`. #' Column sorting is based on `arrange(cgroup, header)`. If you want to sort in non-alphabetic #' order you can provide a factor variable and that information will be retained. #' #' @section Hidden values: #' #' `htmlTable` Allows for some values within `rgroup`, #' `cgroup`, etc. to be specified as `""`. The following parameters #' allow for specific values to be treated as if they were a string of length #' zero in the `htmlTable` function. #' #' * `hidden_rgroup` #' * `hidden_tspanner` #' #' @section Simple tibble output: #' #' The tibble discourages the use of row names. There is therefore a convenience #' option for `tidyHtmlTable` where you can use the function just as you #' would with [htmlTable()] where `rnames` is populated with #' the `rnames` argument provided using `tidyselect` syntax (defaults to #' the "names" column if present int the input data). #' #' @section Additional dependencies: #' #' In order to run this function you also must have \pkg{dplyr}, #' \pkg{tidyr}, \pkg{tidyselect} and \pkg{purrr} #' packages installed. These have been removed due to #' the additional 20 Mb that these dependencies added (issue #47). #' *Note:* if you use \pkg{tidyverse} it will already have #' all of these and you do not need to worry. #' #' #' @return Returns the HTML code that, when rendered, displays a formatted table. #' @export #' @seealso [htmlTable()] #' @example inst/examples/tidyHtmlTable_example.R tidyHtmlTable <- function(x, value, header, rnames, rgroup, hidden_rgroup, cgroup, tspanner, hidden_tspanner, skip_removal_warning = getOption("htmlTable.skip_removal_warning", FALSE), rnames_unique, table_fn = htmlTable, ...) { UseMethod("tidyHtmlTable") } #' @export tidyHtmlTable.default <- function(x, value, header, rnames, rgroup, hidden_rgroup, cgroup, tspanner, hidden_tspanner, skip_removal_warning = getOption("htmlTable.skip_removal_warning", FALSE), rnames_unique, table_fn = htmlTable, ...) { stop("x must be of class data.frame") } #' @export tidyHtmlTable.data.frame <- function(x, value, header, rnames, rgroup, hidden_rgroup, cgroup, tspanner, hidden_tspanner, skip_removal_warning = FALSE, rnames_unique, table_fn = htmlTable, ...) { # You need the suggested package for this function safeLoadPkg("dplyr") safeLoadPkg("tidyr") safeLoadPkg("tidyselect") safeLoadPkg("purrr") safeLoadPkg("rlang") # Re-attach style to the new object at the end style_list <- prGetAttrWithDefault(x, which = style_attribute_name, default = NULL) # Check if x is a grouped tbl_df if (dplyr::is.grouped_df(x)) { x <- dplyr::ungroup(x) } if (missing(value) && missing(header)) { # Sometimes we just want to print a tibble and these don't allow for # rownames and htmlTable becomes a little annoying why we want to # have a tidyverse compatible option if (missing(rnames)) { orgName <- rlang::as_name("name") } else { orgName <- substitute(rnames) } args <- list(...) args$x <- x %>% dplyr::select(-{{ orgName }}) args$rnames <- x[[as.character(orgName)]] if (is.null(args$rowlabel)) { args$rowlabel <- as.character(orgName) } return(do.call(htmlTable, args)) } tidyTableDataList <- list( value = prAssertAndRetrieveValue(x, value), header = prAssertAndRetrieveValue(x, header), rnames = prAssertAndRetrieveValue(x, rnames, name = "name"), rnames_unique = prAssertAndRetrieveValue(x, rnames_unique, optional = TRUE), rgroup = prAssertAndRetrieveValue(x, rgroup, optional = TRUE), cgroup = prAssertAndRetrieveValue(x, cgroup, optional = TRUE, maxCols = getOption("htmlTabl.tidyHtmlTable.maxCols", default = 5)), tspanner = prAssertAndRetrieveValue(x, tspanner, optional = TRUE) ) %>% purrr::keep(~ !is.null(.)) checkUniqueness(tidyTableDataList) tidyTableDataList %<>% removeRowsWithNA(skip_removal_warning = skip_removal_warning) # Create tables from which to gather row, column, and tspanner names # and indices rowRefTbl <- getRowTbl(tidyTableDataList) colRefTbl <- getColTbl(tidyTableDataList) # Format the values for display formatted_df <- tidyTableDataList %>% prBindDataListIntoColumns() %>% innerJoinByCommonCols(colRefTbl) %>% innerJoinByCommonCols(rowRefTbl) %>% dplyr::select(r_idx, c_idx, value) %>% dplyr::mutate_at(dplyr::vars(value), as.character) %>% # It is important to sort the rows as below or the data won't be properly # displayed, i.e. there will be primarily be a mismatch between columns dplyr::arrange(r_idx) %>% tidyr::pivot_wider(names_from = "c_idx") %>% dplyr::select(-r_idx) # Hide row groups specified in hidden_rgroup if (!missing(hidden_rgroup)) { rowRefTbl <- rowRefTbl %>% dplyr::mutate(rgroup = ifelse(rgroup %in% hidden_rgroup, "", rgroup)) } # Hide tspanners specified in hidden_tspanner if (!missing(hidden_tspanner)) { rowRefTbl <- rowRefTbl %>% dplyr::mutate(tspanner = ifelse(tspanner %in% hidden_tspanner, "", tspanner)) } # Now order the columns so that cgroup and headers match formatted_df <- formatted_df[, order(colnames(formatted_df) %>% as.numeric())] # Get names and indices for row groups and tspanners htmlTable_args <- list( formatted_df, # Skip names for direct compatibility with Hmisc::latex rnames = rowRefTbl %>% dplyr::pull(rnames), header = colRefTbl %>% dplyr::pull(header), ... ) if (!missing(rgroup)) { # This will take care of a problem in which adjacent row groups # with the same value will cause rgroup and tspanner collision comp_val <- rowRefTbl %>% dplyr::pull(rgroup) if (!missing(tspanner)) { comp_val <- paste0( comp_val, rowRefTbl %>% dplyr::pull(tspanner) ) } rcnts <- prepGroupCounts(comp_val) htmlTable_args$rgroup <- rowRefTbl %>% dplyr::slice(rcnts$idx) %>% dplyr::pull(rgroup) htmlTable_args$n.rgroup <- rcnts$n } if (!missing(tspanner)) { tcnt <- prepGroupCounts(rowRefTbl %>% dplyr::pull(tspanner)) htmlTable_args$tspanner <- tcnt$names htmlTable_args$n.tspanner <- tcnt$n } # Get names and indices for column groups if (!missing(cgroup)) { cg <- list(names = list(), n = list()) noCgroup <- 1 if (is.data.frame(tidyTableDataList$cgroup)) { noCgroup <- ncol(tidyTableDataList$cgroup) } for (colNo in 1:noCgroup) { counts <- prepGroupCounts(colRefTbl %>% dplyr::pull(colNo)) cg$names[[colNo]] <- counts$names cg$n[[colNo]] <- counts$n } maxLen <- sapply(cg$names, length) %>% max() for (colNo in 1:length(cg$names)) { missingNA <- maxLen - length(cg$names[[colNo]]) if (missingNA > 0) { cg$names[[colNo]] <- c(cg$names[[colNo]], rep(NA, times = missingNA)) cg$n[[colNo]] <- c(cg$n[[colNo]], rep(NA, times = missingNA)) } } if (length(cg$names) == 1) { htmlTable_args$cgroup <- cg$names[[1]] htmlTable_args$n.cgroup <- cg$n[[1]] } else { htmlTable_args$cgroup <- do.call(rbind, cg$names) htmlTable_args$n.cgroup <- do.call(rbind, cg$n) } } if (!is.null(style_list)) { attr(htmlTable_args[[1]], style_attribute_name) <- style_list } ret <- do.call(table_fn, htmlTable_args) attr(ret, "htmlTable_args") <- htmlTable_args return(ret) } `c_idx` <- "Fix no visible binding" `r_idx` <- "Fix no visible binding"htmlTable/R/txtFrmt.R0000644000176200001440000001400214165130172014157 0ustar liggesusers#' A merges lines while preserving the line break for HTML/LaTeX #' #' This function helps you to do a table header with multiple lines #' in both HTML and in LaTeX. In HTML this isn't that tricky, you just use #' the `
` command but in LaTeX I often find #' myself writing `vbox`/`hbox` stuff and therefore #' I've created this simple helper function #' #' @param ... The lines that you want to be joined #' @param html If HTML compatible output should be used. If `FALSE` #' it outputs LaTeX formatting. Note if you set this to 5 #' then the HTML5 version of *br* will be used: `
` #' otherwise it uses the `
` that is compatible #' with the XHTML-formatting. #' @return `string` with `asis_output` wrapping if html output is activated #' #' @examples #' txtMergeLines("hello", "world") #' txtMergeLines("hello", "world", html=FALSE) #' txtMergeLines("hello", "world", list("A list", "is OK")) #' #' @family text formatters #' @export #' @importFrom knitr asis_output txtMergeLines <- function(..., html = 5){ strings <- c() for (i in list(...)) { if (is.list(i)) { for (c in i) strings <- append(strings, i) } else{ strings <- append(strings, i) } } if (length(strings) == 0) { return("") } else if (length(strings) == 1) { # Split multi-line strings strings <- strsplit(strings, "\n[ ]*")[[1]] } if (length(strings) == 1) { if (html) { return(asis_output(strings)) } return(strings) } ret <- ifelse(html != FALSE, "", "\\vbox{") first <- TRUE for (line in strings) { line <- as.character(line) if (first) ret <- paste0(ret, ifelse(html != FALSE, line, sprintf("\\hbox{\\strut %s}", line))) else ret <- paste0(ret, ifelse(html != FALSE, paste(ifelse(html == 5, "
\n", "
\n"), line), sprintf("\\hbox{\\strut %s}", line))) first <- FALSE } if (html) { return(asis_output(ret)) } paste0(ret, "}") } #' SI or English formatting of an integer #' #' English uses ',' between every 3 numbers while the #' SI format recommends a ' ' if x > 10^4. The scientific #' form 10e+? is furthermore avoided. #' #' @param x The integer variable #' @param language The ISO-639-1 two-letter code for the language of #' interest. Currently only English is distinguished from the ISO #' format using a ',' as the separator. #' @param html If the format is used in HTML context #' then the space should be a non-breaking space, ` ` #' @param ... Passed to [base::format()] #' @return `string` #' #' @examples #' txtInt(123) #' #' # Supplying a matrix #' txtInt(matrix(c(1234, 12345, 123456, 1234567), ncol = 2)) #' #' # Missing are returned as empty strings, i.e. "" #' txtInt(c(NA, 1e7)) #' #' @family text formatters #' @export txtInt <- function(x, language = getOption("htmlTable.language", default = "en"), html = getOption("htmlTable.html", default = TRUE), ...){ if (length(x) > 1) { ret <- sapply(x, txtInt, language = language, html = TRUE, ...) if (is.matrix(x)) { ret <- matrix(ret, nrow = nrow(x)) rownames(ret) <- rownames(x) colnames(ret) <- colnames(x) } return(ret) } if (is.na(x)) return('') if (abs(x - round(x)) > .Machine$double.eps^0.5 && !"nsmall" %in% names(list(...))) warning("The function can only be served integers, '", x, "' is not an integer.", " There will be issues with decimals being lost if you don't add the nsmall parameter.") if (language == "en") return(format(x, big.mark = ",", scientific = FALSE, ...)) if (x >= 10^4) return(format(x, big.mark = ifelse(html, " ", " "), scientific = FALSE, ...)) return(format(x, scientific = FALSE, ...)) } #' Formats the p-values #' #' Gets formatted p-values. For instance #' you often want `0.1234` to be `0.12` while also #' having two values up until a limit, #' i.e. `0.01234` should be `0.012` while #' `0.001234` should be `0.001`. Furthermore you #' want to have `< 0.001` as it becomes ridiculous #' to report anything below that value. #' #' @param pvalues The p-values #' @param lim.2dec The limit for showing two decimals. E.g. #' the p-value may be `0.056` and we may want to keep the two decimals in order #' to emphasize the proximity to the all-mighty `0.05` p-value and set this to #' \eqn{10^-2}. This allows that a value of `0.0056` is rounded to `0.006` and this #' makes intuitive sense as the `0.0056` level as this is well below #' the `0.05` value and thus not as interesting to know the exact proximity to #' `0.05`. *Disclaimer:* The `0.05`-limit is really silly and debated, unfortunately #' it remains a standard and this package tries to adapt to the current standards in order #' to limit publication associated issues. #' @param lim.sig The significance limit for the less than sign, i.e. the '`<`' #' @param html If the less than sign should be `<` or `<` as needed for HTML output. #' @param ... Currently only used for generating warnings of deprecated call parameters. #' @return vector #' #' @examples #' txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) #' @family text formatters #' @rdname txtPval #' @export txtPval <- function(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html=TRUE, ...){ if (is.logical(html)) html <- ifelse(html, "< ", "< ") sapply(pvalues, function(x, lim.2dec, lim.sig, lt_sign) { if (is.na(as.numeric(x))) { warning("The value: '", x, "' is non-numeric and txtPval", " can't therefore handle it") return(x) } if (x < lim.sig) return(sprintf("%s%s", lt_sign, format(lim.sig, scientific = FALSE))) if (x > lim.2dec) return(format(x, digits = 2, nsmall = -floor(log10(x)) + 1)) return(format(x, digits = 1, scientific = FALSE)) }, lim.sig = lim.sig, lim.2dec = lim.2dec, lt_sign = html) } htmlTable/R/htmlTable_render_getThead.R0000644000176200001440000001022413730316012017565 0ustar liggesusers#' Renders the table head (thead) #' #' @inheritParams htmlTable #' @inheritParams prGetCgroupHeader #' @param total_columns The total number of columns including the rowlabel and the #' specer cells #' @return `string` Returns the html string for the `...` element #' @keywords internal #' @importFrom stringr str_interp prGetThead <- function(x, header = NULL, cgroup = NULL, n.cgroup = NULL, caption = NULL, compatibility, total_columns, css.cgroup, top_row_style, rnames, rowlabel = NULL, cgroup_spacer_cells, prepped_cell_css, style_list, cell_style) { first_row <- TRUE # Start the head head_str <- "\n\t" if (!is.null(caption) & compatibility == "LibreOffice" & !style_list$pos.caption %in% c("bottom", "below")) { head_str %<>% paste(str_interp("${CONTENT}", list(COLSPAN = total_columns, CONTENT = caption)), sep = "\n\t") } # Add the cgroup table header if (!is.null(cgroup)) { for (i in 1:nrow(cgroup)) { cgrp_str <- prGetCgroupHeader( x = x, cgroup_vec = cgroup[i, ], n.cgroup_vec = n.cgroup[i, ], cgroup_vec.just = style_list$align.cgroup[i, ], css_4_cgroup_vec = style_list$css.cgroup[i, ], row_no = i, top_row_style = top_row_style, rnames = rnames, rowlabel = rowlabel, style_list = style_list, cgroup_spacer_cells = cgroup_spacer_cells, prepped_cell_css = prepped_cell_css ) head_str %<>% paste0(cgrp_str) } first_row <- FALSE } # Add the header if (!is.null(header)) { header_rowlabel_str <- NA no_cgroup_rows <- ifelse(!is.null(cgroup), nrow(cgroup), 0) ts <- ifelse(no_cgroup_rows > 0, "", top_row_style) header_list <- NULL if (!is.null(rowlabel) && style_list$pos.rowlabel == no_cgroup_rows + 1) { header_list <- list(STYLE = prGetStyle(style_list$css.header.border_bottom, style_list$css.header[1], ts, attr(prepped_cell_css, "rnames")[1], align = prGetAlign(style_list$align.header, 1, style_list = style_list)), CONTENT = rowlabel) } else if (!prSkipRownames(rnames)) { header_list <- list(STYLE = prGetStyle(style_list$css.header.border_bottom, ts), CONTENT = "") } if (!is.null(header_list)) { header_rowlabel_str <- paste(str_interp("${CONTENT}", header_list), sep = "\n\t\t") } cell_style <- c(style_list$css.header.border_bottom) if (first_row) { cell_style %<>% c(top_row_style) } cell_str <- prAddCells( rowcells = header, cellcode = "th", style_list = style_list, style = cell_style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames) * 1, prepped_cell_css = attr(prepped_cell_css, "header"), style_list_align_key = "align.header" ) # The bottom border was ment to be here but it doesn't # work that well in the export if (is.na(header_rowlabel_str)) { head_str %<>% paste(paste0("", cell_str), "", sep = "\n\t") } else { head_str %<>% paste(paste0("", header_rowlabel_str, cell_str), "", sep = "\n\t") } first_row <- FALSE } ################################# # Close head and start the body # ################################# head_str %<>% paste0("\n\t") return(head_str) } htmlTable/R/txtFrmt_round_data.frame.R0000644000176200001440000000457314165130172017464 0ustar liggesusers#' @export #' @rdname txtRound #' @section Tidy-select with `data.frame`: #' #' The `txtRound` can use `data.frame` for input. This allows us to use #' [tidyselect](https://tidyselect.r-lib.org/articles/tidyselect.html) #' patterns as popularized by **dplyr**. #' #' @examples #' #' # Using a data.frame directly #' library(magrittr) #' data("mtcars") #' # If we want to round all the numerical values #' mtcars %>% #' txtRound(digits = 1) #' #' # If we want only want to round some columns #' mtcars %>% #' txtRound(wt, qsec_txt = qsec, digits = 1) #' @importFrom methods formalArgs txtRound.data.frame <- function(x, ..., digits = 0L){ safeLoadPkg("tidyselect") vars <- tidyselect::eval_select(rlang::expr(c(...)), x) vars <- vars[!(names(vars) %in% formalArgs(txtRound.default))] if (length(vars) == 0) { vars <- sapply(x, is.numeric) vars <- sapply(names(vars)[vars], function(cn) which(cn == colnames(x))) } call <- as.list(match.call()) # Drop function & x call arguments call[[1]] <- NULL call[[1]] <- NULL call <- Filter(function(argument_value) !is.language(argument_value) && (!is.name(argument_value) || !(as.character(argument_value) %in% colnames(x))), call) if (length(vars) > 0) { for (i in 1:length(vars)) { call$digits <- prPickDigits(colname = colnames(x)[vars[i]], colindex = i, total_cols = ncol(x), digits = digits) x[[names(vars)[i]]] <- do.call(txtRound, c(list(x = x[[vars[i]]]), call)) } } return(x) } prPickDigits <- function(colname, colindex, total_cols, digits) { if (length(digits) == 1 && is.numeric(digits)) return(digits) if (is.null(names(digits))) { if (total_cols == length(digits)) { return(digits[colindex]) } stop("Either provide digits as a single numerical or", " a named vector/list that we can pick elements from") } stopifnot(all(sapply(digits, is.numeric))) if (colname %in% names(digits)) { return(digits[[colname]]) } if (".default" %in% names(digits)) { return(digits[[".default"]]) } stop("The column '", colname, "' (pos. ", colindex, ") was not among provided digits: '", paste(names(digits), collapse = "', '"), "' and no '.default' was found.") }htmlTable/R/prepGroupCounts.R0000644000176200001440000000115213701421460015666 0ustar liggesusers#' Retrieves counts for rgroup, cgroup, & tspanner arguments #' #' This function is a wrapper to [base::rle()] that #' does exactly this but is a little too picky about input values. #' #' @param x The vector to process #' @return `list(n = rle$lengths, names = rle$values)` #' @export #' @examples #' prepGroupCounts(c(1:3, 3:1)) prepGroupCounts <- function(x) { # Drop all classes but the base class as rle counts <- rle(as.vector(x)) ret <- list( n = counts$lengths, idx = cumsum(counts$lengths), names = counts$values ) structure(ret, class = c("htmlTable_group_count", class(ret)) ) } htmlTable/vignettes/0000755000176200001440000000000014646657237014222 5ustar liggesusershtmlTable/vignettes/tidyHtmlTable.Rmd0000644000176200001440000000470213701421460017411 0ustar liggesusers--- title: "Using tidyHtmlTable" author: "Stephen Gragg" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using tidyHtmlTable} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- # Introduction `tidyHtmlTable` acts as a wrapper function for the `htmlTable` function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2. # Some Examples ## Prepare Data We'll begin by turning the `mtcars` data into a tidy dataset. The `pivot_longer` function is called to collect 3 performance metrics into a pair of key and value columns. ```{r, message=FALSE} library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% as_tibble(rownames = "rnames") %>% pivot_longer(names_to = "per_metric", cols = c(hp, mpg, qsec)) ``` Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears. ```{r} tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1), .groups = 'drop') %>% pivot_longer(names_to = "summary_stat", cols = c(Mean, SD, Min, Max)) %>% ungroup() %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ``` At this point, we are ready to implement the `htmlTable` function. Essentially, this constructs an html table using arguments similar to the `htmlTable` function. However, whereas `htmlTable` required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data. ## Output html table ### Example 1 ```{r, warning=FALSE} tidy_summary %>% arrange(per_metric, summary_stat) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric) ``` ### Example 2 ```{r, warning=FALSE} tidy_summary %>% arrange(cyl, gear) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = summary_stat, cgroup = per_metric, rnames = gear, rgroup = cyl) ``` htmlTable/vignettes/text_formatters.Rmd0000644000176200001440000001114514165130172020076 0ustar liggesusers--- title: "Text formatters" author: "Max Gordon" date: "`r Sys.Date()`" VignetteBuilder: knitr, rmarkdown output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{Text formatters} %\usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: inline --- Text formatters =============== Bundled with this package are some text formatting functions. The purpose of these is to convert numeric values into character/text that is more pleasent in publication tables. txtRound -------- While `base::round()` is an excellent function in most cases we often want a table to retain trailing 0:s. E.g. ```{r message=FALSE} library(htmlTable) library(dplyr) library(magrittr) data("mtcars") mtcars %<>% mutate(am = factor(am, levels = 0:1, labels = c("Automatic", "Manual")), vs = factor(vs, levels = 0:1, labels = c("V-shaped", "straight"))) mtcars %>% head(3) %>% select(Transmission = am, Gas = mpg, Weight = wt) %>% htmlTable() ``` doesn't look visually that great, instead we would prefer to have something like this: ```{r} mtcars %>% head(3) %>% select(Transmission = am, Gas = mpg, Weight = wt) %>% txtRound(digits = 1) %>% htmlTable() ``` ### Single/vector values At the core of the `txtRound` is the single/vector value conversion: ```{r} txtRound(c(1, 1.1034), digits = 2) # Use a character to convert txtRound("1.2333", digits = 2) ``` If you have some values that need thousand separation you can also add `txtInt_args`. ```{r} # Large numbers can be combined with the txtInt option txtRound(12345.12, digits = 1, txtInt_args = TRUE) txtRound(12345.12, digits = 1, txtInt_args = list(language = "se", html = FALSE)) ``` ### Data frames As seen in the introduction we can use data frames for input. We can here rename the converted columns: ```{r} mtcars %>% head(3) %>% select(mpg, wt) %>% txtRound(mpg, wt_txt = wt, digits = 1) ``` And we can specify the number of decimals that we're interested in per column: ```{r} mtcars %>% head(3) %>% select(mpg, qsec, wt) %>% txtRound(digits = list(wt = 2, .default = 1)) ``` ### Matrix We can also feed a matrix into the `txtRound`: ```{r} mtcars_matrix <- mtcars %>% select(mpg, qsec, wt) %>% head(3) %>% as.matrix() mtcars_matrix %>% txtRound(digits = 1) ``` Here we have some options of excluding columns/rows using regular expressions: ```{r} mtcars_matrix %>% txtRound(excl.cols = "^wt$", excl.rows = "^Mazda RX4$", digits = 1) ``` Similarly to the data.frame we can use the same syntax to pick column specific digits: ```{r} mtcars_matrix %>% txtRound(digits = list(mpg = 0, wt = 2, .default = 1)) ``` txtInt ------ While scientific format is useful if familiar with the syntax it can be difficult to grasp for scholars with a less mathematical background. Therefore the thousand separator style can be quite useful, also known as [digital grouping](https://en.wikipedia.org/wiki/Decimal_separator#Digit_grouping): ```{r} txtInt(1e7) ``` As Swedish and many other languages rely on space (SI-standard) we can specify language as a parameter. Note that as we don't want to have line breaks within a digit we can use [non-breaking space](https://en.wikipedia.org/wiki/Non-breaking_space) for keeping the number intact (the html-code is ` `): ```{r} txtInt(1e7, language = "SI", html = FALSE) txtInt(1e7, language = "SI", html = TRUE) ``` Note that there are the option `htmlTable.language` and `htmlTable.html` that you can use for the input of these parameters. txtPval ------- The p-value is perhaps the most controversial of statistical output, nevertheless it is still needed and used correctly it has it's use. P-values are frequently rounded as the decimals are not as important. The `txtPval` is a convenient function with some defaults that correspond to typical uses in medical publications. ```{r} txtPval(c(0.1233213, 0.035, 0.001, 0.000001), html = FALSE) # The < sign is less-than in html code '<' txtPval(c(0.05, 0.001, 0.000001), html = TRUE) ``` txtMergeLines ------------- In html we indicate new line using *<br />* while the latex style uses *hbox*. To help with these two there is the `txtMergeLines` that merges lines into one properly formatted unit: ```{r} txtMergeLines("Line 1", "Line 2", "Line 3") ``` Note that you can also use a single multi-line string: ```{r} txtMergeLines("Line 1 Line 2 Line 3") ``` ```{r} txtMergeLines("Line 1 Line 2 Line 3", html = FALSE) ``` htmlTable/vignettes/custom.css0000644000176200001440000000563413730477224016243 0ustar liggesusersbody { background-color: #fff; margin: 1em auto; max-width: 700px; overflow: visible; padding-left: 2em; padding-right: 2em; font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; font-size: 14px; line-height: 1.35; } #header { text-align: center; } #TOC { clear: both; margin: 0 0 10px 10px; padding: 4px; width: 400px; border: 1px solid #CCCCCC; border-radius: 5px; background-color: #f6f6f6; font-size: 13px; line-height: 1.3; } #TOC .toctitle { font-weight: bold; font-size: 15px; margin-left: 5px; } #TOC ul { padding-left: 40px; margin-left: -1.5em; margin-top: 5px; margin-bottom: 5px; } #TOC ul ul { margin-left: -2em; } #TOC li { line-height: 16px; } table { margin: 1em auto; } p { margin: 0.5em 0; } blockquote { background-color: #f6f6f6; padding: 0.25em 0.75em; } hr { border-style: solid; border: none; border-top: 1px solid #777; margin: 28px 0; } dl { margin-left: 0; } dl dd { margin-bottom: 13px; margin-left: 13px; } dl dt { font-weight: bold; } ul { margin-top: 0; } ul li { list-style: circle outside; } ul ul { margin-bottom: 0; } pre, code { background-color: #f7f7f7; border-radius: 3px; color: #333; } pre { white-space: pre-wrap; /* Wrap long lines */ border-radius: 3px; margin: 5px 0px 10px 0px; padding: 10px; } pre:not([class]) { background-color: #f7f7f7; } code { font-family: Consolas, Monaco, 'Courier New', monospace; font-size: 85%; } p > code, li > code { padding: 2px 0px; } div.figure { text-align: center; } img { background-color: #FFFFFF; padding: 2px; border: 1px solid #DDDDDD; border-radius: 3px; border: 1px solid #CCCCCC; margin: 0 5px; } h1 { margin-top: 0; font-size: 35px; line-height: 40px; } h2 { border-bottom: 4px solid #f7f7f7; padding-top: 10px; padding-bottom: 2px; font-size: 145%; } h3 { border-bottom: 2px solid #f7f7f7; padding-top: 10px; font-size: 120%; } h4 { border-bottom: 1px solid #f7f7f7; margin-left: 8px; font-size: 105%; } h5, h6 { border-bottom: 1px solid #ccc; font-size: 105%; } a { color: #0033dd; text-decoration: none; } a:hover { color: #6666ff; } a:visited { color: #800080; } a:visited:hover { color: #BB00BB; } a[href^="http:"] { text-decoration: underline; } a[href^="https:"] { text-decoration: underline; } /* Colours from https://gist.github.com/robsimmons/1172277 */ code > span.kw { color: #555; font-weight: bold; } /* Keyword */ code > span.dt { color: #902000; } /* DataType */ code > span.dv { color: #40a070; } /* DecVal (decimal values) */ code > span.bn { color: #d14; } /* BaseN */ code > span.fl { color: #d14; } /* Float */ code > span.ch { color: #d14; } /* Char */ code > span.st { color: #d14; } /* String */ code > span.co { color: #888888; font-style: italic; } /* Comment */ code > span.ot { color: #007020; } /* OtherToken */ code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ code > span.fu { color: #900; font-weight: bold; } /* Function calls */ code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */htmlTable/vignettes/complex_tables.Rmd0000644000176200001440000002761114517434555017667 0ustar liggesusers--- title: "Building a complex table" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true css: custom.css vignette: > %\VignetteIndexEntry{Building a complex table} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- # Introduction Tables are an essential part of publishing, well... anything. I therefore want to explore the options available for generating these in knitr. It is important to remember that there are two ways of generating tables in markdown: 1. Markdown tables 2. HTML tables As the `htmlTable`-package is all about [HTML](https://en.wikipedia.org/wiki/HTML) tables we will work only with that output option. The core idea is that HTML is ubiquitous and that most word-processors will have to support copy-pasting tables and by providing simple simple CSS-formatting we are able to maximize this compatibility. _Note_ CSS is today an extremely complex topic and it is no surprise that word-processors may have difficulty importing tables that have lots of advanced syntax, htmlTable tries to avoid all of that by putting the style close to each element, often at the cell-level. # Basics I developed the `htmlTable` in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the `Hmisc::latex` function on [Stack Overflow](https://stackoverflow.com/questions/11950703/html-with-multicolumn-table-in-markdown-using-knitr) I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two: ```{r} library(htmlTable) setHtmlTableTheme(theme = "Google docs") output <- matrix(paste("Content", LETTERS[1:16]), ncol = 4, byrow = TRUE) output |> htmlTable(header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2, 2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2, 2), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment") ``` We can modify all our tables by using the `setHtmlTableTemplate()` and we also don't have to set the exact span of each group as it can be assumed from the data. ```{r} setHtmlTableTheme(pos.caption = "bottom") output |> addHtmlTableStyle(css.rgroup = "font-style: italic") |> htmlTable(header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B", ""), n.rgroup = c(1, 2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = 3, caption = "A slightly differnt table with a bottom caption", tfoot = "† A table footer commment") ``` The basic principles are: - use the `|>` pipe as much as possible - build complexity stepwise through passing `addHtmlTableStyle()` function - keep arguments to a minimum through templating and autocalculation # Example based upon Swedish statistics In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. **Goal: visualize migration patterns**. The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format. ```{r, results='markup', message=FALSE, warning=FALSE} data(SCB) # The SCB has three other columns and one value column prepped_scb <- SCB |> dplyr::mutate(region = relevel(SCB$region, "Sweden")) |> dplyr::select(year, region, sex, values) |> tidyr::pivot_wider(names_from = c(region, sex), values_from = values) # Set rownames to be year rownames(prepped_scb) <- prepped_scb$year prepped_scb$year <- NULL # The dataset now has the rows names(prepped_scb) # and the dimensions dim(prepped_scb) ``` The next step is to calculate two new columns: - Δint = The change within each group since the start of the observation. - Δstd = The change in relation to the overall age change in Sweden. To convey all these layers of information will create a table with multiple levels of column spanners:
County
Men   Women
AgeΔint.Δext.   AgeΔint.Δext.
```{r} mx <- NULL for (n in names(prepped_scb)) { tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(prepped_scb[[n]], prepped_scb[[n]] - prepped_scb[[n]][1], prepped_scb[[n]] - prepped_scb[[tmp]])) } rownames(mx) <- rownames(prepped_scb) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(prepped_scb)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(prepped_scb), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(prepped_scb))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(prepped_scb) - length(cgroup))), Hmisc::capitalize( sapply(names(prepped_scb), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(prepped_scb) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ``` Next step is to output the table after rounding to the correct number of decimals. The `txtRound` function helps with this, as it uses the `sprintf` function instead of the `round` the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0. ```{r} htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument. ```{r} mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", spacer.celltype = "double_cell") |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we still feel that we want more separation it is always possible to add colors. ```{r} mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", align.header = "c", col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4))) |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid. ```{r} mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", align.header = "c", col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), col.rgroup = c("none", "#FFFFCC")) |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters. ```{r} cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr) { out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } out_mx |> addHtmlTableStyle(align = "rrrr|r", align.header = "cccc|c", pos.rowlabel = "bottom", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4))) |> htmlTable(caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", rowlabel = "Year", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data. Lastly I would like to thank [Stephen Few](https://www.amazon.com/Show-Me-Numbers-Designing-Enlighten/dp/0970601999), [ThinkUI](http://www.thinkui.co.uk/resources/effective-design-of-data-tables/), and [LabWrite](https://labwrite.ncsu.edu/res/gh/gh-tables.html) for inspiration. htmlTable/vignettes/general.Rmd0000644000176200001440000002613313730477224016275 0ustar liggesusers--- title: "How-to use htmlTable" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{How-to use htmlTable} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Basics ====== The **htmlTable** package is intended for generating tables using [HTML](https://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](https://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```{r} library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol = 2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ``` The function is also aware of the dimnames: ```{r} # A simple output matrix(1:4, ncol = 2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ``` This can be convenient when working with the `base::table` function: ```{r} data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ``` As of version 1.1 you **no longer need** to specify `results='asis'` for each `knitr` chunk. **Tip**: If you are working a lot with `dplyr` and the `tidyverse` approach to exploring data you can make your life much easier using the `tidyHtmlTable()` function included in this package that automatically calculates the `rgroup`, `cgroup` and other parameters that make `htmlTable` so useful. Table caption ------------- The table caption is simply the table description and can be either located above or below: ```{r ctable_example} output <- matrix(1:4, ncol = 2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable = c("solid", "double"), caption = "A table caption above and ctable borders") ``` The caption defaults to above but by setting the `pos.caption` argument to "bottom" it appears below the table. ```{r table_with_caption_below} output %>% addHtmlTableStyle(pos.caption = "bottom") %>% htmlTable(caption = "A table caption below") ``` Cell alignment -------------- Cell alignment is specified through the `align`, `align.header`, `align.cgroup` arguments. For aligning the cell values just use `align`. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below: ```{r} 1:3 %>% addHtmlTableStyle(align = "lcr") %>% htmlTable(rnames = "Row 1", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the `align.header` argument: ```{r} 1:3 %>% addHtmlTableStyle(align = "clcr", align.header = "lcr") %>% htmlTable(rnames = "Row 1", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as: * row groups * column spanners * table spanners * total row * table footer * zebra coloring (also known as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The `htmlTable`-function is written for all these purposes. For demonstration purposes we will setup a basic matrix: ```{r} mx <- matrix(ncol = 6, nrow = 8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)) { for (nc in 1:ncol(mx)) { mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```{r} htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ``` We can easily mix row groups with regular variables by having an empty row group name `""`: ```{r} htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```{r} mx %>% addHtmlTableStyle(css.rgroup = "") %>% htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` The `rgroup` is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the 'add' attribute to the `rgroup`: ```{r} rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ``` Column spanners --------------- A column spanner spans 2 or more columns: ```{r} htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ``` It can sometimes be convenient to have column spanners in multiple levels: ```{r} htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ``` Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function and you can also provide a `list` with elements that allows you to skip the `NA` at the end of the matrix: ```{r} htmlTable(mx, cgroup = list(c("Super column spanner", ""), c("", "Another cgroup"), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = list(c(5,1), c(1,2), c(2,2,2))) ``` Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Note that you actually don't need the last `n.tspanner`, i.e. you can simplify the above to: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4)) ``` Similarly you can use the number rgroups included in each tspanner instead of actual rows. This is convenient as the tspannners must align with underlying rgroups. Total row --------- Many financial tables use the concept of a total row at the end that sums the above elements: ```{r} htmlTable(mx[1:3,], total = TRUE) ``` This can also be combined with table spanners: ```{r} mx %>% addHtmlTableStyle(css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900")) %>% htmlTable(total = "tspanner", tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Table numbering --------------- The htmlTable has built-in numbering, initialized by: ```{r} options(table_counter = TRUE) ``` ```{r} htmlTable(mx[1:2,1:2], caption = "A table caption with a numbering") ``` As we often want to reference the table number in the text there are two associated functions: ```{r} tblNoLast() tblNoNext() ``` ```{r} htmlTable(mx[1:2,1:2], caption = "Another table with numbering") ``` If you want to start the counter at 2 you can instead of setting table_counter to `TRUE` set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by: ```{r} options(table_counter = FALSE) ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```{r} htmlTable(mx[1:2,1:2], tfoot = "A table footer") ``` Zebra coloring (or banded colors) ------------------------------------ Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows: ```{r} mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% htmlTable ``` The zebra coloring in `htmlTable` is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. "" will have alternating colors event though they programatically are within the same group: ```{r} mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ``` We can also color the columns: ```{r} mx %>% addHtmlTableStyle(col.columns = c("none", "#F7F7F7")) %>% htmlTable ``` Or do both (note that the colors blend at the intersections): ```{r} mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) %>% htmlTable ``` Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```{r} rgroup = paste("Group", LETTERS[1:3]) attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001") mx %>% addHtmlTableStyle(align = "rr|r", align.header = "cc|c", spacer.celltype = "double_cell", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;", css.header = "font-weight: normal") %>% htmlTable(rgroup = rgroup, n.rgroup = c(2,4), tspanner = paste("Spanner", LETTERS[1:2]), n.tspanner = c(1), cgroup = list(c("", "Column spanners"), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = list(c(1,5), c(2,2,2)), caption = "A table with column spanners, row groups, and zebra striping", tfoot = "† A table footer commment", cspan.rgroup = 2) ``` htmlTable/data/0000755000176200001440000000000013407215301013073 5ustar liggesusershtmlTable/data/SCB.rda0000644000176200001440000000124513407215301014174 0ustar liggesusersVMn@8?"VlPV,8Jv{X!NZl;, p\}Ì=kTU)#|/3f/A~PgY\UVnR%Va[ =Uw[Ux[\Oɬ5YeMVZHfU-g'(6¡*5X=^1S04k NhVrlrGyX,]ЬGa bs ^-whtmlTable/NAMESPACE0000644000176200001440000000321214517434555013420 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(htmlTable,data.frame) S3method(htmlTable,default) S3method(htmlTable,matrix) S3method(interactiveTable,default) S3method(interactiveTable,htmlTable) S3method(knit_print,htmlTable) S3method(knit_print,interactiveTable) S3method(print,htmlTable) S3method(print,interactiveTable) S3method(tidyHtmlTable,data.frame) S3method(tidyHtmlTable,default) S3method(txtRound,data.frame) S3method(txtRound,default) S3method(txtRound,matrix) S3method(txtRound,table) export(addHtmlTableStyle) export(concatHtmlTables) export(getHtmlTableStyle) export(getHtmlTableTheme) export(hasHtmlTableStyle) export(htmlTable) export(htmlTableWidget) export(htmlTableWidgetOutput) export(interactiveTable) export(outputInt) export(prepGroupCounts) export(pvalueFormatter) export(renderHtmlTableWidget) export(setHtmlTableTheme) export(splitLines4Table) export(tblNoLast) export(tblNoNext) export(tidyHtmlTable) export(txtInt) export(txtMergeLines) export(txtPval) export(txtRound) export(vector2string) import(checkmate) import(htmlwidgets) import(magrittr) importFrom(grDevices,col2rgb) importFrom(grDevices,colorRampPalette) importFrom(htmltools,htmlEscape) importFrom(knitr,asis_output) importFrom(knitr,knit_print) importFrom(methods,formalArgs) importFrom(methods,setClass) importFrom(rstudioapi,getActiveDocumentContext) importFrom(rstudioapi,isAvailable) importFrom(stats,na.omit) importFrom(stringr,str_interp) importFrom(stringr,str_replace) importFrom(stringr,str_replace_all) importFrom(stringr,str_split) importFrom(stringr,str_trim) importFrom(utils,as.roman) importFrom(utils,browseURL) importFrom(utils,head) importFrom(utils,tail) htmlTable/NEWS.md0000644000176200001440000002234614646650100013275 0ustar liggesusersNEWS for the htmlTable package ## Changes for 2.4.3 - Minor test improvement (PR #89) ## Changes for 2.4.2 - Updated JQuery dependency in interactiveTable to 3.7.1 - Dropped reshape in favor of pivot_wider (issue #88) ## Changes for 2.4.1 - Updated JQuery dependency in interactiveTable (issue #85) ## Changes for 2.4.0 - The `txtRound.data.frame` converted all data to a matrix before rounding all elements. Changed to only convert numeric variables and also added tidy-select syntax. The function now returns the entire input `data.frame` with rounded elements as requested. - The `txtMergeLines` now returns an `knitr::asis_output` if html mode is activated. Fixed also multiline strings conversion into latex/html format. - Added vignette for the text formatting functions. ## Changes for 2.3.0 - Added `rnames_unique` parameter to `tidyHtmlTable` so that rows can have non-unique names ## Changes for 2.2.1 - The `txtInt` handles `NA` more gracefully. ## Changes fro 2.2.0 - Added `htmlTable_args` attribute for making modifications to the final table easier ## Changes fro 2.1.0 - Added options for how the empty spacer cell appears (see `addHtmlTableStyle()` spacer.\* options) - Fixed ignored `align.header` - Fix for wrapped styles (issue #80) ## Changes for 2.0.1 - Fix for txtRound not handling negative numbers (issue #76) - Fix bug for `hidden.rgroup` & `hidden_tspanner` in `tidyHtmlTable` - Documentation improvements & switched to markdown docs ## Changes for 2.0.0 - Added theming and styling with `addHtmlTableStyle` and `setHtmlTableTheme` to reduce the cognitive burden of finding the right option within the docs. Note: this may impact your current tables and hence the major version (2.0.0). - Changed so that `css.cell` is properly applied to rownames, cell fillers and the actual cells of interest (may impact the final layout!) - Breaking change `tidyHtmlTable`: Moved to a fully tidyverse compatible system with tidyHtmlTable. This is a breaking change to the API as we switch from columns as strings to `tidyselect` syntax and as `gather`/`spread` have been replaced by `pivot_longer`/`pivot_wider` the default values have been updated in accordance with their defaults, e.g. `rnames = "name"` and `value = "value"`. - Breaking change `tidyHtmlTable`: Sorting of rows is skipped as we may have situations with repeating inputs and this can easily be performed pre-function by calling `dplyr::arrange`. This has furthermore the desirable feature that any custom sorting is retained. - Added _mso-number-format_ to help (Issue #63) - thanks Rasmus Hertzum - txtRound can now add txtInt when formatting the integer section for easier readability - Added htmlTable css options - they should all start with `htmlTable.` - `pos.caption` now uses match.arg as expected - Fixed proper S3 function definition for `htmlTable` with all the arguments - Added `htmlTable.css.border` style option for allowing to choose border style. Also fixed bug with cgroup empty cells and vertical border. - Added `htmlTable.pretty_indentation` option for skipping the stripping of all the tabs that was required due to old Pandoc bug. - Added `attr(x, "html") <- TRUE` by default and UTF-8 encoding on all outputted strings to mimic the `htmltools::HTML` function behavior. - For simple tibble output the `tidyHtmlTable` can now be used to choose a column for the rnames argument - The print statement now respects the `chunk_output_type` in Rmd files in RStudio - `tidyHtmlTable` now accepts table function that allows switching to other table functions - Added `css.header` style as using `css.cell` wasn't entirely intuitive (fixes issue #73) ## Changes for 1.13.3 - Prepared for R 4.0 ## Changes for 1.13.1 - Bug fix for cgroup as list argument - The `n.tspanner` now also accepts number of `rgroup`s ## Changes for 1.13 - Added the ability to have `cgroup` arguments as a list - Fixed `n.rgoup` bug with css - Improved the general vignette - Added `vector2string` - a convenience function when you want to output a vector into a string - Added `digits.nonzero` to `txtRound` function that allows more digits with values close to zero - Force encoding for `print.htmlTable` when outputting a table using the viewer (Issue #61) ## Changes for 1.12 - Added scientific notation to `txtRound` (Issue #35) ## Changes for 1.11.4 - Fix $ MathJax bug (Issue #57) ## Changes for 1.11.3 - Fix single-row `css.cell` bug (Issue #54) ## Changes for 1.11.2 - Set `htmlEscape` to default to `FALSE` as some features depend on the ability to be able to send html formatted strings. ## Changes for 1.11.1 - Removed tidyr and dplyr from dependencies (issue #47) ## Changes for 1.11.0 - Strings are now escaped using `htmltools::htmlEscape` - issue #40 (thanks Peter Konings) - Tidy data interface - issue #42 (thanks Stephen Gragg) ## Changes for 1.10.1 - Fixed bug with rownames styling (thanks Shira Mitchell) ## Changes for 1.10 - Added conversion of dimnames into row/column labels - Added detection of sum row/colum when using `base::table` - fixed `cgroup` bug with automated `n.cgroup` calculations - fixed output to viewport when not in RStudio notebook (thanks Peter Konings) - fixed vector input for `txtRound` warning ## Changes for 1.9 - `txtInt` handles nsmall warning when working with non-atomic numbers (issue #23) - fixed output for RStudio notebook (issue #26) ## Changes for 1.8 - `txtRound` now throws an error when provided a too short vector of digits (thanks Peter Konings) - `css.cell` has improved docs and added checkmate to verify format (thanks maverickg) - Added `concatHtmlTables` for merging multiple tables into one string element of class `htmlTable` - Fixed CRAN bugs in dev version ## Changes for 1.7 - Added ability to print `matrix` & `data.frame` without any rows, i.e. empty (Thanks Peter Konings) - Added table border flexibility via the `ctable` argument (Thanks raredd) - Added option of having row-group separators for no-named row groups (Thanks, prof. Harrell) - Fixed bug with outputting dates (issue #14) ## Changes for 1.6 - The `txtRound` now properly handles vector digits argument - The `txtRound` is now a S3-function and handles `data.frame` objects in a cleaner way ## Changes for 1.5 - Added better description for how to use the add attribute for `rgroup`s - Extended the add attribute for `rgroup` to accept matrices - The `n.rgroup`/`rgroup` are automaticaly completed with the last rows if sum(`n.rgroup`) is less than the total number of rows - Similar applies to `n.cgroup`/`cgroup` - Fixed the line-merge so that all new lines get an `
`-tag - Added an `interactiveTable` for allowing tables with cells that have resizeable content - Added `css.table` for table element css styling ## Changes for 1.4 - Handles `data.frames` with factors - thanks Sergio Oller #4 ## Changes for 1.3 - Prepared for API-changes with stringr 1.0 - The txtRound can now handle vectors and single values ## Changes for 1.2 - Fixed table counter update - The `htmlTable` can now also accept vectors - Removed the `format.df` from Hmisc as it converted & to \& with unexpected results. This functionality has also been superseeded by the txtRound function. ## Changes for 1.1 - Added the option of having an attribute on the `rgroup` in case there is an interest of adding more data to that particular row - Added a fix for the pandoc tab bug - `knit_print` implemented removing the need for results='asis' except for within for-loops - Removed the capitalize tspanner css as this may cause confusion with limited word processor compatibility - Added `htmlTable` tests - `txtRound` now also rounds character matrices - Added a detailed vignette with the primary features of `htmlTable` - Added the option of having a total row - The `pos.caption` can now also be "below" - Fixed minor bug with numbering not beeing turned off with options(table_counter = FALSE) - Zebra striping now works for `rgroup`s mixed with "" - `txtRound` returns "" by default if value missing. This can also be specified with the `txt.NA` option ## Changes for 1.0 - The `htmlTable` and associated txt-functions are now separated from Gmisc - Argument name changes for `htmlTable` for better consistency and logic: `rowname` -> `rnames` `headings` -> `header` `halign` -> `align.header` `cgroup.just` -> `align.cgroup` `rgroupCSSstyle` -> `css.rgroup` `rgroupCSSseparator` -> `css.rgroup.sep` `tspannerCSSstyle` -> `css.tspanner` `tspannerCSSseparator` -> `css.tspanner.sep` `tableCSSclass` -> `css.table.class` `rowlabel.pos` -> `pos.rowlabel` `caption.loc` -> `pos.caption` `altcol` -> `col.rgroup` - `htmlTable` can now handle `rnames = FALSE` in order to surpress rownames - `htmlTable` now defaults to the layout of `ctable` as this is the more commonly found layout among medical papers - `htmlTable` `rgroup` has the additional `padding.rgroup` for those that want to change the no-breaking space padding - `htmlTable` `tfoot` is automatically run through `txtMergeLines` in order to retain wrapped text - Renamed `splitLines4Table` to `txtMergeLines`, `outputInt` to `txtInt`, `pvalueFormatter` to `txtPval` and these follow now the argument style of `htmlTable` - Added `txtRound` for rounding matrices. The problem with `round()` is that 1.01 rounds to 1 instead of "1.0" that is wanted for output. - Multiple bug-fixes htmlTable/inst/0000755000176200001440000000000014646657237013167 5ustar liggesusershtmlTable/inst/html_components/0000755000176200001440000000000013407215301016350 5ustar liggesusershtmlTable/inst/html_components/button.html0000644000176200001440000000034013407215301020546 0ustar liggesusers
%sign%
htmlTable/inst/examples/0000755000176200001440000000000014165130172014761 5ustar liggesusershtmlTable/inst/examples/data-SCB_example.R0000644000176200001440000000172213407215301020133 0ustar liggesusers\dontrun{ # The data was generated through downloading via the API library(pxweb) # Get the last 15 years of data (the data always lags 1 year) current_year <- as.integer(format(Sys.Date(), "%Y")) -1 SCB <- get_pxweb_data( url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", dims = list(Region = c('00', '01', '03', '25'), Kon = c('1', '2'), ContentsCode = c('BE0101G9'), Tid = (current_year-14):current_year), clean = TRUE) # Some cleaning was needed before use SCB$region <- factor(substring(as.character(SCB$region), 4)) Swe_ltrs <- c("å" = "å", "Å" = "Å", "ä" = "ä", "Ä" = "Ä", "ö" = "ö", "Ö" = "Ö") for (i in 1:length(Swe_ltrs)){ levels(SCB$region) <- gsub(names(Swe_ltrs)[i], Swe_ltrs[i], levels(SCB$region)) } save(SCB, file = "data/SCB.rda") } htmlTable/inst/examples/tidyHtmlTable_example.R0000644000176200001440000000255714165130172021376 0ustar liggesuserslibrary(tibble) library(dplyr) library(tidyr) # Prep and select basic data data("mtcars") base_data <- mtcars %>% rownames_to_column() %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) %>% select(rowname, cyl, gear, wt, mpg, qsec) base_data %>% pivot_longer(names_to = "per_metric", cols = c(wt, mpg, qsec)) %>% group_by(cyl, gear, per_metric) %>% summarise(value_Mean = round(mean(value), 1), value_Min = round(min(value), 1), value_Max = round(max(value), 1), .groups = "drop") %>% pivot_wider(names_from = per_metric, values_from = starts_with("value_")) %>% # Round the values into a nicer format where we want the weights to have two decimals txtRound(ends_with("_wt"), digits = 2) %>% txtRound(starts_with("value") & !ends_with("_wt"), digits = 1) %>% # Convert into long format pivot_longer(cols = starts_with("value_"), names_prefix = "value_") %>% separate(name, into = c("summary_stat", "per_metric")) %>% # Without sorting the row groups wont appear right # If the columns end up in the wrong order you may want to change the columns # into factors arrange(per_metric) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable( header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric, skip_removal_warning = TRUE) htmlTable/inst/examples/interactiveTable_example.R0000644000176200001440000000144013701421460022101 0ustar liggesuserslibrary(magrittr) # A simple output long_txt <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" short_txt <- gsub("(^[^.]+).*", "\\1", long_txt) cbind(rep(short_txt, 2), rep(long_txt, 2)) %>% addHtmlTableStyle(col.rgroup = c("#FFF", "#EEF")) %>% interactiveTable(minimized.columns = ncol(.), header = c("Short", "Long"), rnames = c("First", "Second")) htmlTable/inst/examples/htmlTable_example.R0000644000176200001440000000646314165130172020544 0ustar liggesuserslibrary(magrittr) # Basic example output <- matrix(1:4, ncol = 2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) invisible(readline(prompt = "Press [enter] to continue")) # An advanced output output <- matrix(ncol = 6, nrow = 8) for (nr in 1:nrow(output)) { for (nc in 1:ncol(output)) { output[nr, nc] <- paste0(nr, ":", nc) } } output %>% addHtmlTableStyle(align = "r", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") %>% htmlTable(header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment", cspan.rgroup = 2) invisible(readline(prompt = "Press [enter] to continue")) # An advanced empty table suppressWarnings({ matrix(ncol = 6, nrow = 0) %>% addHtmlTableStyle(col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") %>% htmlTable(align = "r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption = "Basic empty table with column spanners (groups) and ignored row colors", tfoot = "† A table footer commment", cspan.rgroup = 2) }) invisible(readline(prompt = "Press [enter] to continue")) # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol = 2) simple_output %>% addHtmlTableStyle(css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times = ncol(simple_output)), matrix("", ncol = ncol(simple_output), nrow = nrow(simple_output)))) %>% htmlTable(header = LETTERS[1:2]) invisible(readline(prompt = "Press [enter] to continue")) # See vignette("tables", package = "htmlTable") # for more examples, also check out tidyHtmlTable() that manages # the group arguments for you through tidy-select syntax htmlTable/inst/examples/concatHtmlTables_example.R0000644000176200001440000000306714165130172022054 0ustar liggesuserslibrary(magrittr) # Basic example tables <- list() output <- matrix(1:4, ncol = 2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) tables[["Simple table"]] <- htmlTable(output) # An advanced output output <- matrix(ncol = 6, nrow = 8) for (nr in 1:nrow(output)) { for (nc in 1:ncol(output)) { output[nr, nc] <- paste0(nr, ":", nc) } } tables[["Fancy table"]] <- output %>% addHtmlTableStyle(align = "r", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") %>% htmlTable(header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment", cspan.rgroup = 2) concatHtmlTables(tables) htmlTable/inst/htmlwidgets/0000755000176200001440000000000014261642754015511 5ustar liggesusershtmlTable/inst/htmlwidgets/htmlTableWidget.yaml0000644000176200001440000000041514261642754021455 0ustar liggesusersdependencies: - name: jquery version: 3.6.0 src: "htmlwidgets/lib/jquery" script: jquery.min.js - name: table_pagination version: 0.1.0 src: "htmlwidgets/lib/table_pagination" script: table_pagination.js stylesheet: table_pagination.css htmlTable/inst/htmlwidgets/htmlTableWidget.js0000644000176200001440000000205713407215301021114 0ustar liggesusersHTMLWidgets.widget({ name: 'htmlTableWidget', type: 'output', factory: function(el, width, height) { return { renderValue: function(x) { $(el).empty(); // Select number of rows to see: var select_entries_div = document.createElement('div'); var select_entries_div_id = (el.id).concat('_entries'); $(select_entries_div).attr('id', select_entries_div_id); $(el).append(select_entries_div); // Add the table: $(el).append(x.thetable); /// The navigation bar: var nav_obj = document.createElement('div'); var nav_id = (el.id).concat('_nav'); $(nav_obj).attr('id', nav_id); $(el).append(nav_obj); // Set instance variables: var thetable = $(el).find('table'); $(el).css("position","relative"); $(el).css("clear","both"); $(thetable).css("width","100%"); table_pagination(thetable, nav_id, select_entries_div_id, x.options, el); }, resize: function(width, height) { } }; } }); htmlTable/inst/htmlwidgets/lib/0000755000176200001440000000000013407215301016240 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/table_pagination/0000755000176200001440000000000013407215301021540 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/table_pagination/table_pagination.js0000644000176200001440000001341613407215301025403 0ustar liggesusers/** * Refreshes the table and the navigation bar * @param table the table to paginate * @param nav_id the div where the pagination menu will appear * @param currPage the page of the table to show * @param rowsShown the number of rows to show per page */ function refresh_table(table, nav_id, currPage, rowsShown) { "use strict"; function append_link_to_page(pagenum, text, container) { var pagelink; pagelink = document.createElement("a"); $(pagelink).attr('href','#').attr('data-page', pagenum). addClass('page_button').text(text); $(container).append(pagelink); return pagelink; } function showing_x_to_y_of_z_entries(startItem, endItem, rowsTotal) { var showing_entries_div = document.createElement('div'); $(showing_entries_div).attr('id', 'showing_entries_div'); if (+rowsTotal === 0) { $(showing_entries_div).append('No entries.'); } else { $(showing_entries_div).append('Showing ' +(+startItem+1) + ' to ' +endItem + ' of ' +rowsTotal + ' entries.'); } return showing_entries_div; } function first_previous_1_2_3_4_next_last(currPage, numPages, table, nav_id, rowsShown) { // First Previous 4 5 6 7 8 9 10 Next Last var page_numbers_div = document.createElement('div'); if (numPages <= 1) { // Empty div if there are no pages to change return page_numbers_div; } $(page_numbers_div).attr('id', 'page_numbers_div'); // Page: First and Previous var pagefirst = append_link_to_page(0, 'First', page_numbers_div); var pageprev = append_link_to_page(+currPage-1, 'Previous', page_numbers_div); if (+currPage === 0) { $(pagefirst).addClass('page_button_disabled'); $(pageprev).addClass('page_button_disabled'); } var spanpagenumber = document.createElement('span'); $(page_numbers_div).append(spanpagenumber); var start_nearby_pages = Math.max(0, +currPage-3); var end_nearby_pages = Math.min(+numPages-1, +currPage+3); for (var i = start_nearby_pages; i <= end_nearby_pages; i++) { // Page: i var page_i = append_link_to_page(i, 1+i, spanpagenumber); if (+currPage === +i) { $(page_i).addClass('page_button_current'); } } // Page: Next and Last var pagenext = append_link_to_page(+currPage+1, "Next", page_numbers_div); var pagelast = append_link_to_page(+numPages-1, "Last", page_numbers_div); if (+currPage === +numPages-1) { $(pagenext).addClass('page_button_disabled'); $(pagelast).addClass('page_button_disabled'); } $(page_numbers_div).find('a').bind('click', function() { var currPage = $(this).attr('data-page'); refresh_table(table, nav_id, +currPage, +rowsShown); }); return page_numbers_div; } var navobj = document.getElementById(nav_id); var rowsTotal = $(table).find('tbody').find('tr').length; var startItem = currPage * rowsShown; var endItem = Math.min(startItem + rowsShown, rowsTotal); var numPages; if (+rowsShown > 0) { numPages = Math.ceil(1.0*rowsTotal/rowsShown); } else { numPages = 0; } // Show the chosen rows: $(table).find('tbody').find('tr').css('opacity','0.0').hide().slice(startItem, endItem). css('display','table-row').animate({opacity:1}, 300); // Rewrite the navigation panel below the table on each page click $(navobj).empty(); // Showing 31 to 40 entries out of 150 entries: $(navobj).append(showing_x_to_y_of_z_entries(startItem, endItem, rowsTotal)); // First Previous 1 2 3 4 5 Next Last $(navobj).append(first_previous_1_2_3_4_next_last(currPage, numPages, table, nav_id, rowsShown)); } /** * Adds pagination options to a table * @param table the table to be paginated * @param nav_id A string with the id of the div that will contain both the "Showing 11 to 20 of 100 entries" and the pagination buttons (First Previous 1 2 3 Next Last) * @param select_entries_div_id A string with the id of the div where "Show [10|25|100] entries" selection box will be placed * @param options Currently only one option accepted: options.number_of_entries = [10, 20, 30]. It controls the possible number of rows per page to show. */ function table_pagination(table, nav_id, select_entries_div_id, options) { "use strict"; //
var select_entries_div = document.getElementById(select_entries_div_id); $(select_entries_div).empty(); // Get the possible entries per page: var select_entries_allowed = options.number_of_entries; if (select_entries_allowed.length === 0) { select_entries_allowed = [10, 25, 100]; } // If select_entries_allowed is a scalar, do not offer a select: if (!$.isArray(select_entries_allowed)) { refresh_table(table, nav_id, 0, +select_entries_allowed); return; } // Otherwise show the select menu: var label_entries = document.createElement('label'); var select_entries = document.createElement('select'); var select_entries_id = select_entries_div_id.concat('_select'); $(label_entries).attr('for', select_entries_id); $(label_entries).append('Show '); $(select_entries).attr('id', select_entries_id); for (var i=0;i+~]|"+ge+")"+ge+"*"),x=new RegExp(ge+"|>"),j=new RegExp(g),A=new RegExp("^"+t+"$"),D={ID:new RegExp("^#("+t+")"),CLASS:new RegExp("^\\.("+t+")"),TAG:new RegExp("^("+t+"|[*])"),ATTR:new RegExp("^"+p),PSEUDO:new RegExp("^"+g),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+ge+"*(even|odd|(([+-]|)(\\d*)n|)"+ge+"*(?:([+-]|)"+ge+"*(\\d+)|))"+ge+"*\\)|)","i"),bool:new RegExp("^(?:"+f+")$","i"),needsContext:new RegExp("^"+ge+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+ge+"*((?:-\\d)?\\d*)"+ge+"*\\)|)(?=[^-]|$)","i")},N=/^(?:input|select|textarea|button)$/i,q=/^h\d$/i,L=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,H=/[+~]/,O=new RegExp("\\\\[\\da-fA-F]{1,6}"+ge+"?|\\\\([^\\r\\n\\f])","g"),P=function(e,t){var n="0x"+e.slice(1)-65536;return t||(n<0?String.fromCharCode(n+65536):String.fromCharCode(n>>10|55296,1023&n|56320))},M=function(){V()},R=J(function(e){return!0===e.disabled&&fe(e,"fieldset")},{dir:"parentNode",next:"legend"});try{k.apply(oe=ae.call(ye.childNodes),ye.childNodes),oe[ye.childNodes.length].nodeType}catch(e){k={apply:function(e,t){me.apply(e,ae.call(t))},call:function(e){me.apply(e,ae.call(arguments,1))}}}function I(t,e,n,r){var i,o,a,s,u,l,c,f=e&&e.ownerDocument,p=e?e.nodeType:9;if(n=n||[],"string"!=typeof t||!t||1!==p&&9!==p&&11!==p)return n;if(!r&&(V(e),e=e||T,C)){if(11!==p&&(u=L.exec(t)))if(i=u[1]){if(9===p){if(!(a=e.getElementById(i)))return n;if(a.id===i)return k.call(n,a),n}else if(f&&(a=f.getElementById(i))&&I.contains(e,a)&&a.id===i)return k.call(n,a),n}else{if(u[2])return k.apply(n,e.getElementsByTagName(t)),n;if((i=u[3])&&e.getElementsByClassName)return k.apply(n,e.getElementsByClassName(i)),n}if(!(h[t+" "]||d&&d.test(t))){if(c=t,f=e,1===p&&(x.test(t)||m.test(t))){(f=H.test(t)&&U(e.parentNode)||e)==e&&le.scope||((s=e.getAttribute("id"))?s=ce.escapeSelector(s):e.setAttribute("id",s=S)),o=(l=Y(t)).length;while(o--)l[o]=(s?"#"+s:":scope")+" "+Q(l[o]);c=l.join(",")}try{return k.apply(n,f.querySelectorAll(c)),n}catch(e){h(t,!0)}finally{s===S&&e.removeAttribute("id")}}}return re(t.replace(ve,"$1"),e,n,r)}function W(){var r=[];return function e(t,n){return r.push(t+" ")>b.cacheLength&&delete e[r.shift()],e[t+" "]=n}}function F(e){return e[S]=!0,e}function $(e){var t=T.createElement("fieldset");try{return!!e(t)}catch(e){return!1}finally{t.parentNode&&t.parentNode.removeChild(t),t=null}}function B(t){return function(e){return fe(e,"input")&&e.type===t}}function _(t){return function(e){return(fe(e,"input")||fe(e,"button"))&&e.type===t}}function z(t){return function(e){return"form"in e?e.parentNode&&!1===e.disabled?"label"in e?"label"in e.parentNode?e.parentNode.disabled===t:e.disabled===t:e.isDisabled===t||e.isDisabled!==!t&&R(e)===t:e.disabled===t:"label"in e&&e.disabled===t}}function X(a){return F(function(o){return o=+o,F(function(e,t){var n,r=a([],e.length,o),i=r.length;while(i--)e[n=r[i]]&&(e[n]=!(t[n]=e[n]))})})}function U(e){return e&&"undefined"!=typeof e.getElementsByTagName&&e}function V(e){var t,n=e?e.ownerDocument||e:ye;return n!=T&&9===n.nodeType&&n.documentElement&&(r=(T=n).documentElement,C=!ce.isXMLDoc(T),i=r.matches||r.webkitMatchesSelector||r.msMatchesSelector,r.msMatchesSelector&&ye!=T&&(t=T.defaultView)&&t.top!==t&&t.addEventListener("unload",M),le.getById=$(function(e){return r.appendChild(e).id=ce.expando,!T.getElementsByName||!T.getElementsByName(ce.expando).length}),le.disconnectedMatch=$(function(e){return i.call(e,"*")}),le.scope=$(function(){return T.querySelectorAll(":scope")}),le.cssHas=$(function(){try{return T.querySelector(":has(*,:jqfake)"),!1}catch(e){return!0}}),le.getById?(b.filter.ID=function(e){var t=e.replace(O,P);return function(e){return e.getAttribute("id")===t}},b.find.ID=function(e,t){if("undefined"!=typeof t.getElementById&&C){var n=t.getElementById(e);return n?[n]:[]}}):(b.filter.ID=function(e){var n=e.replace(O,P);return function(e){var t="undefined"!=typeof e.getAttributeNode&&e.getAttributeNode("id");return t&&t.value===n}},b.find.ID=function(e,t){if("undefined"!=typeof t.getElementById&&C){var n,r,i,o=t.getElementById(e);if(o){if((n=o.getAttributeNode("id"))&&n.value===e)return[o];i=t.getElementsByName(e),r=0;while(o=i[r++])if((n=o.getAttributeNode("id"))&&n.value===e)return[o]}return[]}}),b.find.TAG=function(e,t){return"undefined"!=typeof t.getElementsByTagName?t.getElementsByTagName(e):t.querySelectorAll(e)},b.find.CLASS=function(e,t){if("undefined"!=typeof t.getElementsByClassName&&C)return t.getElementsByClassName(e)},d=[],$(function(e){var t;r.appendChild(e).innerHTML="",e.querySelectorAll("[selected]").length||d.push("\\["+ge+"*(?:value|"+f+")"),e.querySelectorAll("[id~="+S+"-]").length||d.push("~="),e.querySelectorAll("a#"+S+"+*").length||d.push(".#.+[+~]"),e.querySelectorAll(":checked").length||d.push(":checked"),(t=T.createElement("input")).setAttribute("type","hidden"),e.appendChild(t).setAttribute("name","D"),r.appendChild(e).disabled=!0,2!==e.querySelectorAll(":disabled").length&&d.push(":enabled",":disabled"),(t=T.createElement("input")).setAttribute("name",""),e.appendChild(t),e.querySelectorAll("[name='']").length||d.push("\\["+ge+"*name"+ge+"*="+ge+"*(?:''|\"\")")}),le.cssHas||d.push(":has"),d=d.length&&new RegExp(d.join("|")),l=function(e,t){if(e===t)return a=!0,0;var n=!e.compareDocumentPosition-!t.compareDocumentPosition;return n||(1&(n=(e.ownerDocument||e)==(t.ownerDocument||t)?e.compareDocumentPosition(t):1)||!le.sortDetached&&t.compareDocumentPosition(e)===n?e===T||e.ownerDocument==ye&&I.contains(ye,e)?-1:t===T||t.ownerDocument==ye&&I.contains(ye,t)?1:o?se.call(o,e)-se.call(o,t):0:4&n?-1:1)}),T}for(e in I.matches=function(e,t){return I(e,null,null,t)},I.matchesSelector=function(e,t){if(V(e),C&&!h[t+" "]&&(!d||!d.test(t)))try{var n=i.call(e,t);if(n||le.disconnectedMatch||e.document&&11!==e.document.nodeType)return n}catch(e){h(t,!0)}return 0":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(e){return e[1]=e[1].replace(O,P),e[3]=(e[3]||e[4]||e[5]||"").replace(O,P),"~="===e[2]&&(e[3]=" "+e[3]+" "),e.slice(0,4)},CHILD:function(e){return e[1]=e[1].toLowerCase(),"nth"===e[1].slice(0,3)?(e[3]||I.error(e[0]),e[4]=+(e[4]?e[5]+(e[6]||1):2*("even"===e[3]||"odd"===e[3])),e[5]=+(e[7]+e[8]||"odd"===e[3])):e[3]&&I.error(e[0]),e},PSEUDO:function(e){var t,n=!e[6]&&e[2];return D.CHILD.test(e[0])?null:(e[3]?e[2]=e[4]||e[5]||"":n&&j.test(n)&&(t=Y(n,!0))&&(t=n.indexOf(")",n.length-t)-n.length)&&(e[0]=e[0].slice(0,t),e[2]=n.slice(0,t)),e.slice(0,3))}},filter:{TAG:function(e){var t=e.replace(O,P).toLowerCase();return"*"===e?function(){return!0}:function(e){return fe(e,t)}},CLASS:function(e){var t=s[e+" "];return t||(t=new RegExp("(^|"+ge+")"+e+"("+ge+"|$)"))&&s(e,function(e){return t.test("string"==typeof e.className&&e.className||"undefined"!=typeof e.getAttribute&&e.getAttribute("class")||"")})},ATTR:function(n,r,i){return function(e){var t=I.attr(e,n);return null==t?"!="===r:!r||(t+="","="===r?t===i:"!="===r?t!==i:"^="===r?i&&0===t.indexOf(i):"*="===r?i&&-1:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i;function T(e,n,r){return v(n)?ce.grep(e,function(e,t){return!!n.call(e,t,e)!==r}):n.nodeType?ce.grep(e,function(e){return e===n!==r}):"string"!=typeof n?ce.grep(e,function(e){return-1)[^>]*|#([\w-]+))$/;(ce.fn.init=function(e,t,n){var r,i;if(!e)return this;if(n=n||k,"string"==typeof e){if(!(r="<"===e[0]&&">"===e[e.length-1]&&3<=e.length?[null,e,null]:S.exec(e))||!r[1]&&t)return!t||t.jquery?(t||n).find(e):this.constructor(t).find(e);if(r[1]){if(t=t instanceof ce?t[0]:t,ce.merge(this,ce.parseHTML(r[1],t&&t.nodeType?t.ownerDocument||t:C,!0)),w.test(r[1])&&ce.isPlainObject(t))for(r in t)v(this[r])?this[r](t[r]):this.attr(r,t[r]);return this}return(i=C.getElementById(r[2]))&&(this[0]=i,this.length=1),this}return e.nodeType?(this[0]=e,this.length=1,this):v(e)?void 0!==n.ready?n.ready(e):e(ce):ce.makeArray(e,this)}).prototype=ce.fn,k=ce(C);var E=/^(?:parents|prev(?:Until|All))/,j={children:!0,contents:!0,next:!0,prev:!0};function A(e,t){while((e=e[t])&&1!==e.nodeType);return e}ce.fn.extend({has:function(e){var t=ce(e,this),n=t.length;return this.filter(function(){for(var e=0;e\x20\t\r\n\f]*)/i,Ce=/^$|^module$|\/(?:java|ecma)script/i;xe=C.createDocumentFragment().appendChild(C.createElement("div")),(be=C.createElement("input")).setAttribute("type","radio"),be.setAttribute("checked","checked"),be.setAttribute("name","t"),xe.appendChild(be),le.checkClone=xe.cloneNode(!0).cloneNode(!0).lastChild.checked,xe.innerHTML="",le.noCloneChecked=!!xe.cloneNode(!0).lastChild.defaultValue,xe.innerHTML="",le.option=!!xe.lastChild;var ke={thead:[1,"","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};function Se(e,t){var n;return n="undefined"!=typeof e.getElementsByTagName?e.getElementsByTagName(t||"*"):"undefined"!=typeof e.querySelectorAll?e.querySelectorAll(t||"*"):[],void 0===t||t&&fe(e,t)?ce.merge([e],n):n}function Ee(e,t){for(var n=0,r=e.length;n",""]);var je=/<|&#?\w+;/;function Ae(e,t,n,r,i){for(var o,a,s,u,l,c,f=t.createDocumentFragment(),p=[],d=0,h=e.length;d\s*$/g;function Re(e,t){return fe(e,"table")&&fe(11!==t.nodeType?t:t.firstChild,"tr")&&ce(e).children("tbody")[0]||e}function Ie(e){return e.type=(null!==e.getAttribute("type"))+"/"+e.type,e}function We(e){return"true/"===(e.type||"").slice(0,5)?e.type=e.type.slice(5):e.removeAttribute("type"),e}function Fe(e,t){var n,r,i,o,a,s;if(1===t.nodeType){if(_.hasData(e)&&(s=_.get(e).events))for(i in _.remove(t,"handle events"),s)for(n=0,r=s[i].length;n").attr(n.scriptAttrs||{}).prop({charset:n.scriptCharset,src:n.url}).on("load error",i=function(e){r.remove(),i=null,e&&t("error"===e.type?404:200,e.type)}),C.head.appendChild(r[0])},abort:function(){i&&i()}}});var Jt,Kt=[],Zt=/(=)\?(?=&|$)|\?\?/;ce.ajaxSetup({jsonp:"callback",jsonpCallback:function(){var e=Kt.pop()||ce.expando+"_"+jt.guid++;return this[e]=!0,e}}),ce.ajaxPrefilter("json jsonp",function(e,t,n){var r,i,o,a=!1!==e.jsonp&&(Zt.test(e.url)?"url":"string"==typeof e.data&&0===(e.contentType||"").indexOf("application/x-www-form-urlencoded")&&Zt.test(e.data)&&"data");if(a||"jsonp"===e.dataTypes[0])return r=e.jsonpCallback=v(e.jsonpCallback)?e.jsonpCallback():e.jsonpCallback,a?e[a]=e[a].replace(Zt,"$1"+r):!1!==e.jsonp&&(e.url+=(At.test(e.url)?"&":"?")+e.jsonp+"="+r),e.converters["script json"]=function(){return o||ce.error(r+" was not called"),o[0]},e.dataTypes[0]="json",i=ie[r],ie[r]=function(){o=arguments},n.always(function(){void 0===i?ce(ie).removeProp(r):ie[r]=i,e[r]&&(e.jsonpCallback=t.jsonpCallback,Kt.push(r)),o&&v(i)&&i(o[0]),o=i=void 0}),"script"}),le.createHTMLDocument=((Jt=C.implementation.createHTMLDocument("").body).innerHTML="
",2===Jt.childNodes.length),ce.parseHTML=function(e,t,n){return"string"!=typeof e?[]:("boolean"==typeof t&&(n=t,t=!1),t||(le.createHTMLDocument?((r=(t=C.implementation.createHTMLDocument("")).createElement("base")).href=C.location.href,t.head.appendChild(r)):t=C),o=!n&&[],(i=w.exec(e))?[t.createElement(i[1])]:(i=Ae([e],t,o),o&&o.length&&ce(o).remove(),ce.merge([],i.childNodes)));var r,i,o},ce.fn.load=function(e,t,n){var r,i,o,a=this,s=e.indexOf(" ");return-1").append(ce.parseHTML(e)).find(r):e)}).always(n&&function(e,t){a.each(function(){n.apply(this,o||[e.responseText,t,e])})}),this},ce.expr.pseudos.animated=function(t){return ce.grep(ce.timers,function(e){return t===e.elem}).length},ce.offset={setOffset:function(e,t,n){var r,i,o,a,s,u,l=ce.css(e,"position"),c=ce(e),f={};"static"===l&&(e.style.position="relative"),s=c.offset(),o=ce.css(e,"top"),u=ce.css(e,"left"),("absolute"===l||"fixed"===l)&&-1<(o+u).indexOf("auto")?(a=(r=c.position()).top,i=r.left):(a=parseFloat(o)||0,i=parseFloat(u)||0),v(t)&&(t=t.call(e,n,ce.extend({},s))),null!=t.top&&(f.top=t.top-s.top+a),null!=t.left&&(f.left=t.left-s.left+i),"using"in t?t.using.call(e,f):c.css(f)}},ce.fn.extend({offset:function(t){if(arguments.length)return void 0===t?this:this.each(function(e){ce.offset.setOffset(this,t,e)});var e,n,r=this[0];return r?r.getClientRects().length?(e=r.getBoundingClientRect(),n=r.ownerDocument.defaultView,{top:e.top+n.pageYOffset,left:e.left+n.pageXOffset}):{top:0,left:0}:void 0},position:function(){if(this[0]){var e,t,n,r=this[0],i={top:0,left:0};if("fixed"===ce.css(r,"position"))t=r.getBoundingClientRect();else{t=this.offset(),n=r.ownerDocument,e=r.offsetParent||n.documentElement;while(e&&(e===n.body||e===n.documentElement)&&"static"===ce.css(e,"position"))e=e.parentNode;e&&e!==r&&1===e.nodeType&&((i=ce(e).offset()).top+=ce.css(e,"borderTopWidth",!0),i.left+=ce.css(e,"borderLeftWidth",!0))}return{top:t.top-i.top-ce.css(r,"marginTop",!0),left:t.left-i.left-ce.css(r,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var e=this.offsetParent;while(e&&"static"===ce.css(e,"position"))e=e.offsetParent;return e||J})}}),ce.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(t,i){var o="pageYOffset"===i;ce.fn[t]=function(e){return M(this,function(e,t,n){var r;if(y(e)?r=e:9===e.nodeType&&(r=e.defaultView),void 0===n)return r?r[i]:e[t];r?r.scrollTo(o?r.pageXOffset:n,o?n:r.pageYOffset):e[t]=n},t,e,arguments.length)}}),ce.each(["top","left"],function(e,n){ce.cssHooks[n]=Ye(le.pixelPosition,function(e,t){if(t)return t=Ge(e,n),_e.test(t)?ce(e).position()[n]+"px":t})}),ce.each({Height:"height",Width:"width"},function(a,s){ce.each({padding:"inner"+a,content:s,"":"outer"+a},function(r,o){ce.fn[o]=function(e,t){var n=arguments.length&&(r||"boolean"!=typeof e),i=r||(!0===e||!0===t?"margin":"border");return M(this,function(e,t,n){var r;return y(e)?0===o.indexOf("outer")?e["inner"+a]:e.document.documentElement["client"+a]:9===e.nodeType?(r=e.documentElement,Math.max(e.body["scroll"+a],r["scroll"+a],e.body["offset"+a],r["offset"+a],r["client"+a])):void 0===n?ce.css(e,t,i):ce.style(e,t,n,i)},s,n?e:void 0,n)}})}),ce.each(["ajaxStart","ajaxStop","ajaxComplete","ajaxError","ajaxSuccess","ajaxSend"],function(e,t){ce.fn[t]=function(e){return this.on(t,e)}}),ce.fn.extend({bind:function(e,t,n){return this.on(e,null,t,n)},unbind:function(e,t){return this.off(e,null,t)},delegate:function(e,t,n,r){return this.on(t,e,n,r)},undelegate:function(e,t,n){return 1===arguments.length?this.off(e,"**"):this.off(t,e||"**",n)},hover:function(e,t){return this.on("mouseenter",e).on("mouseleave",t||e)}}),ce.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(e,n){ce.fn[n]=function(e,t){return 0 Gilles van den Hoven Michael Geary Stefan Petre Yehuda Katz Corey Jewett Klaus Hartl Franck Marcia Jörn Zaefferer Paul Bakaus Brandon Aaron Mike Alsup Dave Methvin Ed Engelhardt Sean Catchpole Paul Mclanahan David Serduke Richard D. Worth Scott González Ariel Flesler Cheah Chu Yeow Andrew Chalkley Fabio Buffoni Stefan Bauckmeier Jon Evans TJ Holowaychuk Riccardo De Agostini Michael Bensoussan Louis-Rémi Babé Robert Katić Damian Janowski Anton Kovalyov Dušan B. Jovanovic Earle Castledine Rich Dougherty Kim Dalsgaard Andrea Giammarchi Fabian Jakobs Mark Gibson Karl Swedberg Justin Meyer Ben Alman James Padolsey David Petersen Batiste Bieler Jake Archibald Alexander Farkas Filipe Fortes Rick Waldron Neeraj Singh Paul Irish Iraê Carvalho Matt Curry Michael Monteleone Noah Sloan Tom Viner J. Ryan Stinnett Douglas Neiner Adam J. Sontag Heungsub Lee Dave Reed Carl Fürstenberg Jacob Wright Ralph Whitbeck unknown temp01 Colin Snover Jared Grippe Ryan W Tenney Alex Sexton Pinhook Ron Otten Jephte Clain Anton Matzneller Dan Heberden Henri Wiechers Russell Holbrook Julian Aubourg Gianni Alessandro Chiappetta Scott Jehl James Burke Jonas Pfenniger Xavi Ramirez Sylvester Keil Brandon Sterne Mathias Bynens Lee Carpenter Timmy Willison <4timmywil@gmail.com> Corey Frang Digitalxero David Murdoch Josh Varner Charles McNulty Jordan Boesch Jess Thrysoee Michael Murray Alexis Abril Rob Morgan John Firebaugh Sam Bisbee Gilmore Davidson Brian Brennan Xavier Montillet Daniel Pihlstrom Sahab Yazdani avaly Scott Hughes Mike Sherov Greg Hazel Schalk Neethling Denis Knauf Timo Tijhof Steen Nielsen Anton Ryzhov Shi Chuan Matt Mueller Berker Peksag Toby Brain Justin Daniel Herman Oleg Gaidarenko Rock Hymas Richard Gibson Rafaël Blais Masson cmc3cn <59194618@qq.com> Joe Presbrey Sindre Sorhus Arne de Bree Vladislav Zarakovsky Andrew E Monat Oskari Joao Henrique de Andrade Bruni tsinha Dominik D. Geyer Matt Farmer Trey Hunner Jason Moon Jeffery To Kris Borchers Vladimir Zhuravlev Jacob Thornton Chad Killingsworth Vitya Muhachev Nowres Rafid David Benjamin Alan Plum Uri Gilad Chris Faulkner Marcel Greter Elijah Manor Daniel Chatfield Daniel Gálvez Nikita Govorov Wesley Walser Mike Pennisi Matthias Jäggli Devin Cooper Markus Staab Dave Riddle Callum Macrae Jonathan Sampson Benjamin Truyman Jay Merrifield James Huston Sai Lung Wong Erick Ruiz de Chávez David Bonner Allen J Schmidt Jr Akintayo Akinwunmi MORGAN Ismail Khair Carl Danley Mike Petrovich Greg Lavallee Tom H Fuertes Roland Eckl Yiming He David Fox Bennett Sorbo Paul Ramos Rod Vagg Sebastian Burkhard Zachary Adam Kaplan Adam Coulombe nanto_vi nanto Danil Somsikov Ryunosuke SATO Diego Tres Jean Boussier Andrew Plummer Mark Raddatz Pascal Borreli Isaac Z. Schlueter Karl Sieburg Nguyen Phuc Lam Dmitry Gusev Steven Benner Li Xudong Michał Gołębiowski-Owczarek Renato Oliveira dos Santos Frederic Junod Tom H Fuertes Mitch Foley ros3cin Kyle Robinson Young John Paul Jason Bedard Chris Talkington Eddie Monge Terry Jones Jason Merino Dan Burzo Jeremy Dunck Chris Price Guy Bedford njhamann Goare Mao Amey Sakhadeo Mike Sidorov Anthony Ryan Lihan Li George Kats Dongseok Paeng Ronny Springer Ilya Kantor Marian Sollmann Chris Antaki David Hong Jakob Stoeck Christopher Jones Forbes Lindesay S. Andrew Sheppard Leonardo Balter Rodrigo Rosenfeld Rosas Daniel Husar Philip Jägenstedt John Hoven Roman Reiß Benjy Cui Christian Kosmowski David Corbacho Liang Peng TJ VanToll Aurelio De Rosa Senya Pugach Dan Hart Nazar Mokrynskyi Benjamin Tan Amit Merchant Jason Bedard Veaceslav Grimalschi Richard McDaniel Arthur Verschaeve Shivaji Varma Ben Toews Bin Xin Neftaly Hernandez T.J. Crowder Nicolas HENRY Frederic Hemberger Victor Homyakov Aditya Raghavan Anne-Gaelle Colom Leonardo Braga George Mauer Stephen Edgar Thomas Tortorini Jörn Wagner Jon Hester Colin Frick Winston Howes Alexander O'Mara Chris Rebert Bastian Buchholz Mu Haibao Calvin Metcalf Arthur Stolyar Gabriel Schulhof Gilad Peleg Julian Alexander Murillo Kevin Kirsche Martin Naumann Yongwoo Jeon John-David Dalton Marek Lewandowski Bruno Pérel Daniel Nill Reed Loden Sean Henderson Gary Ye Richard Kraaijenhagen Connor Atherton Christian Grete Tom von Clef Liza Ramo Joelle Fleurantin Steve Mao Jon Dufresne Jae Sung Park Josh Soref Saptak Sengupta Henry Wong Jun Sun Martijn W. van der Lee Devin Wilson Damian Senn Zack Hall Vitaliy Terziev Todor Prikumov Bernhard M. Wiedemann Jha Naman Alexander Lisianoi William Robinet Joe Trumbull Alexander K Ralin Chimev Felipe Sateler Christophe Tafani-Dereeper Manoj Kumar David Broder-Rodgers Alex Louden Alex Padilla karan-96 南漂一卒 Erik Lax Boom Lee Andreas Solleder Pierre Spring Shashanka Nataraj CDAGaming Matan Kotler-Berkowitz <205matan@gmail.com> Jordan Beland Henry Zhu Nilton Cesar basil.belokon Andrey Meshkov tmybr11 Luis Emilio Velasco Sanchez Ed S Bert Zhang Sébastien Règne wartmanm <3869625+wartmanm@users.noreply.github.com> Siddharth Dungarwal abnud1 Andrei Fangli Marja Hölttä buddh4 Hoang Wonseop Kim Pat O'Callaghan JuanMa Ruiz Ahmed.S.ElAfifi Sean Robinson Christian Oliff htmlTable/inst/javascript/0000755000176200001440000000000013407215301015305 5ustar liggesusershtmlTable/inst/javascript/toggler.js0000644000176200001440000000237113407215301017311 0ustar liggesusers$(document).ready(function(){ $(".gmisc_table td .hidden").map(function(index, el){ el.parentNode.style["original-color"] = el.parentNode.style["background-color"]; el.parentNode.style["background-color"] = "#DDD"; }); getSelected = function(){ var t = ''; if(window.getSelection){ t = window.getSelection(); }else if(document.getSelection){ t = document.getSelection(); }else if(document.selection){ t = document.selection.createRange().text; } return t.toString(); }; $(".gmisc_table td").map(function(index, el){ this.style.cursor = "pointer"; el.onmouseup = function(e){ if (getSelected().length > 0) return; var hidden = this.getElementsByClassName("hidden"); if (hidden.length > 0){ this.innerHTML = hidden[0].textContent; this.style["background-color"] = this.style["original-color"]; }else{ $(this).append(""); this.childNodes[0].data = this.childNodes[0].data.substr(0, 20) + "... "; this.style["original-color"] = this.style["background-color"]; this.style["background-color"] = "#DDD"; } }; }); }); htmlTable/inst/javascript/button.js0000644000176200001440000000155613407215301017165 0ustar liggesusers$(document).ready(function(){ // Placeholder for button btn = "%btn%"; // Ad the button to each element $(".gmisc_table td").map(function(index, el){ if (el.innerHTML.length > %txt.maxlen% && el.getElementsByClassName("btn").length == 0) el.innerHTML += btn; }) $(".gmisc_table td .btn").map(function(index, el){ el.onclick = function(e){ var hidden = this.parentNode.getElementsByClassName("hidden"); if (this.textContent === "+"){ this.parentNode.childNodes[0].data = hidden[0].textContent; this.textContent = "-"; }else{ $(this.parentNode).append("") this.parentNode.childNodes[0].data = this.parentNode.textContent.substr(0, %txt.maxlen%) + "... "; this.textContent = "+"; } } }) }) htmlTable/inst/doc/0000755000176200001440000000000014646657237013734 5ustar liggesusershtmlTable/inst/doc/tidyHtmlTable.Rmd0000644000176200001440000000470213701421460017123 0ustar liggesusers--- title: "Using tidyHtmlTable" author: "Stephen Gragg" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using tidyHtmlTable} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- # Introduction `tidyHtmlTable` acts as a wrapper function for the `htmlTable` function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2. # Some Examples ## Prepare Data We'll begin by turning the `mtcars` data into a tidy dataset. The `pivot_longer` function is called to collect 3 performance metrics into a pair of key and value columns. ```{r, message=FALSE} library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% as_tibble(rownames = "rnames") %>% pivot_longer(names_to = "per_metric", cols = c(hp, mpg, qsec)) ``` Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears. ```{r} tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1), .groups = 'drop') %>% pivot_longer(names_to = "summary_stat", cols = c(Mean, SD, Min, Max)) %>% ungroup() %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ``` At this point, we are ready to implement the `htmlTable` function. Essentially, this constructs an html table using arguments similar to the `htmlTable` function. However, whereas `htmlTable` required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data. ## Output html table ### Example 1 ```{r, warning=FALSE} tidy_summary %>% arrange(per_metric, summary_stat) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric) ``` ### Example 2 ```{r, warning=FALSE} tidy_summary %>% arrange(cyl, gear) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = summary_stat, cgroup = per_metric, rnames = gear, rgroup = cyl) ``` htmlTable/inst/doc/complex_tables.html0000644000176200001440000127704714646657233017641 0ustar liggesusers Building a complex table

Building a complex table

Max Gordon

2024-07-20

Introduction

Tables are an essential part of publishing, well… anything. I therefore want to explore the options available for generating these in knitr. It is important to remember that there are two ways of generating tables in markdown:

  1. Markdown tables
  2. HTML tables

As the htmlTable-package is all about HTML tables we will work only with that output option. The core idea is that HTML is ubiquitous and that most word-processors will have to support copy-pasting tables and by providing simple simple CSS-formatting we are able to maximize this compatibility. Note CSS is today an extremely complex topic and it is no surprise that word-processors may have difficulty importing tables that have lots of advanced syntax, htmlTable tries to avoid all of that by putting the style close to each element, often at the cell-level.

Basics

I developed the htmlTable in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the Hmisc::latex function on Stack Overflow I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two:

library(htmlTable)

setHtmlTableTheme(theme = "Google docs")

output <-
  matrix(paste("Content", LETTERS[1:16]),
         ncol = 4, byrow = TRUE)

output |>
  htmlTable(header =  paste(c("1st", "2nd", "3rd", "4th"), "header"),
            rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"),
            rgroup = c("Group A", "Group B"),
            n.rgroup = c(2, 2),
            cgroup = c("Cgroup 1", "Cgroup 2&dagger;"),
            n.cgroup = c(2, 2),
            caption = "Basic table with both column spanners (groups) and row groups",
            tfoot = "&dagger; A table footer commment")
Cgroup 1 Cgroup 2†
1st header 2nd header 3rd header 4th header
Group A
  1st row Content A Content B Content C Content D
  2nd row Content E Content F Content G Content H
Group B
  3rd row Content I Content J Content K Content L
  4th row Content M Content N Content O Content P
Basic table with both column spanners (groups) and row groups
† A table footer commment

We can modify all our tables by using the setHtmlTableTemplate() and we also don’t have to set the exact span of each group as it can be assumed from the data.

setHtmlTableTheme(pos.caption = "bottom")

output |>
  addHtmlTableStyle(css.rgroup = "font-style: italic") |>
  htmlTable(header =  paste(c("1st", "2nd", "3rd", "4th"), "header"),
            rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"),
            rgroup = c("Group A", "Group B", ""),
            n.rgroup = c(1, 2),
            cgroup = c("Cgroup 1", "Cgroup 2&dagger;"),
            n.cgroup = 3,
            caption = "A slightly differnt table with a bottom caption",
            tfoot = "&dagger; A table footer commment")
Cgroup 1 Cgroup 2†
1st header 2nd header 3rd header 4th header
Group A
  1st row Content A Content B Content C Content D
Group B
  2nd row Content E Content F Content G Content H
  3rd row Content I Content J Content K Content L
4th row Content M Content N Content O Content P
A slightly differnt table with a bottom caption
† A table footer commment

The basic principles are:

  • use the |> pipe as much as possible
  • build complexity stepwise through passing addHtmlTableStyle() function
  • keep arguments to a minimum through templating and autocalculation

Example based upon Swedish statistics

In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. Goal: visualize migration patterns.

The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format.

data(SCB)

# The SCB has three other columns and one value column
prepped_scb <- SCB |>
  dplyr::mutate(region = relevel(SCB$region, "Sweden")) |>
  dplyr::select(year, region, sex, values) |>
  tidyr::pivot_wider(names_from = c(region, sex), values_from = values)

# Set rownames to be year
rownames(prepped_scb) <- prepped_scb$year
prepped_scb$year <- NULL

# The dataset now has the rows
names(prepped_scb)
## [1] "Sweden_men"              "Sweden_women"           
## [3] "Stockholm county_men"    "Stockholm county_women" 
## [5] "Uppsala county_men"      "Uppsala county_women"   
## [7] "Norrbotten county_men"   "Norrbotten county_women"
# and the dimensions
dim(prepped_scb)
## [1] 15  8

The next step is to calculate two new columns:

  • Δint = The change within each group since the start of the observation.
  • Δstd = The change in relation to the overall age change in Sweden.

To convey all these layers of information will create a table with multiple levels of column spanners:

County
Men   Women
Age Δint. Δext.   Age Δint. Δext.
mx <- NULL
for (n in names(prepped_scb)) {
  tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2])
  mx <- cbind(mx,
              cbind(prepped_scb[[n]],
                    prepped_scb[[n]] - prepped_scb[[n]][1],
                    prepped_scb[[n]] - prepped_scb[[tmp]]))
}
rownames(mx) <- rownames(prepped_scb)
colnames(mx) <- rep(c("Age",
                      "&Delta;<sub>int</sub>",
                      "&Delta;<sub>std</sub>"),
                    times = ncol(prepped_scb))
mx <- mx[,c(-3, -6)]

# This automated generation of cgroup elements is
# somewhat of an overkill
cgroup <-
  unique(sapply(names(prepped_scb),
                function(x) strsplit(x, "_")[[1]][1],
                USE.NAMES = FALSE))
n.cgroup <-
  sapply(cgroup,
         function(x) sum(grepl(paste0("^", x), names(prepped_scb))),
         USE.NAMES = FALSE)*3
n.cgroup[cgroup == "Sweden"] <-
  n.cgroup[cgroup == "Sweden"] - 2

cgroup <-
  rbind(c(cgroup, rep(NA, ncol(prepped_scb) - length(cgroup))),
        Hmisc::capitalize(
          sapply(names(prepped_scb),
                 function(x) strsplit(x, "_")[[1]][2],
                 USE.NAMES = FALSE)))
n.cgroup <-
  rbind(c(n.cgroup, rep(NA, ncol(prepped_scb) - length(n.cgroup))),
        c(2,2, rep(3, ncol(cgroup) - 2)))

print(cgroup)
##      [,1]     [,2]               [,3]             [,4]                [,5] 
## [1,] "Sweden" "Stockholm county" "Uppsala county" "Norrbotten county" NA   
## [2,] "Men"    "Women"            "Men"            "Women"             "Men"
##      [,6]    [,7]  [,8]   
## [1,] NA      NA    NA     
## [2,] "Women" "Men" "Women"
print(n.cgroup)
##      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## [1,]    4    6    6    6   NA   NA   NA   NA
## [2,]    2    2    3    3    3    3    3    3

Next step is to output the table after rounding to the correct number of decimals. The txtRound function helps with this, as it uses the sprintf function instead of the round the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0.

htmlTable(txtRound(mx, 1),
          cgroup = cgroup,
          n.cgroup = n.cgroup,
          rgroup = c("First period",
                     "Second period",
                     "Third period"),
          n.rgroup = rep(5, 3),
          tfoot = txtMergeLines("&Delta;<sub>int</sub> correspnds to the change since start",
                                "&Delta;<sub>std</sub> corresponds to the change compared to national average"))
Sweden Stockholm county Uppsala county Norrbotten county
Men Women Men Women Men Women Men Women
Age Δint Age Δint Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd
First period
  1 38.9 0.0 41.5 0.0 37.3 0.0 -1.6 40.1 0.0 -1.4 37.2 0.0 -1.7 39.3 0.0 -2.2 39.7 0.0 0.8 41.9 0.0 0.4
  2 39.0 0.1 41.6 0.1 37.4 0.1 -1.6 40.1 0.0 -1.5 37.5 0.3 -1.5 39.4 0.1 -2.2 40.0 0.3 1.0 42.2 0.3 0.6
  3 39.2 0.3 41.7 0.2 37.5 0.2 -1.7 40.1 0.0 -1.6 37.6 0.4 -1.6 39.6 0.3 -2.1 40.2 0.5 1.0 42.5 0.6 0.8
  4 39.3 0.4 41.8 0.3 37.6 0.3 -1.7 40.2 0.1 -1.6 37.8 0.6 -1.5 39.7 0.4 -2.1 40.5 0.8 1.2 42.8 0.9 1.0
  5 39.4 0.5 41.9 0.4 37.7 0.4 -1.7 40.2 0.1 -1.7 38.0 0.8 -1.4 39.8 0.5 -2.1 40.7 1.0 1.3 43.0 1.1 1.1
Second period
  6 39.6 0.7 42.0 0.5 37.8 0.5 -1.8 40.3 0.2 -1.7 38.1 0.9 -1.5 40.0 0.7 -2.0 40.9 1.2 1.3 43.1 1.2 1.1
  7 39.7 0.8 42.0 0.5 37.9 0.6 -1.8 40.3 0.2 -1.7 38.3 1.1 -1.4 40.1 0.8 -1.9 41.1 1.4 1.4 43.4 1.5 1.4
  8 39.8 0.9 42.1 0.6 37.9 0.6 -1.9 40.2 0.1 -1.9 38.5 1.3 -1.3 40.4 1.1 -1.7 41.3 1.6 1.5 43.5 1.6 1.4
  9 39.8 0.9 42.1 0.6 37.8 0.5 -2.0 40.1 0.0 -2.0 38.6 1.4 -1.2 40.5 1.2 -1.6 41.5 1.8 1.7 43.8 1.9 1.7
  10 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.1 0.0 -2.0 38.7 1.5 -1.2 40.5 1.2 -1.6 41.7 2.0 1.8 44.0 2.1 1.9
Third period
  11 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.0 -0.1 -2.1 38.8 1.6 -1.1 40.6 1.3 -1.5 41.9 2.2 2.0 44.2 2.3 2.1
  12 40.0 1.1 42.1 0.6 37.8 0.5 -2.2 40.0 -0.1 -2.1 38.9 1.7 -1.1 40.6 1.3 -1.5 42.1 2.4 2.1 44.4 2.5 2.3
  13 40.1 1.2 42.2 0.7 37.9 0.6 -2.2 39.9 -0.2 -2.3 39.0 1.8 -1.1 40.7 1.4 -1.5 42.3 2.6 2.2 44.5 2.6 2.3
  14 40.2 1.3 42.2 0.7 37.9 0.6 -2.3 39.9 -0.2 -2.3 39.1 1.9 -1.1 40.8 1.5 -1.4 42.4 2.7 2.2 44.6 2.7 2.4
  15 40.2 1.3 42.2 0.7 38.0 0.7 -2.2 39.9 -0.2 -2.3 39.2 2.0 -1.0 40.9 1.6 -1.3 42.4 2.7 2.2 44.7 2.8 2.5
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument.

mx |>
  txtRound(digits = 1) |>
  addHtmlTableStyle(align = "rrrr|r",
                    spacer.celltype = "double_cell") |>
  htmlTable(cgroup = cgroup,
            n.cgroup = n.cgroup,
            rgroup = c("First period",
                       "Second period",
                       "Third period"),
            n.rgroup = rep(5, 3),
            tfoot = txtMergeLines("&Delta;<sub>int</sub> correspnds to the change since start",
                                  "&Delta;<sub>std</sub> corresponds to the change compared to national average"))
Sweden Stockholm county Uppsala county Norrbotten county
Men Women Men Women Men Women Men Women
Age Δint Age Δint Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd
First period
  1 38.9 0.0 41.5 0.0 37.3 0.0 -1.6 40.1 0.0 -1.4 37.2 0.0 -1.7 39.3 0.0 -2.2 39.7 0.0 0.8 41.9 0.0 0.4
  2 39.0 0.1 41.6 0.1 37.4 0.1 -1.6 40.1 0.0 -1.5 37.5 0.3 -1.5 39.4 0.1 -2.2 40.0 0.3 1.0 42.2 0.3 0.6
  3 39.2 0.3 41.7 0.2 37.5 0.2 -1.7 40.1 0.0 -1.6 37.6 0.4 -1.6 39.6 0.3 -2.1 40.2 0.5 1.0 42.5 0.6 0.8
  4 39.3 0.4 41.8 0.3 37.6 0.3 -1.7 40.2 0.1 -1.6 37.8 0.6 -1.5 39.7 0.4 -2.1 40.5 0.8 1.2 42.8 0.9 1.0
  5 39.4 0.5 41.9 0.4 37.7 0.4 -1.7 40.2 0.1 -1.7 38.0 0.8 -1.4 39.8 0.5 -2.1 40.7 1.0 1.3 43.0 1.1 1.1
Second period
  6 39.6 0.7 42.0 0.5 37.8 0.5 -1.8 40.3 0.2 -1.7 38.1 0.9 -1.5 40.0 0.7 -2.0 40.9 1.2 1.3 43.1 1.2 1.1
  7 39.7 0.8 42.0 0.5 37.9 0.6 -1.8 40.3 0.2 -1.7 38.3 1.1 -1.4 40.1 0.8 -1.9 41.1 1.4 1.4 43.4 1.5 1.4
  8 39.8 0.9 42.1 0.6 37.9 0.6 -1.9 40.2 0.1 -1.9 38.5 1.3 -1.3 40.4 1.1 -1.7 41.3 1.6 1.5 43.5 1.6 1.4
  9 39.8 0.9 42.1 0.6 37.8 0.5 -2.0 40.1 0.0 -2.0 38.6 1.4 -1.2 40.5 1.2 -1.6 41.5 1.8 1.7 43.8 1.9 1.7
  10 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.1 0.0 -2.0 38.7 1.5 -1.2 40.5 1.2 -1.6 41.7 2.0 1.8 44.0 2.1 1.9
Third period
  11 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.0 -0.1 -2.1 38.8 1.6 -1.1 40.6 1.3 -1.5 41.9 2.2 2.0 44.2 2.3 2.1
  12 40.0 1.1 42.1 0.6 37.8 0.5 -2.2 40.0 -0.1 -2.1 38.9 1.7 -1.1 40.6 1.3 -1.5 42.1 2.4 2.1 44.4 2.5 2.3
  13 40.1 1.2 42.2 0.7 37.9 0.6 -2.2 39.9 -0.2 -2.3 39.0 1.8 -1.1 40.7 1.4 -1.5 42.3 2.6 2.2 44.5 2.6 2.3
  14 40.2 1.3 42.2 0.7 37.9 0.6 -2.3 39.9 -0.2 -2.3 39.1 1.9 -1.1 40.8 1.5 -1.4 42.4 2.7 2.2 44.6 2.7 2.4
  15 40.2 1.3 42.2 0.7 38.0 0.7 -2.2 39.9 -0.2 -2.3 39.2 2.0 -1.0 40.9 1.6 -1.3 42.4 2.7 2.2 44.7 2.8 2.5
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

If we still feel that we want more separation it is always possible to add colors.

mx |>
  txtRound(digits = 1) |>
  addHtmlTableStyle(align = "rrrr|r",
                    align.header = "c",
                    col.columns = c(rep("#E6E6F0", 4),
                          rep("none", ncol(mx) - 4))) |>
  htmlTable(cgroup = cgroup,
            n.cgroup = n.cgroup,
            rgroup = c("First period",
                       "Second period",
                       "Third period"),
            n.rgroup = rep(5, 3),
            tfoot = txtMergeLines("&Delta;<sub>int</sub> correspnds to the change since start",
                                  "&Delta;<sub>std</sub> corresponds to the change compared to national average"))
Sweden Stockholm county Uppsala county Norrbotten county
Men Women Men Women Men Women Men Women
Age Δint Age Δint Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd
First period
  1 38.9 0.0 41.5 0.0 37.3 0.0 -1.6 40.1 0.0 -1.4 37.2 0.0 -1.7 39.3 0.0 -2.2 39.7 0.0 0.8 41.9 0.0 0.4
  2 39.0 0.1 41.6 0.1 37.4 0.1 -1.6 40.1 0.0 -1.5 37.5 0.3 -1.5 39.4 0.1 -2.2 40.0 0.3 1.0 42.2 0.3 0.6
  3 39.2 0.3 41.7 0.2 37.5 0.2 -1.7 40.1 0.0 -1.6 37.6 0.4 -1.6 39.6 0.3 -2.1 40.2 0.5 1.0 42.5 0.6 0.8
  4 39.3 0.4 41.8 0.3 37.6 0.3 -1.7 40.2 0.1 -1.6 37.8 0.6 -1.5 39.7 0.4 -2.1 40.5 0.8 1.2 42.8 0.9 1.0
  5 39.4 0.5 41.9 0.4 37.7 0.4 -1.7 40.2 0.1 -1.7 38.0 0.8 -1.4 39.8 0.5 -2.1 40.7 1.0 1.3 43.0 1.1 1.1
Second period
  6 39.6 0.7 42.0 0.5 37.8 0.5 -1.8 40.3 0.2 -1.7 38.1 0.9 -1.5 40.0 0.7 -2.0 40.9 1.2 1.3 43.1 1.2 1.1
  7 39.7 0.8 42.0 0.5 37.9 0.6 -1.8 40.3 0.2 -1.7 38.3 1.1 -1.4 40.1 0.8 -1.9 41.1 1.4 1.4 43.4 1.5 1.4
  8 39.8 0.9 42.1 0.6 37.9 0.6 -1.9 40.2 0.1 -1.9 38.5 1.3 -1.3 40.4 1.1 -1.7 41.3 1.6 1.5 43.5 1.6 1.4
  9 39.8 0.9 42.1 0.6 37.8 0.5 -2.0 40.1 0.0 -2.0 38.6 1.4 -1.2 40.5 1.2 -1.6 41.5 1.8 1.7 43.8 1.9 1.7
  10 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.1 0.0 -2.0 38.7 1.5 -1.2 40.5 1.2 -1.6 41.7 2.0 1.8 44.0 2.1 1.9
Third period
  11 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.0 -0.1 -2.1 38.8 1.6 -1.1 40.6 1.3 -1.5 41.9 2.2 2.0 44.2 2.3 2.1
  12 40.0 1.1 42.1 0.6 37.8 0.5 -2.2 40.0 -0.1 -2.1 38.9 1.7 -1.1 40.6 1.3 -1.5 42.1 2.4 2.1 44.4 2.5 2.3
  13 40.1 1.2 42.2 0.7 37.9 0.6 -2.2 39.9 -0.2 -2.3 39.0 1.8 -1.1 40.7 1.4 -1.5 42.3 2.6 2.2 44.5 2.6 2.3
  14 40.2 1.3 42.2 0.7 37.9 0.6 -2.3 39.9 -0.2 -2.3 39.1 1.9 -1.1 40.8 1.5 -1.4 42.4 2.7 2.2 44.6 2.7 2.4
  15 40.2 1.3 42.2 0.7 38.0 0.7 -2.2 39.9 -0.2 -2.3 39.2 2.0 -1.0 40.9 1.6 -1.3 42.4 2.7 2.2 44.7 2.8 2.5
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid.

mx |>
  txtRound(digits = 1) |>
  addHtmlTableStyle(align = "rrrr|r",
                    align.header = "c",
                    col.columns = c(rep("#E6E6F0", 4),
                          rep("none", ncol(mx) - 4)),
                    col.rgroup = c("none", "#FFFFCC")) |>
  htmlTable(cgroup = cgroup,
            n.cgroup = n.cgroup,
            # I use the &nbsp; - the no breaking space as I don't want to have a
            # row break in the row group. This adds a little space in the table
            # when used together with the cspan.rgroup=1.
            rgroup = c("1st&nbsp;period",
                       "2nd&nbsp;period",
                       "3rd&nbsp;period"),
            n.rgroup = rep(5, 3),
            tfoot = txtMergeLines("&Delta;<sub>int</sub> correspnds to the change since start",
                                  "&Delta;<sub>std</sub> corresponds to the change compared to national average"),
            cspan.rgroup = 1)
Sweden Stockholm county Uppsala county Norrbotten county
Men Women Men Women Men Women Men Women
Age Δint Age Δint Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd
1st period
  1 38.9 0.0 41.5 0.0 37.3 0.0 -1.6 40.1 0.0 -1.4 37.2 0.0 -1.7 39.3 0.0 -2.2 39.7 0.0 0.8 41.9 0.0 0.4
  2 39.0 0.1 41.6 0.1 37.4 0.1 -1.6 40.1 0.0 -1.5 37.5 0.3 -1.5 39.4 0.1 -2.2 40.0 0.3 1.0 42.2 0.3 0.6
  3 39.2 0.3 41.7 0.2 37.5 0.2 -1.7 40.1 0.0 -1.6 37.6 0.4 -1.6 39.6 0.3 -2.1 40.2 0.5 1.0 42.5 0.6 0.8
  4 39.3 0.4 41.8 0.3 37.6 0.3 -1.7 40.2 0.1 -1.6 37.8 0.6 -1.5 39.7 0.4 -2.1 40.5 0.8 1.2 42.8 0.9 1.0
  5 39.4 0.5 41.9 0.4 37.7 0.4 -1.7 40.2 0.1 -1.7 38.0 0.8 -1.4 39.8 0.5 -2.1 40.7 1.0 1.3 43.0 1.1 1.1
2nd period
  6 39.6 0.7 42.0 0.5 37.8 0.5 -1.8 40.3 0.2 -1.7 38.1 0.9 -1.5 40.0 0.7 -2.0 40.9 1.2 1.3 43.1 1.2 1.1
  7 39.7 0.8 42.0 0.5 37.9 0.6 -1.8 40.3 0.2 -1.7 38.3 1.1 -1.4 40.1 0.8 -1.9 41.1 1.4 1.4 43.4 1.5 1.4
  8 39.8 0.9 42.1 0.6 37.9 0.6 -1.9 40.2 0.1 -1.9 38.5 1.3 -1.3 40.4 1.1 -1.7 41.3 1.6 1.5 43.5 1.6 1.4
  9 39.8 0.9 42.1 0.6 37.8 0.5 -2.0 40.1 0.0 -2.0 38.6 1.4 -1.2 40.5 1.2 -1.6 41.5 1.8 1.7 43.8 1.9 1.7
  10 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.1 0.0 -2.0 38.7 1.5 -1.2 40.5 1.2 -1.6 41.7 2.0 1.8 44.0 2.1 1.9
3rd period
  11 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.0 -0.1 -2.1 38.8 1.6 -1.1 40.6 1.3 -1.5 41.9 2.2 2.0 44.2 2.3 2.1
  12 40.0 1.1 42.1 0.6 37.8 0.5 -2.2 40.0 -0.1 -2.1 38.9 1.7 -1.1 40.6 1.3 -1.5 42.1 2.4 2.1 44.4 2.5 2.3
  13 40.1 1.2 42.2 0.7 37.9 0.6 -2.2 39.9 -0.2 -2.3 39.0 1.8 -1.1 40.7 1.4 -1.5 42.3 2.6 2.2 44.5 2.6 2.3
  14 40.2 1.3 42.2 0.7 37.9 0.6 -2.3 39.9 -0.2 -2.3 39.1 1.9 -1.1 40.8 1.5 -1.4 42.4 2.7 2.2 44.6 2.7 2.4
  15 40.2 1.3 42.2 0.7 38.0 0.7 -2.2 39.9 -0.2 -2.3 39.2 2.0 -1.0 40.9 1.6 -1.3 42.4 2.7 2.2 44.7 2.8 2.5
Δint correspnds to the change since start

Δstd corresponds to the change compared to national average

If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters.

cols_2_clr <- grep("&Delta;<sub>std</sub>", colnames(mx))
# We need a copy as the formatting causes the matrix to loos
# its numerical property
out_mx <- txtRound(mx, 1)

min_delta <- min(mx[,cols_2_clr])
span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr])
for (col in cols_2_clr) {
  out_mx[, col] <- mapply(function(val, strength)
    paste0("<span style='font-weight: 900; color: ",
           colorRampPalette(c("#009900", "#000000", "#990033"))(101)[strength],
           "'>",
           val, "</span>"),
    val = out_mx[,col],
    strength = round((mx[,col] - min_delta)/span_delta*100 + 1),
    USE.NAMES = FALSE)
}

out_mx |>
  addHtmlTableStyle(align = "rrrr|r",
                    align.header = "cccc|c",
                    pos.rowlabel = "bottom",
                    col.rgroup = c("none", "#FFFFCC"),
                    col.columns = c(rep("#EFEFF0", 4),
                                    rep("none", ncol(mx) - 4))) |>
  htmlTable(caption = "Average age in Sweden counties over a period of
                     15 years. The Norbotten county is typically known
                     for having a negative migration pattern compared to
                     Stockholm, while Uppsala has a proportionally large
                     population of students.",
            rowlabel = "Year",
            cgroup = cgroup,
            n.cgroup = n.cgroup,
            rgroup = c("1st&nbsp;period",
                       "2nd&nbsp;period",
                       "3rd&nbsp;period"),
            n.rgroup = rep(5, 3),
            tfoot = txtMergeLines("&Delta;<sub>int</sub> corresponds to the change since start",
                                  "&Delta;<sub>std</sub> corresponds to the change compared to national average"),
            cspan.rgroup = 1)
Sweden Stockholm county Uppsala county Norrbotten county
Men Women Men Women Men Women Men Women
Year Age Δint Age Δint Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd Age Δint Δstd
1st period
  1 38.9 0.0 41.5 0.0 37.3 0.0 -1.6 40.1 0.0 -1.4 37.2 0.0 -1.7 39.3 0.0 -2.2 39.7 0.0 0.8 41.9 0.0 0.4
  2 39.0 0.1 41.6 0.1 37.4 0.1 -1.6 40.1 0.0 -1.5 37.5 0.3 -1.5 39.4 0.1 -2.2 40.0 0.3 1.0 42.2 0.3 0.6
  3 39.2 0.3 41.7 0.2 37.5 0.2 -1.7 40.1 0.0 -1.6 37.6 0.4 -1.6 39.6 0.3 -2.1 40.2 0.5 1.0 42.5 0.6 0.8
  4 39.3 0.4 41.8 0.3 37.6 0.3 -1.7 40.2 0.1 -1.6 37.8 0.6 -1.5 39.7 0.4 -2.1 40.5 0.8 1.2 42.8 0.9 1.0
  5 39.4 0.5 41.9 0.4 37.7 0.4 -1.7 40.2 0.1 -1.7 38.0 0.8 -1.4 39.8 0.5 -2.1 40.7 1.0 1.3 43.0 1.1 1.1
2nd period
  6 39.6 0.7 42.0 0.5 37.8 0.5 -1.8 40.3 0.2 -1.7 38.1 0.9 -1.5 40.0 0.7 -2.0 40.9 1.2 1.3 43.1 1.2 1.1
  7 39.7 0.8 42.0 0.5 37.9 0.6 -1.8 40.3 0.2 -1.7 38.3 1.1 -1.4 40.1 0.8 -1.9 41.1 1.4 1.4 43.4 1.5 1.4
  8 39.8 0.9 42.1 0.6 37.9 0.6 -1.9 40.2 0.1 -1.9 38.5 1.3 -1.3 40.4 1.1 -1.7 41.3 1.6 1.5 43.5 1.6 1.4
  9 39.8 0.9 42.1 0.6 37.8 0.5 -2.0 40.1 0.0 -2.0 38.6 1.4 -1.2 40.5 1.2 -1.6 41.5 1.8 1.7 43.8 1.9 1.7
  10 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.1 0.0 -2.0 38.7 1.5 -1.2 40.5 1.2 -1.6 41.7 2.0 1.8 44.0 2.1 1.9
3rd period
  11 39.9 1.0 42.1 0.6 37.8 0.5 -2.1 40.0 -0.1 -2.1 38.8 1.6 -1.1 40.6 1.3 -1.5 41.9 2.2 2.0 44.2 2.3 2.1
  12 40.0 1.1 42.1 0.6 37.8 0.5 -2.2 40.0 -0.1 -2.1 38.9 1.7 -1.1 40.6 1.3 -1.5 42.1 2.4 2.1 44.4 2.5 2.3
  13 40.1 1.2 42.2 0.7 37.9 0.6 -2.2 39.9 -0.2 -2.3 39.0 1.8 -1.1 40.7 1.4 -1.5 42.3 2.6 2.2 44.5 2.6 2.3
  14 40.2 1.3 42.2 0.7 37.9 0.6 -2.3 39.9 -0.2 -2.3 39.1 1.9 -1.1 40.8 1.5 -1.4 42.4 2.7 2.2 44.6 2.7 2.4
  15 40.2 1.3 42.2 0.7 38.0 0.7 -2.2 39.9 -0.2 -2.3 39.2 2.0 -1.0 40.9 1.6 -1.3 42.4 2.7 2.2 44.7 2.8 2.5
Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.
Δint corresponds to the change since start

Δstd corresponds to the change compared to national average

Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data.

Lastly I would like to thank Stephen Few, ThinkUI, and LabWrite for inspiration.

htmlTable/inst/doc/text_formatters.html0000644000176200001440000007056214646657236020065 0ustar liggesusers Text formatters

Text formatters

Max Gordon

2024-07-20

Text formatters

Bundled with this package are some text formatting functions. The purpose of these is to convert numeric values into character/text that is more pleasent in publication tables.

txtRound

While base::round() is an excellent function in most cases we often want a table to retain trailing 0:s. E.g.

library(htmlTable)
library(dplyr)
library(magrittr)
data("mtcars")

mtcars %<>%
  mutate(am = factor(am, levels = 0:1, labels = c("Automatic", "Manual")),
         vs = factor(vs, levels = 0:1, labels = c("V-shaped", "straight")))

mtcars %>% 
  head(3) %>% 
  select(Transmission = am, Gas = mpg, Weight = wt) %>% 
  htmlTable()
Transmission Gas Weight
Mazda RX4 Manual 21 2.62
Mazda RX4 Wag Manual 21 2.875
Datsun 710 Manual 22.8 2.32

doesn’t look visually that great, instead we would prefer to have something like this:

mtcars %>% 
  head(3) %>% 
  select(Transmission = am, Gas = mpg, Weight = wt) %>% 
  txtRound(digits = 1) %>% 
  htmlTable()
Transmission Gas Weight
Mazda RX4 Manual 21.0 2.6
Mazda RX4 Wag Manual 21.0 2.9
Datsun 710 Manual 22.8 2.3

Single/vector values

At the core of the txtRound is the single/vector value conversion:

txtRound(c(1, 1.1034), digits = 2)
## [1] "1.00" "1.10"
# Use a character to convert
txtRound("1.2333", digits = 2)
## [1] "1.23"

If you have some values that need thousand separation you can also add txtInt_args.

# Large numbers can be combined with the txtInt option
txtRound(12345.12, digits = 1, txtInt_args = TRUE)
## [1] "12,345.1"
txtRound(12345.12, digits = 1, txtInt_args = list(language = "se", html = FALSE))
## [1] "12 345.1"

Data frames

As seen in the introduction we can use data frames for input. We can here rename the converted columns:

mtcars %>% 
  head(3) %>% 
  select(mpg, wt) %>% 
  txtRound(mpg, wt_txt = wt, digits = 1)
##                mpg    wt wt_txt
## Mazda RX4     21.0 2.620    2.6
## Mazda RX4 Wag 21.0 2.875    2.9
## Datsun 710    22.8 2.320    2.3

And we can specify the number of decimals that we’re interested in per column:

mtcars %>% 
  head(3) %>% 
  select(mpg, qsec, wt) %>% 
  txtRound(digits = list(wt = 2, .default = 1))
##                mpg qsec   wt
## Mazda RX4     21.0 16.5 2.62
## Mazda RX4 Wag 21.0 17.0 2.88
## Datsun 710    22.8 18.6 2.32

Matrix

We can also feed a matrix into the txtRound:

mtcars_matrix <- mtcars %>% 
  select(mpg, qsec, wt) %>% 
  head(3) %>% 
  as.matrix()

mtcars_matrix %>% 
  txtRound(digits = 1)
##               mpg    qsec   wt   
## Mazda RX4     "21.0" "16.5" "2.6"
## Mazda RX4 Wag "21.0" "17.0" "2.9"
## Datsun 710    "22.8" "18.6" "2.3"

Here we have some options of excluding columns/rows using regular expressions:

mtcars_matrix %>% 
  txtRound(excl.cols = "^wt$",
           excl.rows = "^Mazda RX4$",
           digits = 1)
##               mpg    qsec    wt     
## Mazda RX4     "21"   "16.46" "2.62" 
## Mazda RX4 Wag "21.0" "17.0"  "2.875"
## Datsun 710    "22.8" "18.6"  "2.32"

Similarly to the data.frame we can use the same syntax to pick column specific digits:

mtcars_matrix %>% 
  txtRound(digits = list(mpg = 0, wt = 2, .default = 1))
##               mpg  qsec   wt    
## Mazda RX4     "21" "16.5" "2.62"
## Mazda RX4 Wag "21" "17.0" "2.88"
## Datsun 710    "23" "18.6" "2.32"

txtInt

While scientific format is useful if familiar with the syntax it can be difficult to grasp for scholars with a less mathematical background. Therefore the thousand separator style can be quite useful, also known as digital grouping:

txtInt(1e7)
## [1] "10,000,000"

As Swedish and many other languages rely on space (SI-standard) we can specify language as a parameter. Note that as we don’t want to have line breaks within a digit we can use non-breaking space for keeping the number intact (the html-code is &nbsp;):

txtInt(1e7, language = "SI", html = FALSE)
## [1] "10 000 000"
txtInt(1e7, language = "SI", html = TRUE)
## [1] "10&nbsp;000&nbsp;000"

Note that there are the option htmlTable.language and htmlTable.html that you can use for the input of these parameters.

txtPval

The p-value is perhaps the most controversial of statistical output, nevertheless it is still needed and used correctly it has it’s use. P-values are frequently rounded as the decimals are not as important. The txtPval is a convenient function with some defaults that correspond to typical uses in medical publications.

txtPval(c(0.1233213, 0.035, 0.001, 0.000001), html = FALSE)
## [1] "0.12"     "0.035"    "0.001"    "< 0.0001"
# The < sign is less-than in html code '&lt;'
txtPval(c(0.05, 0.001, 0.000001), html = TRUE)
## [1] "0.050"       "0.001"       "&lt; 0.0001"

txtMergeLines

In html we indicate new line using <br /> while the latex style uses hbox. To help with these two there is the txtMergeLines that merges lines into one properly formatted unit:

txtMergeLines("Line 1",
              "Line 2",
              "Line 3")

Line 1
Line 2
Line 3

Note that you can also use a single multi-line string:

txtMergeLines("Line 1
               Line 2
               Line 3")

Line 1
Line 2
Line 3

txtMergeLines("Line 1
               Line 2
               Line 3",
              html = FALSE)
## [1] "\\vbox{\\hbox{\\strut Line 1}\\hbox{\\strut Line 2}\\hbox{\\strut Line 3}}"
htmlTable/inst/doc/text_formatters.R0000644000176200001440000000563314646657236017317 0ustar liggesusers## ----message=FALSE------------------------------------------------------------ library(htmlTable) library(dplyr) library(magrittr) data("mtcars") mtcars %<>% mutate(am = factor(am, levels = 0:1, labels = c("Automatic", "Manual")), vs = factor(vs, levels = 0:1, labels = c("V-shaped", "straight"))) mtcars %>% head(3) %>% select(Transmission = am, Gas = mpg, Weight = wt) %>% htmlTable() ## ----------------------------------------------------------------------------- mtcars %>% head(3) %>% select(Transmission = am, Gas = mpg, Weight = wt) %>% txtRound(digits = 1) %>% htmlTable() ## ----------------------------------------------------------------------------- txtRound(c(1, 1.1034), digits = 2) # Use a character to convert txtRound("1.2333", digits = 2) ## ----------------------------------------------------------------------------- # Large numbers can be combined with the txtInt option txtRound(12345.12, digits = 1, txtInt_args = TRUE) txtRound(12345.12, digits = 1, txtInt_args = list(language = "se", html = FALSE)) ## ----------------------------------------------------------------------------- mtcars %>% head(3) %>% select(mpg, wt) %>% txtRound(mpg, wt_txt = wt, digits = 1) ## ----------------------------------------------------------------------------- mtcars %>% head(3) %>% select(mpg, qsec, wt) %>% txtRound(digits = list(wt = 2, .default = 1)) ## ----------------------------------------------------------------------------- mtcars_matrix <- mtcars %>% select(mpg, qsec, wt) %>% head(3) %>% as.matrix() mtcars_matrix %>% txtRound(digits = 1) ## ----------------------------------------------------------------------------- mtcars_matrix %>% txtRound(excl.cols = "^wt$", excl.rows = "^Mazda RX4$", digits = 1) ## ----------------------------------------------------------------------------- mtcars_matrix %>% txtRound(digits = list(mpg = 0, wt = 2, .default = 1)) ## ----------------------------------------------------------------------------- txtInt(1e7) ## ----------------------------------------------------------------------------- txtInt(1e7, language = "SI", html = FALSE) txtInt(1e7, language = "SI", html = TRUE) ## ----------------------------------------------------------------------------- txtPval(c(0.1233213, 0.035, 0.001, 0.000001), html = FALSE) # The < sign is less-than in html code '<' txtPval(c(0.05, 0.001, 0.000001), html = TRUE) ## ----------------------------------------------------------------------------- txtMergeLines("Line 1", "Line 2", "Line 3") ## ----------------------------------------------------------------------------- txtMergeLines("Line 1 Line 2 Line 3") ## ----------------------------------------------------------------------------- txtMergeLines("Line 1 Line 2 Line 3", html = FALSE) htmlTable/inst/doc/general.R0000644000176200001440000001731714646657235015503 0ustar liggesusers## ----------------------------------------------------------------------------- library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol = 2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ## ----------------------------------------------------------------------------- # A simple output matrix(1:4, ncol = 2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ## ----------------------------------------------------------------------------- data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ## ----ctable_example----------------------------------------------------------- output <- matrix(1:4, ncol = 2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable = c("solid", "double"), caption = "A table caption above and ctable borders") ## ----table_with_caption_below------------------------------------------------- output %>% addHtmlTableStyle(pos.caption = "bottom") %>% htmlTable(caption = "A table caption below") ## ----------------------------------------------------------------------------- 1:3 %>% addHtmlTableStyle(align = "lcr") %>% htmlTable(rnames = "Row 1", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ## ----------------------------------------------------------------------------- 1:3 %>% addHtmlTableStyle(align = "clcr", align.header = "lcr") %>% htmlTable(rnames = "Row 1", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ## ----------------------------------------------------------------------------- mx <- matrix(ncol = 6, nrow = 8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)) { for (nc in 1:ncol(mx)) { mx[nr, nc] <- paste0(nr, ":", nc) } } ## ----------------------------------------------------------------------------- htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- mx %>% addHtmlTableStyle(css.rgroup = "") %>% htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ## ----------------------------------------------------------------------------- htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ## ----------------------------------------------------------------------------- htmlTable(mx, cgroup = list(c("Super column spanner", ""), c("", "Another cgroup"), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = list(c(5,1), c(1,2), c(2,2,2))) ## ----------------------------------------------------------------------------- htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4)) ## ----------------------------------------------------------------------------- htmlTable(mx[1:3,], total = TRUE) ## ----------------------------------------------------------------------------- mx %>% addHtmlTableStyle(css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900")) %>% htmlTable(total = "tspanner", tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ## ----------------------------------------------------------------------------- options(table_counter = TRUE) ## ----------------------------------------------------------------------------- htmlTable(mx[1:2,1:2], caption = "A table caption with a numbering") ## ----------------------------------------------------------------------------- tblNoLast() tblNoNext() ## ----------------------------------------------------------------------------- htmlTable(mx[1:2,1:2], caption = "Another table with numbering") ## ----------------------------------------------------------------------------- options(table_counter = FALSE) ## ----------------------------------------------------------------------------- htmlTable(mx[1:2,1:2], tfoot = "A table footer") ## ----------------------------------------------------------------------------- mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% htmlTable ## ----------------------------------------------------------------------------- mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ## ----------------------------------------------------------------------------- mx %>% addHtmlTableStyle(col.columns = c("none", "#F7F7F7")) %>% htmlTable ## ----------------------------------------------------------------------------- mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) %>% htmlTable ## ----------------------------------------------------------------------------- rgroup = paste("Group", LETTERS[1:3]) attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001") mx %>% addHtmlTableStyle(align = "rr|r", align.header = "cc|c", spacer.celltype = "double_cell", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;", css.header = "font-weight: normal") %>% htmlTable(rgroup = rgroup, n.rgroup = c(2,4), tspanner = paste("Spanner", LETTERS[1:2]), n.tspanner = c(1), cgroup = list(c("", "Column spanners"), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = list(c(1,5), c(2,2,2)), caption = "A table with column spanners, row groups, and zebra striping", tfoot = "† A table footer commment", cspan.rgroup = 2) htmlTable/inst/doc/text_formatters.Rmd0000644000176200001440000001114514165130172017610 0ustar liggesusers--- title: "Text formatters" author: "Max Gordon" date: "`r Sys.Date()`" VignetteBuilder: knitr, rmarkdown output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{Text formatters} %\usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: inline --- Text formatters =============== Bundled with this package are some text formatting functions. The purpose of these is to convert numeric values into character/text that is more pleasent in publication tables. txtRound -------- While `base::round()` is an excellent function in most cases we often want a table to retain trailing 0:s. E.g. ```{r message=FALSE} library(htmlTable) library(dplyr) library(magrittr) data("mtcars") mtcars %<>% mutate(am = factor(am, levels = 0:1, labels = c("Automatic", "Manual")), vs = factor(vs, levels = 0:1, labels = c("V-shaped", "straight"))) mtcars %>% head(3) %>% select(Transmission = am, Gas = mpg, Weight = wt) %>% htmlTable() ``` doesn't look visually that great, instead we would prefer to have something like this: ```{r} mtcars %>% head(3) %>% select(Transmission = am, Gas = mpg, Weight = wt) %>% txtRound(digits = 1) %>% htmlTable() ``` ### Single/vector values At the core of the `txtRound` is the single/vector value conversion: ```{r} txtRound(c(1, 1.1034), digits = 2) # Use a character to convert txtRound("1.2333", digits = 2) ``` If you have some values that need thousand separation you can also add `txtInt_args`. ```{r} # Large numbers can be combined with the txtInt option txtRound(12345.12, digits = 1, txtInt_args = TRUE) txtRound(12345.12, digits = 1, txtInt_args = list(language = "se", html = FALSE)) ``` ### Data frames As seen in the introduction we can use data frames for input. We can here rename the converted columns: ```{r} mtcars %>% head(3) %>% select(mpg, wt) %>% txtRound(mpg, wt_txt = wt, digits = 1) ``` And we can specify the number of decimals that we're interested in per column: ```{r} mtcars %>% head(3) %>% select(mpg, qsec, wt) %>% txtRound(digits = list(wt = 2, .default = 1)) ``` ### Matrix We can also feed a matrix into the `txtRound`: ```{r} mtcars_matrix <- mtcars %>% select(mpg, qsec, wt) %>% head(3) %>% as.matrix() mtcars_matrix %>% txtRound(digits = 1) ``` Here we have some options of excluding columns/rows using regular expressions: ```{r} mtcars_matrix %>% txtRound(excl.cols = "^wt$", excl.rows = "^Mazda RX4$", digits = 1) ``` Similarly to the data.frame we can use the same syntax to pick column specific digits: ```{r} mtcars_matrix %>% txtRound(digits = list(mpg = 0, wt = 2, .default = 1)) ``` txtInt ------ While scientific format is useful if familiar with the syntax it can be difficult to grasp for scholars with a less mathematical background. Therefore the thousand separator style can be quite useful, also known as [digital grouping](https://en.wikipedia.org/wiki/Decimal_separator#Digit_grouping): ```{r} txtInt(1e7) ``` As Swedish and many other languages rely on space (SI-standard) we can specify language as a parameter. Note that as we don't want to have line breaks within a digit we can use [non-breaking space](https://en.wikipedia.org/wiki/Non-breaking_space) for keeping the number intact (the html-code is ` `): ```{r} txtInt(1e7, language = "SI", html = FALSE) txtInt(1e7, language = "SI", html = TRUE) ``` Note that there are the option `htmlTable.language` and `htmlTable.html` that you can use for the input of these parameters. txtPval ------- The p-value is perhaps the most controversial of statistical output, nevertheless it is still needed and used correctly it has it's use. P-values are frequently rounded as the decimals are not as important. The `txtPval` is a convenient function with some defaults that correspond to typical uses in medical publications. ```{r} txtPval(c(0.1233213, 0.035, 0.001, 0.000001), html = FALSE) # The < sign is less-than in html code '<' txtPval(c(0.05, 0.001, 0.000001), html = TRUE) ``` txtMergeLines ------------- In html we indicate new line using *<br />* while the latex style uses *hbox*. To help with these two there is the `txtMergeLines` that merges lines into one properly formatted unit: ```{r} txtMergeLines("Line 1", "Line 2", "Line 3") ``` Note that you can also use a single multi-line string: ```{r} txtMergeLines("Line 1 Line 2 Line 3") ``` ```{r} txtMergeLines("Line 1 Line 2 Line 3", html = FALSE) ``` htmlTable/inst/doc/general.html0000644000176200001440000054047514646657236016255 0ustar liggesusers How-to use htmlTable

How-to use htmlTable

Max Gordon

2024-07-20

Basics

The htmlTable package is intended for generating tables using HTML formatting. This format is compatible with Markdown when used for HTML-output. The most basic table can easily be created by just passing a matrix or a data.frame to the htmlTable-function:

library(htmlTable)
library(magrittr)
# A simple output
matrix(1:4,
       ncol = 2,
       dimnames = list(c("Row 1", "Row 2"),
                       c("Column 1", "Column 2"))) %>% 
  htmlTable
Column 1 Column 2
Row 1 1 3
Row 2 2 4

The function is also aware of the dimnames:

# A simple output
matrix(1:4,
       ncol = 2,
       dimnames = list(rows = c("Row 1", "Row 2"),
                       cols = c("Column 1", "Column 2"))) %>% 
  htmlTable
cols
Column 1 Column 2
rows
  Row 1 1 3
  Row 2 2 4

This can be convenient when working with the base::table function:

data("mtcars")
with(mtcars,
     table(cyl, gear)) %>% 
  addmargins %>%
  htmlTable
gear
3 4 5 Sum
cyl
  4 1 8 2 11
  6 2 4 1 7
  8 12 0 2 14
  Sum 15 12 5 32

As of version 1.1 you no longer need to specify results='asis' for each knitr chunk.

Tip: If you are working a lot with dplyr and the tidyverse approach to exploring data you can make your life much easier using the tidyHtmlTable() function included in this package that automatically calculates the rgroup, cgroup and other parameters that make htmlTable so useful.

Table caption

The table caption is simply the table description and can be either located above or below:

output <- matrix(1:4,
                 ncol = 2,
                 dimnames = list(c("Row 1", "Row 2"),
                                 c("Column 1", "Column 2")))
htmlTable(output,
          ctable = c("solid", "double"),
          caption = "A table caption above and ctable borders")
Column 1 Column 2
Row 1 1 3
Row 2 2 4
A table caption above and ctable borders

The caption defaults to above but by setting the pos.caption argument to “bottom” it appears below the table.

output %>%
  addHtmlTableStyle(pos.caption = "bottom") %>% 
  htmlTable(caption = "A table caption below")
Column 1 Column 2
Row 1 1 3
Row 2 2 4
A table caption below

Cell alignment

Cell alignment is specified through the align, align.header, align.cgroup arguments. For aligning the cell values just use align. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below:

1:3 %>% 
  addHtmlTableStyle(align = "lcr") %>% 
  htmlTable(rnames = "Row 1",
            header = c("'l' = left", "'c' = center", "'r' = right"),
            caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.")
‘l’ = left ‘c’ = center ‘r’ = right
Row 1 1 2 3
The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.

Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the align.header argument:

1:3 %>% 
  addHtmlTableStyle(align = "clcr",
                    align.header = "lcr") %>% 
  htmlTable(rnames = "Row 1",
            header = c("'l' = left", "'c' = center", "'r' = right"),
            caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.")
‘l’ = left ‘c’ = center ‘r’ = right
Row 1 1 2 3
The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.

Advanced

While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as:

  • row groups
  • column spanners
  • table spanners
  • total row
  • table footer
  • zebra coloring (also known as banding):
    • rows
    • columns

As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The htmlTable-function is written for all these purposes.

For demonstration purposes we will setup a basic matrix:

mx <- matrix(ncol = 6, nrow = 8)
rownames(mx) <- paste(c("1st", "2nd",
                        "3rd",
                        paste0(4:8, "th")),
                      "row")
colnames(mx) <- paste(c("1st", "2nd",
                        "3rd", 
                        paste0(4:6, "th")),
                      "hdr")

for (nr in 1:nrow(mx)) {
  for (nc in 1:ncol(mx)) {
    mx[nr, nc] <-
      paste0(nr, ":", nc)
  }
}

Row groups

The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together.

htmlTable(mx, 
          rgroup = paste("Group", LETTERS[1:3]),
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6

We can easily mix row groups with regular variables by having an empty row group name "":

htmlTable(mx, 
          rgroup = c(paste("Group", LETTERS[1:2]), ""),
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label:

mx %>% 
  addHtmlTableStyle(css.rgroup = "") %>% 
  htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""),
            n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

The rgroup is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the ‘add’ attribute to the rgroup:

rgroup <- c(paste("Group", LETTERS[1:2]), "")
attr(rgroup, "add") <- list(`2` = "More")
htmlTable(mx, 
          rgroup = rgroup,
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B More
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Column spanners

A column spanner spans 2 or more columns:

htmlTable(mx,
          cgroup = c("Cgroup 1", "Cgroup 2"),
          n.cgroup = c(2,4))
Cgroup 1 Cgroup 2
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

It can sometimes be convenient to have column spanners in multiple levels:

htmlTable(mx,
          cgroup = rbind(c("", "Column spanners", NA),
                         c("", "Cgroup 1", "Cgroup 2")),
          n.cgroup = rbind(c(1,2,NA),
                           c(2,2,2)))
Column spanners
Cgroup 1 Cgroup 2
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function and you can also provide a list with elements that allows you to skip the NA at the end of the matrix:

htmlTable(mx,
          cgroup = list(c("Super column spanner", ""),
                        c("", "Another cgroup"),
                        c("", "Cgroup 1", "Cgroup 2")),
          n.cgroup = list(c(5,1),
                          c(1,2),
                          c(2,2,2)))
Super column spanner
Another cgroup
Cgroup 1 Cgroup 2
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Table spanners

A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one:

htmlTable(mx, 
          tspanner = paste("Spanner", LETTERS[1:3]),
          n.tspanner = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Note that you actually don’t need the last n.tspanner, i.e. you can simplify the above to:

htmlTable(mx, 
          tspanner = paste("Spanner", LETTERS[1:3]),
          n.tspanner = c(2,4))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Similarly you can use the number rgroups included in each tspanner instead of actual rows. This is convenient as the tspannners must align with underlying rgroups.

Total row

Many financial tables use the concept of a total row at the end that sums the above elements:

htmlTable(mx[1:3,], total = TRUE)
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6

This can also be combined with table spanners:

mx %>% 
  addHtmlTableStyle(css.total = c("border-top: 1px dashed grey;",
                                  "border-top: 1px dashed grey;",
                                  "border-top: 1px solid grey; font-weight: 900")) %>% 
  htmlTable(total = "tspanner",
            tspanner = paste("Spanner", LETTERS[1:3]),
            n.tspanner = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Table numbering

The htmlTable has built-in numbering, initialized by:

options(table_counter = TRUE)
htmlTable(mx[1:2,1:2], 
          caption = "A table caption with a numbering")
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
Table 1: A table caption with a numbering

As we often want to reference the table number in the text there are two associated functions:

tblNoLast()
## [1] 1
tblNoNext()
## [1] 2
htmlTable(mx[1:2,1:2], 
          caption = "Another table with numbering")
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
Table 2: Another table with numbering

If you want to start the counter at 2 you can instead of setting table_counter to TRUE set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by:

options(table_counter = FALSE)

Zebra coloring (or banded colors)

Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows:

mx %>% 
  addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% 
  htmlTable
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

The zebra coloring in htmlTable is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. “” will have alternating colors event though they programatically are within the same group:

mx %>% 
  addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% 
  htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""),
            n.rgroup = c(2,2,nrow(mx) - 4))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

We can also color the columns:

mx %>% 
  addHtmlTableStyle(col.columns = c("none", "#F7F7F7")) %>% 
  htmlTable
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Or do both (note that the colors blend at the intersections):

mx %>% 
  addHtmlTableStyle(col.rgroup = c("none", "#F9FAF0"),
                    col.columns = c("none", "#F1F0FA")) %>% 
  htmlTable
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Putting it all together

Now if we want to do everything in one table it may look like this:

rgroup = paste("Group", LETTERS[1:3])
attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001")

mx %>% 
  addHtmlTableStyle(align = "rr|r",
                    align.header = "cc|c",
                    spacer.celltype = "double_cell",
                    col.columns = c(rep("none", 2),
                                    rep("#F5FBFF", 4)),
                    col.rgroup = c("none", "#F7F7F7"),
                    css.cell = "padding-left: .5em; padding-right: .2em;",
                    css.header = "font-weight: normal") %>% 
  htmlTable(rgroup = rgroup,
            n.rgroup = c(2,4),
            tspanner = paste("Spanner", LETTERS[1:2]),
            n.tspanner = c(1),
            cgroup = list(c("", "Column spanners"),
                          c("", "Cgroup 1", "Cgroup 2&dagger;")),
            n.cgroup = list(c(1,5),
                            c(2,2,2)),
            caption = "A table with column spanners, row groups, and zebra striping",
            tfoot = "&dagger; A table footer commment",
            cspan.rgroup = 2)
Column spanners
Cgroup 1 Cgroup 2†
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C Group p-value < 0.001
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6
A table with column spanners, row groups, and zebra striping
† A table footer commment
htmlTable/inst/doc/tidyHtmlTable.R0000644000176200001440000000264714646657237016636 0ustar liggesusers## ----message=FALSE------------------------------------------------------------ library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% as_tibble(rownames = "rnames") %>% pivot_longer(names_to = "per_metric", cols = c(hp, mpg, qsec)) ## ----------------------------------------------------------------------------- tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1), .groups = 'drop') %>% pivot_longer(names_to = "summary_stat", cols = c(Mean, SD, Min, Max)) %>% ungroup() %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ## ----warning=FALSE------------------------------------------------------------ tidy_summary %>% arrange(per_metric, summary_stat) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric) ## ----warning=FALSE------------------------------------------------------------ tidy_summary %>% arrange(cyl, gear) %>% addHtmlTableStyle(align = "r") %>% tidyHtmlTable(header = summary_stat, cgroup = per_metric, rnames = gear, rgroup = cyl) htmlTable/inst/doc/tidyHtmlTable.html0000644000176200001440000012705014646657237017375 0ustar liggesusers Using tidyHtmlTable

Using tidyHtmlTable

Stephen Gragg

2024-07-20

Introduction

tidyHtmlTable acts as a wrapper function for the htmlTable function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2.

Some Examples

Prepare Data

We’ll begin by turning the mtcars data into a tidy dataset. The pivot_longer function is called to collect 3 performance metrics into a pair of key and value columns.

library(magrittr)
library(tidyr)
library(dplyr)
library(htmlTable)
library(tibble)

td <- mtcars %>%
  as_tibble(rownames = "rnames") %>% 
  pivot_longer(names_to = "per_metric", 
               cols = c(hp, mpg, qsec))

Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears.

tidy_summary <- td %>%
  group_by(cyl, gear, per_metric) %>% 
  summarise(Mean = round(mean(value), 1),
            SD = round(sd(value), 1),
            Min = round(min(value), 1),
            Max = round(max(value), 1),
            .groups = 'drop') %>%
  pivot_longer(names_to = "summary_stat", 
               cols = c(Mean, SD, Min, Max)) %>% 
  ungroup() %>% 
  mutate(gear = paste(gear, "Gears"),
         cyl = paste(cyl, "Cylinders"))

At this point, we are ready to implement the htmlTable function. Essentially, this constructs an html table using arguments similar to the htmlTable function. However, whereas htmlTable required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data.

Output html table

Example 1

tidy_summary  %>% 
  arrange(per_metric, summary_stat) %>% 
  addHtmlTableStyle(align = "r") %>% 
  tidyHtmlTable(header = gear,
                cgroup = cyl,
                rnames = summary_stat,
                rgroup = per_metric)
4 Cylinders 6 Cylinders 8 Cylinders
3 Gears 4 Gears 5 Gears 3 Gears 4 Gears 5 Gears 3 Gears 5 Gears
hp
  Max 97 109 113 110 123 175 245 335
  Mean 97 76 102 107.5 116.5 175 194.2 299.5
  Min 97 52 91 105 110 175 150 264
  SD 20.1 15.6 3.5 7.5 33.4 50.2
mpg
  Max 21.5 33.9 30.4 21.4 21 19.7 19.2 15.8
  Mean 21.5 26.9 28.2 19.8 19.8 19.7 15.1 15.4
  Min 21.5 21.4 26 18.1 17.8 19.7 10.4 15
  SD 4.8 3.1 2.3 1.6 2.8 0.6
qsec
  Max 20 22.9 16.9 20.2 18.9 15.5 18 14.6
  Mean 20 19.6 16.8 19.8 17.7 15.5 17.1 14.6
  Min 20 18.5 16.7 19.4 16.5 15.5 15.4 14.5
  SD 1.5 0.1 0.6 1.1 0.8 0.1

Example 2

tidy_summary  %>% 
  arrange(cyl, gear) %>% 
  addHtmlTableStyle(align = "r") %>% 
  tidyHtmlTable(header = summary_stat,
                cgroup = per_metric,
                rnames = gear,
                rgroup = cyl)
hp mpg qsec
Max Mean Min SD Max Mean Min SD Max Mean Min SD
4 Cylinders
  3 Gears 97 97 97 21.5 21.5 21.5 20 20 20
  4 Gears 109 76 52 20.1 33.9 26.9 21.4 4.8 22.9 19.6 18.5 1.5
  5 Gears 113 102 91 15.6 30.4 28.2 26 3.1 16.9 16.8 16.7 0.1
6 Cylinders
  3 Gears 110 107.5 105 3.5 21.4 19.8 18.1 2.3 20.2 19.8 19.4 0.6
  4 Gears 123 116.5 110 7.5 21 19.8 17.8 1.6 18.9 17.7 16.5 1.1
  5 Gears 175 175 175 19.7 19.7 19.7 15.5 15.5 15.5
8 Cylinders
  3 Gears 245 194.2 150 33.4 19.2 15.1 10.4 2.8 18 17.1 15.4 0.8
  5 Gears 335 299.5 264 50.2 15.8 15.4 15 0.6 14.6 14.6 14.5 0.1
htmlTable/inst/doc/complex_tables.Rmd0000644000176200001440000002761114517434555017401 0ustar liggesusers--- title: "Building a complex table" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true css: custom.css vignette: > %\VignetteIndexEntry{Building a complex table} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- # Introduction Tables are an essential part of publishing, well... anything. I therefore want to explore the options available for generating these in knitr. It is important to remember that there are two ways of generating tables in markdown: 1. Markdown tables 2. HTML tables As the `htmlTable`-package is all about [HTML](https://en.wikipedia.org/wiki/HTML) tables we will work only with that output option. The core idea is that HTML is ubiquitous and that most word-processors will have to support copy-pasting tables and by providing simple simple CSS-formatting we are able to maximize this compatibility. _Note_ CSS is today an extremely complex topic and it is no surprise that word-processors may have difficulty importing tables that have lots of advanced syntax, htmlTable tries to avoid all of that by putting the style close to each element, often at the cell-level. # Basics I developed the `htmlTable` in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the `Hmisc::latex` function on [Stack Overflow](https://stackoverflow.com/questions/11950703/html-with-multicolumn-table-in-markdown-using-knitr) I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two: ```{r} library(htmlTable) setHtmlTableTheme(theme = "Google docs") output <- matrix(paste("Content", LETTERS[1:16]), ncol = 4, byrow = TRUE) output |> htmlTable(header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2, 2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2, 2), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment") ``` We can modify all our tables by using the `setHtmlTableTemplate()` and we also don't have to set the exact span of each group as it can be assumed from the data. ```{r} setHtmlTableTheme(pos.caption = "bottom") output |> addHtmlTableStyle(css.rgroup = "font-style: italic") |> htmlTable(header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B", ""), n.rgroup = c(1, 2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = 3, caption = "A slightly differnt table with a bottom caption", tfoot = "† A table footer commment") ``` The basic principles are: - use the `|>` pipe as much as possible - build complexity stepwise through passing `addHtmlTableStyle()` function - keep arguments to a minimum through templating and autocalculation # Example based upon Swedish statistics In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. **Goal: visualize migration patterns**. The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format. ```{r, results='markup', message=FALSE, warning=FALSE} data(SCB) # The SCB has three other columns and one value column prepped_scb <- SCB |> dplyr::mutate(region = relevel(SCB$region, "Sweden")) |> dplyr::select(year, region, sex, values) |> tidyr::pivot_wider(names_from = c(region, sex), values_from = values) # Set rownames to be year rownames(prepped_scb) <- prepped_scb$year prepped_scb$year <- NULL # The dataset now has the rows names(prepped_scb) # and the dimensions dim(prepped_scb) ``` The next step is to calculate two new columns: - Δint = The change within each group since the start of the observation. - Δstd = The change in relation to the overall age change in Sweden. To convey all these layers of information will create a table with multiple levels of column spanners:
County
Men   Women
AgeΔint.Δext.   AgeΔint.Δext.
```{r} mx <- NULL for (n in names(prepped_scb)) { tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(prepped_scb[[n]], prepped_scb[[n]] - prepped_scb[[n]][1], prepped_scb[[n]] - prepped_scb[[tmp]])) } rownames(mx) <- rownames(prepped_scb) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(prepped_scb)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(prepped_scb), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(prepped_scb))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(prepped_scb) - length(cgroup))), Hmisc::capitalize( sapply(names(prepped_scb), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(prepped_scb) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ``` Next step is to output the table after rounding to the correct number of decimals. The `txtRound` function helps with this, as it uses the `sprintf` function instead of the `round` the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0. ```{r} htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument. ```{r} mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", spacer.celltype = "double_cell") |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we still feel that we want more separation it is always possible to add colors. ```{r} mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", align.header = "c", col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4))) |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid. ```{r} mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", align.header = "c", col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), col.rgroup = c("none", "#FFFFCC")) |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters. ```{r} cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr) { out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } out_mx |> addHtmlTableStyle(align = "rrrr|r", align.header = "cccc|c", pos.rowlabel = "bottom", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4))) |> htmlTable(caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", rowlabel = "Year", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data. Lastly I would like to thank [Stephen Few](https://www.amazon.com/Show-Me-Numbers-Designing-Enlighten/dp/0970601999), [ThinkUI](http://www.thinkui.co.uk/resources/effective-design-of-data-tables/), and [LabWrite](https://labwrite.ncsu.edu/res/gh/gh-tables.html) for inspiration. htmlTable/inst/doc/general.Rmd0000644000176200001440000002613313730477224016007 0ustar liggesusers--- title: "How-to use htmlTable" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{How-to use htmlTable} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Basics ====== The **htmlTable** package is intended for generating tables using [HTML](https://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](https://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```{r} library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol = 2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ``` The function is also aware of the dimnames: ```{r} # A simple output matrix(1:4, ncol = 2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ``` This can be convenient when working with the `base::table` function: ```{r} data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ``` As of version 1.1 you **no longer need** to specify `results='asis'` for each `knitr` chunk. **Tip**: If you are working a lot with `dplyr` and the `tidyverse` approach to exploring data you can make your life much easier using the `tidyHtmlTable()` function included in this package that automatically calculates the `rgroup`, `cgroup` and other parameters that make `htmlTable` so useful. Table caption ------------- The table caption is simply the table description and can be either located above or below: ```{r ctable_example} output <- matrix(1:4, ncol = 2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable = c("solid", "double"), caption = "A table caption above and ctable borders") ``` The caption defaults to above but by setting the `pos.caption` argument to "bottom" it appears below the table. ```{r table_with_caption_below} output %>% addHtmlTableStyle(pos.caption = "bottom") %>% htmlTable(caption = "A table caption below") ``` Cell alignment -------------- Cell alignment is specified through the `align`, `align.header`, `align.cgroup` arguments. For aligning the cell values just use `align`. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below: ```{r} 1:3 %>% addHtmlTableStyle(align = "lcr") %>% htmlTable(rnames = "Row 1", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the `align.header` argument: ```{r} 1:3 %>% addHtmlTableStyle(align = "clcr", align.header = "lcr") %>% htmlTable(rnames = "Row 1", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as: * row groups * column spanners * table spanners * total row * table footer * zebra coloring (also known as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The `htmlTable`-function is written for all these purposes. For demonstration purposes we will setup a basic matrix: ```{r} mx <- matrix(ncol = 6, nrow = 8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)) { for (nc in 1:ncol(mx)) { mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```{r} htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ``` We can easily mix row groups with regular variables by having an empty row group name `""`: ```{r} htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```{r} mx %>% addHtmlTableStyle(css.rgroup = "") %>% htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` The `rgroup` is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the 'add' attribute to the `rgroup`: ```{r} rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ``` Column spanners --------------- A column spanner spans 2 or more columns: ```{r} htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ``` It can sometimes be convenient to have column spanners in multiple levels: ```{r} htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ``` Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function and you can also provide a `list` with elements that allows you to skip the `NA` at the end of the matrix: ```{r} htmlTable(mx, cgroup = list(c("Super column spanner", ""), c("", "Another cgroup"), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = list(c(5,1), c(1,2), c(2,2,2))) ``` Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Note that you actually don't need the last `n.tspanner`, i.e. you can simplify the above to: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4)) ``` Similarly you can use the number rgroups included in each tspanner instead of actual rows. This is convenient as the tspannners must align with underlying rgroups. Total row --------- Many financial tables use the concept of a total row at the end that sums the above elements: ```{r} htmlTable(mx[1:3,], total = TRUE) ``` This can also be combined with table spanners: ```{r} mx %>% addHtmlTableStyle(css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900")) %>% htmlTable(total = "tspanner", tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Table numbering --------------- The htmlTable has built-in numbering, initialized by: ```{r} options(table_counter = TRUE) ``` ```{r} htmlTable(mx[1:2,1:2], caption = "A table caption with a numbering") ``` As we often want to reference the table number in the text there are two associated functions: ```{r} tblNoLast() tblNoNext() ``` ```{r} htmlTable(mx[1:2,1:2], caption = "Another table with numbering") ``` If you want to start the counter at 2 you can instead of setting table_counter to `TRUE` set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by: ```{r} options(table_counter = FALSE) ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```{r} htmlTable(mx[1:2,1:2], tfoot = "A table footer") ``` Zebra coloring (or banded colors) ------------------------------------ Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows: ```{r} mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% htmlTable ``` The zebra coloring in `htmlTable` is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. "" will have alternating colors event though they programatically are within the same group: ```{r} mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F7F7F7")) %>% htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ``` We can also color the columns: ```{r} mx %>% addHtmlTableStyle(col.columns = c("none", "#F7F7F7")) %>% htmlTable ``` Or do both (note that the colors blend at the intersections): ```{r} mx %>% addHtmlTableStyle(col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) %>% htmlTable ``` Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```{r} rgroup = paste("Group", LETTERS[1:3]) attr(rgroup, "add") <- list(`3` = "Group p-value < 0.001") mx %>% addHtmlTableStyle(align = "rr|r", align.header = "cc|c", spacer.celltype = "double_cell", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;", css.header = "font-weight: normal") %>% htmlTable(rgroup = rgroup, n.rgroup = c(2,4), tspanner = paste("Spanner", LETTERS[1:2]), n.tspanner = c(1), cgroup = list(c("", "Column spanners"), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = list(c(1,5), c(2,2,2)), caption = "A table with column spanners, row groups, and zebra striping", tfoot = "† A table footer commment", cspan.rgroup = 2) ``` htmlTable/inst/doc/complex_tables.R0000644000176200001440000001750114646657231017056 0ustar liggesusers## ----------------------------------------------------------------------------- library(htmlTable) setHtmlTableTheme(theme = "Google docs") output <- matrix(paste("Content", LETTERS[1:16]), ncol = 4, byrow = TRUE) output |> htmlTable(header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2, 2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2, 2), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment") ## ----------------------------------------------------------------------------- setHtmlTableTheme(pos.caption = "bottom") output |> addHtmlTableStyle(css.rgroup = "font-style: italic") |> htmlTable(header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B", ""), n.rgroup = c(1, 2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = 3, caption = "A slightly differnt table with a bottom caption", tfoot = "† A table footer commment") ## ----results='markup', message=FALSE, warning=FALSE--------------------------- data(SCB) # The SCB has three other columns and one value column prepped_scb <- SCB |> dplyr::mutate(region = relevel(SCB$region, "Sweden")) |> dplyr::select(year, region, sex, values) |> tidyr::pivot_wider(names_from = c(region, sex), values_from = values) # Set rownames to be year rownames(prepped_scb) <- prepped_scb$year prepped_scb$year <- NULL # The dataset now has the rows names(prepped_scb) # and the dimensions dim(prepped_scb) ## ----------------------------------------------------------------------------- mx <- NULL for (n in names(prepped_scb)) { tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(prepped_scb[[n]], prepped_scb[[n]] - prepped_scb[[n]][1], prepped_scb[[n]] - prepped_scb[[tmp]])) } rownames(mx) <- rownames(prepped_scb) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(prepped_scb)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(prepped_scb), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(prepped_scb))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(prepped_scb) - length(cgroup))), Hmisc::capitalize( sapply(names(prepped_scb), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(prepped_scb) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ## ----------------------------------------------------------------------------- htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ----------------------------------------------------------------------------- mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", spacer.celltype = "double_cell") |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ----------------------------------------------------------------------------- mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", align.header = "c", col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4))) |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ----------------------------------------------------------------------------- mx |> txtRound(digits = 1) |> addHtmlTableStyle(align = "rrrr|r", align.header = "c", col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), col.rgroup = c("none", "#FFFFCC")) |> htmlTable(cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ## ----------------------------------------------------------------------------- cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr) { out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } out_mx |> addHtmlTableStyle(align = "rrrr|r", align.header = "cccc|c", pos.rowlabel = "bottom", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4))) |> htmlTable(caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", rowlabel = "Year", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) htmlTable/README.md0000644000176200001440000015100714517463044013461 0ustar liggesusers[![Downloads](https://cranlogs.r-pkg.org/badges/htmlTable)](https://cran.r-project.org/package=htmlTable) # Basics The **htmlTable** package is intended for generating tables using [HTML](https://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](https://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```r library(magrittr) library(htmlTable) # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) ```
Column 1 Column 2
Row 1 1 3
Row 2 2 4
If you are using `dplyr` and `tidyverse` a convenient wrapper is the `tidyHtmlTable` function (check out `vignette("tidyHtmlTable")`). A simple example of the `tidyHtmlTable` would look something like this: ```r library(tidyverse) library(glue) mtcars |> as_tibble(rownames = "rnames") |> filter(cyl == 6 & qsec < 18) |> pivot_longer(names_to = "per_metric", cols = c(hp, mpg, qsec)) |> arrange(gear, rnames) |> mutate(gear = glue("{gear} gears")) |> addHtmlTableStyle(align = "r") |> tidyHtmlTable(header = per_metric, rnames = rnames, rgroup = gear, caption = "A simple tidyHtmlTable example using mtcars") ```
A simple tidyHtmlTable example using mtcars
hp mpg qsec
4 gears
  Mazda RX4 110 21 16.46
  Mazda RX4 Wag 110 21 17.02
5 gears
  Ferrari Dino 175 19.7 15.5
# Advanced While it may be sufficient for basic tables a more advanced layout is often needed in medical publications with elements such as: - row groups - column spanners - table spanners - caption - table footer - zebra coloring (also know as _banding_): - rows - columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table doesn't only look nice in a web browser but also in the final document. The `htmlTable`-function is written for all these purposes. **Note:** Due to GitHub CSS-styles the rows get automatically zebra-striped (in a bad way), borders get overridden and I haven't been able to figure out how to change this. See the vignette for a correct example: `vignette("general", package = "htmlTable")` For demonstration purposes we will setup a basic matrix: ```r mx <- matrix(ncol=6, nrow=8) |> set_rownames(paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row")) |> set_colnames(paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr")) for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ``` ## Row groups The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```r htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6
We can easily mix row groups with regular variables by having an empty row group name `""`: ```r htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label. As of htmlTable version 2.0 you can separate the css styling using `addHtmlTableStyle`: ```r mx |> addHtmlTableStyle(css.rgroup = "") |> htmlTable(rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
## Column spanners A column spanner spans 2 or more columns: ```r htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ```
Cgroup 1  Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4 1:5 1:6
2nd row 2:1 2:2   2:3 2:4 2:5 2:6
3rd row 3:1 3:2   3:3 3:4 3:5 3:6
4th row 4:1 4:2   4:3 4:4 4:5 4:6
5th row 5:1 5:2   5:3 5:4 5:5 5:6
6th row 6:1 6:2   6:3 6:4 6:5 6:6
7th row 7:1 7:2   7:3 7:4 7:5 7:6
8th row 8:1 8:2   8:3 8:4 8:5 8:6
It can sometimes be convenient to have column spanners in multiple levels: ```r htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ```
  Column spanners
  Cgroup 1  Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4   1:5 1:6
2nd row 2:1 2:2   2:3 2:4   2:5 2:6
3rd row 3:1 3:2   3:3 3:4   3:5 3:6
4th row 4:1 4:2   4:3 4:4   4:5 4:6
5th row 5:1 5:2   5:3 5:4   5:5 5:6
6th row 6:1 6:2   6:3 6:4   6:5 6:6
7th row 7:1 7:2   7:3 7:4   7:5 7:6
8th row 8:1 8:2   8:3 8:4   8:5 8:6
Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function: ```r htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,5,NA), c(2,1,3))) ```
  Column spanners
  Cgroup 1  Cgroup 2
1st hdr   2nd hdr   3rd hdr   4th hdr 5th hdr 6th hdr
1st row 1:1   1:2   1:3   1:4 1:5 1:6
2nd row 2:1   2:2   2:3   2:4 2:5 2:6
3rd row 3:1   3:2   3:3   3:4 3:5 3:6
4th row 4:1   4:2   4:3   4:4 4:5 4:6
5th row 5:1   5:2   5:3   5:4 5:5 5:6
6th row 6:1   6:2   6:3   6:4 6:5 6:6
7th row 7:1   7:2   7:3   7:4 7:5 7:6
8th row 8:1   8:2   8:3   8:4 8:5 8:6
## Table spanners A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```r htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
## Table caption The table caption is simply the table description and can be either located above or below the table: ```r htmlTable(mx[1:2,1:2], caption="A table caption above") ```
Table 5: A table caption above
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
```r mx[1:2,1:2] |> addHtmlTableStyle(pos.caption = "bottom") |> htmlTable(caption="A table caption below") ```
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
Table 6: A table caption below
A more interesting detail that the function allows for is table numbering, initialized by: ```r options(table_counter = TRUE) ``` ```r htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ```
Table 1: A table caption with a numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
As we often want to reference the table number in the text there are two associated functions: ```r tblNoLast() ``` ``` ## [1] 1 ``` ```r tblNoNext() ``` ``` ## [1] 2 ``` ## Table footer The footer usually contains specifics regarding variables and is always located at the foot of the table: ```r htmlTable(mx[1:2,1:2], tfoot="A table footer") ```
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
A table footer
## Putting it all together Now if we want to do everything in one table it may look like this: ```r mx |> addHtmlTableStyle(col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;", align="r") |> htmlTable(rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2, 4), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1, 2, NA), c(2, 2, 2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2) ```
Table 2: A table with column spanners, row groups, and zebra striping
  Column spanners
  Cgroup 1  Cgroup 2†
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
Group A    
  1st row 1:1 1:2   1:3 1:4   1:5 1:6
  2nd row 2:1 2:2   2:3 2:4   2:5 2:6
Group B    
  3rd row 3:1 3:2   3:3 3:4   3:5 3:6
  4th row 4:1 4:2   4:3 4:4   4:5 4:6
  5th row 5:1 5:2   5:3 5:4   5:5 5:6
  6th row 6:1 6:2   6:3 6:4   6:5 6:6
Group C    
  7th row 7:1 7:2   7:3 7:4   7:5 7:6
  8th row 8:1 8:2   8:3 8:4   8:5 8:6
† A table footer comment
htmlTable/build/0000755000176200001440000000000014646657237013311 5ustar liggesusershtmlTable/build/vignette.rds0000644000176200001440000000046614646657237015656 0ustar liggesusersN0 5t!4MPMaFLn<8]RS۷IÀ!'}Şq;QvPd5z+dٿ}O<9rG5L2>_A zP@?lݦȥ\[Ϋj9d{5tm~=mv*.lģnݰ9F)63(c=2D30Q PF YGi;'|^,q` X~'8UB")nM]_~EΔ',J|MhtmlTable/man/0000755000176200001440000000000014517464356012760 5ustar liggesusershtmlTable/man/tblNoNext.Rd0000644000176200001440000000125513701421460015146 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tblNo.R \name{tblNoNext} \alias{tblNoNext} \title{Gets the next table number} \usage{ tblNoNext(roman = getOption("table_counter_roman", FALSE)) } \arguments{ \item{roman}{Whether or not to use roman numbers instead of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} } \description{ The function relies on \code{options("table_counter")} in order to keep track of the last number. } \examples{ org_opts <- options(table_counter=1) tblNoNext() options(org_opts) } \seealso{ Other table functions: \code{\link{htmlTable}}, \code{\link{tblNoLast}()} } \concept{table functions} htmlTable/man/prAddEmptySpacerCell.Rd0000644000176200001440000000255313730316012017240 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render_prAddEmptySpacerCell.R \name{prAddEmptySpacerCell} \alias{prAddEmptySpacerCell} \title{Add an empty cell} \usage{ prAddEmptySpacerCell( x, style_list, cell_style, align_style, cell_tag = c("td", "th"), colspan = 1 ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cell_style}{The style of the current cell that should be applied to all cells} \item{align_style}{The style from \code{\link[=prGetAlign]{prGetAlign()}}} \item{cell_tag}{What HTML tag to use} \item{colspan}{The number of rows each tag should span} } \value{ \code{string} } \description{ Depending on the \code{spacer.celltype} set in \code{\link[=addHtmlTableStyle]{addHtmlTableStyle()}} we will use different spacer cells. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prPrepareAlign.Rd0000644000176200001440000000313513730316012016141 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_prepareAlign.R \name{prPrepareAlign} \alias{prPrepareAlign} \title{Prepares the align to match the columns} \usage{ prPrepareAlign(align, x, rnames, default_rn = "l") } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} \item{default_rn}{The default rowname alignment. This is an option as the header uses the same function and there may be differences in how the alignments should be implemented.} } \description{ The alignment may be tricky and this function therefore simplifies this process by extending/shortening the alignment to match the correct number of columns. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prGetStyle.Rd0000644000176200001440000000215214517434555015347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_getStyle.R \name{prGetStyle} \alias{prGetStyle} \title{Gets the CSS style element} \usage{ prGetStyle(...) } \arguments{ \item{...}{Styles can be provided as \code{vector}, \verb{named vector}, or \code{string}. If you provide a name, e.g. \code{background: blue}, \code{align="center"}, the function will convert the \code{align} into proper \code{align: center}.} } \value{ \code{string} Returns the codes merged into one string with correct CSS ; and : structure. } \description{ A function for checking, merging, and more with a variety of different style formats. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/htmlTable.Rd0000644000176200001440000004740414517464356015174 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R, R/htmlTable_render_knit_print.R, % R/htmlTable_render_print.R \name{htmlTable} \alias{htmlTable} \alias{htmlTable.default} \alias{knit_print.htmlTable} \alias{print.htmlTable} \title{Output an HTML table} \usage{ htmlTable( x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL, tfoot = NULL, label = NULL, rgroup = NULL, n.rgroup = NULL, cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL, total = NULL, ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ... ) \method{htmlTable}{default}( x, header = NULL, rnames = NULL, rowlabel = NULL, caption = NULL, tfoot = NULL, label = NULL, rgroup = NULL, n.rgroup = NULL, cgroup = NULL, n.cgroup = NULL, tspanner = NULL, n.tspanner = NULL, total = NULL, ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ... ) \method{knit_print}{htmlTable}(x, ...) \method{print}{htmlTable}(x, useViewer, ...) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base:colnames]{colnames(x)}}} \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} \item{rowlabel}{If the table has row names or \code{rnames}, \code{rowlabel} is a character string containing the column heading for the \code{rnames}.} \item{caption}{Adds a table caption.} \item{tfoot}{Adds a table footer (uses the \verb{} HTML element). The output is run through \code{\link[=txtMergeLines]{txtMergeLines()}} simplifying the generation of multiple lines.} \item{label}{A text string representing a symbolic label for the table for referencing as an anchor. All you need to do is to reference the table, for instance \verb{see table 2}. This is known as the element's id attribute, i.e. table id, in HTML linguo, and should be unique id for an HTML element in contrast to the \code{css.class} element attribute.} \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{n.rgroup}{An integer vector giving the number of rows in each grouping. If \code{rgroup} is not specified, \code{n.rgroup} is just used to divide off blocks of rows by horizontal lines. If \code{rgroup} is given but \code{n.rgroup} is omitted, \code{n.rgroup} will default so that each row group contains the same number of rows. If you want additional rgroup column elements to the cells you can sett the "add" attribute to \code{rgroup} through \code{attr(rgroup, "add")}, see below explaining section.} \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the \code{n.cgroup} is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{tspanner}{The table spanner is somewhat of a table header that you can use when you want to join different tables with the same columns.} \item{n.tspanner}{An integer vector with the number of rows or \code{rgroup}s in the original matrix that the table spanner should span. If you have provided one fewer n.tspanner elements the last will be imputed from the number of \code{rgroup}s (if you have provided \code{rgroup} and \code{sum(n.tspanner) < length(rgroup)}) or the number of rows in the table.} \item{total}{The last row is sometimes a row total with a border on top and bold fonts. Set this to \code{TRUE} if you are interested in such a row. If you want a total row at the end of each table spanner you can set this to \code{"tspanner"}.} \item{ctable}{If the table should have a double top border or a single a' la LaTeX ctable style} \item{compatibility}{Is default set to \code{LibreOffice} as some settings need to be in old HTML format as Libre Office can't handle some commands such as the css caption-alignment. Note: this option is not yet fully implemented for all details, in the future I aim to generate a HTML-correct table and one that is aimed at Libre Office compatibility. Word-compatibility is difficult as Word ignores most settings and destroys all layout attempts (at least that is how my 2010 version behaves). You can additinally use the \code{options(htmlTableCompat = "html")} if you want a change to apply to the entire document. MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"".} \item{cspan.rgroup}{The number of columns that an \code{rgroup} should span. It spans by default all columns but you may want to limit this if you have column colors that you want to retain.} \item{escape.html}{logical: should HTML characters be escaped? Defaults to FALSE.} \item{...}{Passed on to \code{print.htmlTable} function and any argument except the \code{useViewer} will be passed on to the \code{\link[base:cat]{base::cat()}} functions arguments. \emph{Note:} as of version 2.0.0 styling options are still allowed but it is recommended to instead preprocess your object with \code{\link[=addHtmlTableStyle]{addHtmlTableStyle()}}.} \item{useViewer}{If you are using RStudio there is a viewer thar can render the table within that is envoced if in \code{\link[base:interactive]{base::interactive()}} mode. Set this to \code{FALSE} if you want to remove that functionality. You can also force the function to call a specific viewer by setting this to a viewer function, e.g. \code{useViewer = utils::browseURL} if you want to override the default RStudio viewer. Another option that does the same is to set the \code{options(viewer=utils::browseURL)} and it will default to that particular viewer (this is how RStudio decides on a viewer). \emph{Note:} If you want to force all output to go through the \code{\link[base:cat]{base::cat()}} the set \verb{[options][base::options](htmlTable.cat = TRUE)}.} } \value{ Returns a formatted string representing an HTML table of class \code{htmlTable}. } \description{ Generates advanced HTML tables with column and row groups for a dense representation of complex data. Designed for maximum compatibility with copy-paste into word processors. For styling, see \code{\link[=addHtmlTableStyle]{addHtmlTableStyle()}} and \code{\link[=setHtmlTableTheme]{setHtmlTableTheme()}}. \emph{Note:} If you are using \pkg{tidyverse} and \pkg{dplyr} you may want to check out \code{\link[=tidyHtmlTable]{tidyHtmlTable()}} that automates many of the arguments that \code{htmlTable} requires. } \section{Multiple rows of column spanners \code{cgroup}}{ If you want to have a column spanner in multiple levels (rows) you can set the \code{cgroup} and \code{n.cgroup} arguments to a \code{matrix} or \code{list}. For different level elements, set absent ones to NA in a matrix. For example, \code{cgroup = rbind(c("first", "second", NA), c("a", "b", "c"))}. And the corresponding \code{n.cgroup} would be \code{n.cgroup = rbind(c(1, 2, NA), c(2, 1, 2))}. for a table consisting of 5 columns. The "first" spans the first two columns, the "second" spans the last three columns, "a" spans the first two, "b" the middle column, and "c" the last two columns. Using a list is recommended to avoid handling \code{NA}s. For an empty \code{cgroup}, use \code{""}. } \section{The \code{rgroup} argument}{ The \code{rgroup} groups rows seamlessly. Each row in a group is indented by two spaces (unless the rgroup is \code{""}) and grouped by its rgroup element. The \code{sum(n.rgroup)} should be zr3ywKOjLZACY4j7TuGXu4v6I8wVWuKy-\eqn{\leq} matrix rows. If fewer, remaining rows are padded with an empty rgroup (\code{""}). If \code{rgroup} has one more element than \code{n.rgroup}, the last \code{n.rgroup} is computed as \code{nrow(x) - sum(n.rgroup)} for a smoother table generation. } \section{The add attribute to \code{rgroup}}{ To add an extra element at the \code{rgroup} level/row, use \code{attr(rgroup, 'add')}. The value can either be a \code{vector}, a \code{list}, or a \code{matrix}. See \code{vignette("general", package = "htmlTable")} for examples. \itemize{ \item A \code{vector} of either equal number of \code{rgroup}s to the number of \code{rgroup}s that aren't empty, i.e. \code{rgroup[rgroup != ""]}. Or a named vector where the name must correspond to either an \code{rgroup} or to an \code{rgroup} number. \item A \code{list} that has exactly the same requirements as the vector. In addition to the previous we can also have a list with column numbers within as names within the list. \item A \code{matrix} with the dimension \verb{nrow(x) x ncol(x)} or \verb{nrow(x) x 1} where the latter is equivalent to a named vector. If you have \code{rownames} these will resolve similarly to the names to the \code{list}/\code{vector} arguments. The same thing applies to \code{colnames}. } } \section{Important \pkg{knitr}-note}{ This function will only work with \pkg{knitr} outputting \emph{HTML}, i.e. markdown mode. As the function returns raw HTML-code the compatibility with non-HTML formatting is limited, even with \href{https://pandoc.org/}{pandoc}. Thanks to the the \code{\link[knitr:knit_print]{knitr::knit_print()}} and the \code{\link[knitr:asis_output]{knitr::asis_output()}} the \code{results='asis'} is \emph{no longer needed} except within for-loops. If you have a knitr-chunk with a for loop and use \code{print()} to produce raw HTML you must set the chunk option \code{results='asis'}. \emph{Note}: the print-function relies on the \code{\link[base:interactive]{base::interactive()}} function for determining if the output should be sent to a browser or to the terminal. In vignettes and other directly knitted documents you may need to either set \code{useViewer = FALSE} alternatively set \code{options(htmlTable.cat = TRUE)}. } \section{RStudio's notebook}{ RStudio has an interactive notebook that allows output directly into the document. In order for the output to be properly formatted it needs to have the \code{class} of \code{html}. The \code{htmlTable} tries to identify if the environment is a notebook document (uses the \pkg{rstudioapi} and identifies if its a file with and \code{Rmd} file ending or if there is an element with \code{html_notebook}). If you don't want this behavior you can remove it using the \code{options(htmlTable.skip_notebook = TRUE)}. } \section{Table counter}{ If you set the option table_counter you will get a Table 1,2,3 etc before each table, just set \code{options(table_counter=TRUE)}. If you set it to a number then that number will correspond to the start of the table_counter. The \code{table_counter} option will also contain the number of the last table, this can be useful when referencing it in text. By setting the option \code{options(table_counter_str = "Table \%s: ")} you can manipulate the counter table text that is added prior to the actual caption. Note, you should use the \code{\link[=sprintf]{sprintf()}} \verb{\%s} instead of \verb{\%d} as the software converts all numbers to characters for compatibility reasons. If you set \code{options(table_counter_roman = TRUE)} then the table counter will use Roman numerals instead of Arabic. } \section{Empty data frames}{ An empty data frame will result in a warning and output an empty table, provided that \code{rgroup} and \code{n.rgroup} are not specified. All other row layout options will be ignored. } \section{Options}{ There are multiple options that can be set, here is a set of the perhaps most used \itemize{ \item \code{table_counter} - logical - activates a counter for each table \item \code{table_counter_roman} - logical - if true the counter is in Roman numbers, i.e. I, II, III, IV... \item \code{table_counter_str} - string - the string used for generating the table counter text \item \code{useViewer} - logical - if viewer should be used fro printing the table \item \code{htmlTable.cat} - logical - if the output should be directly sent to \code{cat()} \item \code{htmlTable.skip_notebook} - logical - skips the logic for detecting notebook \item \code{htmlTable.pretty_indentation} - logical - there was some issues in previous Pandoc versions where HTML indentation caused everything to be interpreted as code. This seems to be fixed and if you want to look at the raw HTML code it is nice to have this set to \code{TRUE} so that the tags and elements are properly indented. \item \code{htmlTableCompat} - string - see parameter description } } \section{Other}{ \emph{Copy-pasting:} As you copy-paste results into Word you need to keep the original formatting. Either right click and choose that paste option or click on the icon appearing after a paste. Currently the following compatibilities have been tested with MS Word 2016: \itemize{ \item \strong{Internet Explorer} (v. 11.20.10586.0) Works perfectly when copy-pasting into Word \item \strong{RStudio} (v. 0.99.448) Works perfectly when copy-pasting into Word. \emph{Note:} can have issues with multi-line \code{cgroup}s - see \href{https://bugs.chromium.org/p/chromium/issues/detail?id=305130}{bug} \item \strong{Chrome} (v. 47.0.2526.106) Works perfectly when copy-pasting into Word. \emph{Note:} can have issues with multi-line \code{cgroup}s - see \href{https://bugs.chromium.org/p/chromium/issues/detail?id=305130}{bug} \item \strong{Firefox} (v. 43.0.3) Works poorly - looses font-styling, lines and general feel \item \strong{Edge} (v. 25.10586.0.0) Works poorly - looses lines and general feel } \emph{Direct word processor opening:} Opening directly in Libre Office or Word is no longer recommended. You get much prettier results using the cut-and-paste option. \emph{Google docs}: Copy-paste directly into a Google docs document is handled rather well. This seems to work especially well when the paste comes directly from a Chrome browser. \emph{Note} that when using complex \code{cgroup} alignments with multiple levels not every browser is able to handle this. For instance the RStudio webkit browser seems to have issues with this and a \href{https://bugs.chromium.org/p/chromium/issues/detail?id=305130}{bug has been filed}. As the table uses HTML for rendering you need to be aware of that headers, row names, and cell values should try respect this for optimal display. Browsers try to compensate and frequently the tables still turn out fine but it is not advised. Most importantly you should try to use \verb{<} instead of \code{<} and \verb{>} instead of \code{>}. You can find a complete list of HTML characters \href{https://ascii.cl/htmlcodes.htm}{here}. Lastly, I want to mention that function was inspired by the \code{\link[Hmisc:latex]{Hmisc::latex()}} that can be an excellent alternative if you wish to switch to PDF-output. For the sibling function \code{\link[=tidyHtmlTable]{tidyHtmlTable()}} you can directly switch between the two using the \code{table_fn} argument. } \examples{ library(magrittr) # Basic example output <- matrix(1:4, ncol = 2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) invisible(readline(prompt = "Press [enter] to continue")) # An advanced output output <- matrix(ncol = 6, nrow = 8) for (nr in 1:nrow(output)) { for (nc in 1:ncol(output)) { output[nr, nc] <- paste0(nr, ":", nc) } } output \%>\% addHtmlTableStyle(align = "r", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") \%>\% htmlTable(header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment", cspan.rgroup = 2) invisible(readline(prompt = "Press [enter] to continue")) # An advanced empty table suppressWarnings({ matrix(ncol = 6, nrow = 0) \%>\% addHtmlTableStyle(col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") \%>\% htmlTable(align = "r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption = "Basic empty table with column spanners (groups) and ignored row colors", tfoot = "† A table footer commment", cspan.rgroup = 2) }) invisible(readline(prompt = "Press [enter] to continue")) # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol = 2) simple_output \%>\% addHtmlTableStyle(css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times = ncol(simple_output)), matrix("", ncol = ncol(simple_output), nrow = nrow(simple_output)))) \%>\% htmlTable(header = LETTERS[1:2]) invisible(readline(prompt = "Press [enter] to continue")) # See vignette("tables", package = "htmlTable") # for more examples, also check out tidyHtmlTable() that manages # the group arguments for you through tidy-select syntax } \seealso{ \code{\link[=addHtmlTableStyle]{addHtmlTableStyle()}}, \code{\link[=setHtmlTableTheme]{setHtmlTableTheme()}}, \code{\link[=tidyHtmlTable]{tidyHtmlTable()}}. \code{\link[=txtMergeLines]{txtMergeLines()}}, \code{\link[Hmisc:latex]{Hmisc::latex()}} Other table functions: \code{\link{tblNoLast}()}, \code{\link{tblNoNext}()} } \concept{table functions} htmlTable/man/tidyHtmlTable.Rd0000644000176200001440000001420614517463044016011 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidyHtmlTable.R \name{tidyHtmlTable} \alias{tidyHtmlTable} \title{Generate an htmlTable using tidy data as input} \usage{ tidyHtmlTable( x, value, header, rnames, rgroup, hidden_rgroup, cgroup, tspanner, hidden_tspanner, skip_removal_warning = getOption("htmlTable.skip_removal_warning", FALSE), rnames_unique, table_fn = htmlTable, ... ) } \arguments{ \item{x}{Tidy data used to build the \code{htmlTable}} \item{value}{Column containing values for individual table cells. Defaults to "value" (same as \link[tidyr:pivot_wider]{tidyr::pivot_wider}).} \item{header}{Column in \code{x} specifying column headings} \item{rnames}{Column in \code{x} specifying row names. Defaults to "name" (same as \code{\link[tidyr:pivot_wider]{tidyr::pivot_wider()}}).} \item{rgroup}{Column in \code{x} specifying row groups.} \item{hidden_rgroup}{Strings indicating \code{rgroup} values to be hidden.} \item{cgroup}{Columns in \code{x} specifying the column groups.} \item{tspanner}{Column in \code{x} specifying \code{tspanner} groups.} \item{hidden_tspanner}{Strings indicating \code{tspanner} values to be hidden.} \item{skip_removal_warning}{Boolean to suppress warnings when removing \code{NA} columns.} \item{rnames_unique}{Designates unique row names when regular names lack uniqueness.} \item{table_fn}{Function to format the table, defaults to \code{\link[=htmlTable]{htmlTable()}}.} \item{...}{Additional arguments passed to \code{\link[=htmlTable]{htmlTable()}}.} } \value{ Returns the HTML code that, when rendered, displays a formatted table. } \description{ This function maps columns from the input data, \code{x}, to \code{\link[=htmlTable]{htmlTable()}} parameters. It's designed to provide a fluent interface for those familiar with the \code{tidyverse} ecosystem. } \section{Column-mapping}{ Columns from \code{x} are mapped (transformed) to specific parameters of the \code{\link[=htmlTable]{htmlTable()}} The following columns are converted to match the intended input structure: \itemize{ \item \code{value} \item \code{header} \item \code{rnames} \item \code{rgroup} \item \code{cgroup} \item \code{tspanner} } Each combination of the variables in \code{x} should be unique to map correctly to the output table. } \section{Row uniqueness}{ Usually each row should have a unique combination of the mappers. Sometimes though rows come in a distinct order and the order identifies the row more than the name. E.g. if we are identifying bone fractures using the AO-classification we will have classes ranging in the form of: \itemize{ \item A \item A1 \item A1.1 \item A2 \item A2.1 \item A2.2 \item B \item ... } we can simplify the names while retaining the key knowledge to: \itemize{ \item A \item .1 \item ...1 \item .2 \item ...1 \item ...2 \item B \item ... } This will though result in non-unique rows and thus we need to provide the original names in addition to the \code{rnames} argument. To do this we have \code{rnames_unique} as a parameter, without this \code{tidyHtmlTable} we risk unintended merging of cells, generating > 1 value per cell. \emph{Note} it is recommended that you verify with the full names just to make sure that any unexpected row order change has happened in the underlying pivot functions. } \section{Sorting}{ Rows can be pre-sorted using \code{\link[dplyr:arrange]{dplyr::arrange()}} before passing to \code{tidyHtmlTable}. Column sorting is based on \code{arrange(cgroup, header)}. If you want to sort in non-alphabetic order you can provide a factor variable and that information will be retained. } \section{Hidden values}{ \code{htmlTable} Allows for some values within \code{rgroup}, \code{cgroup}, etc. to be specified as \code{""}. The following parameters allow for specific values to be treated as if they were a string of length zero in the \code{htmlTable} function. \itemize{ \item \code{hidden_rgroup} \item \code{hidden_tspanner} } } \section{Simple tibble output}{ The tibble discourages the use of row names. There is therefore a convenience option for \code{tidyHtmlTable} where you can use the function just as you would with \code{\link[=htmlTable]{htmlTable()}} where \code{rnames} is populated with the \code{rnames} argument provided using \code{tidyselect} syntax (defaults to the "names" column if present int the input data). } \section{Additional dependencies}{ In order to run this function you also must have \pkg{dplyr}, \pkg{tidyr}, \pkg{tidyselect} and \pkg{purrr} packages installed. These have been removed due to the additional 20 Mb that these dependencies added (issue #47). \emph{Note:} if you use \pkg{tidyverse} it will already have all of these and you do not need to worry. } \examples{ library(tibble) library(dplyr) library(tidyr) # Prep and select basic data data("mtcars") base_data <- mtcars \%>\% rownames_to_column() \%>\% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) \%>\% select(rowname, cyl, gear, wt, mpg, qsec) base_data \%>\% pivot_longer(names_to = "per_metric", cols = c(wt, mpg, qsec)) \%>\% group_by(cyl, gear, per_metric) \%>\% summarise(value_Mean = round(mean(value), 1), value_Min = round(min(value), 1), value_Max = round(max(value), 1), .groups = "drop") \%>\% pivot_wider(names_from = per_metric, values_from = starts_with("value_")) \%>\% # Round the values into a nicer format where we want the weights to have two decimals txtRound(ends_with("_wt"), digits = 2) \%>\% txtRound(starts_with("value") & !ends_with("_wt"), digits = 1) \%>\% # Convert into long format pivot_longer(cols = starts_with("value_"), names_prefix = "value_") \%>\% separate(name, into = c("summary_stat", "per_metric")) \%>\% # Without sorting the row groups wont appear right # If the columns end up in the wrong order you may want to change the columns # into factors arrange(per_metric) \%>\% addHtmlTableStyle(align = "r") \%>\% tidyHtmlTable( header = gear, cgroup = cyl, rnames = summary_stat, rgroup = per_metric, skip_removal_warning = TRUE) } \seealso{ \code{\link[=htmlTable]{htmlTable()}} } htmlTable/man/prGetScriptString.Rd0000644000176200001440000000067113407215301016665 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interactiveTable.R \name{prGetScriptString} \alias{prGetScriptString} \title{Gets a string with all the scripts merged into one script tag} \usage{ prGetScriptString(x) } \arguments{ \item{x}{An interactiveTable} } \value{ string } \description{ Each element has it's own script tags in otherwise an error will cause all the scripts to fail. } \keyword{internal} htmlTable/man/prPrepInputMatrixDimensions.Rd0000644000176200001440000000221313730316012020730 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_prepInputMatrixDimensions.R \name{prPrepInputMatrixDimensions} \alias{prPrepInputMatrixDimensions} \title{Makes sure the input is correct} \usage{ prPrepInputMatrixDimensions(x, header = NULL) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base:colnames]{colnames(x)}}} } \description{ Checks and converts dimensions into something the \code{\link[=htmlTable]{htmlTable()}} is comfortable with. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/hasHtmlTableStyle.Rd0000644000176200001440000000155213730316012016620 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_style_handlers.R \name{hasHtmlTableStyle} \alias{hasHtmlTableStyle} \title{Check if object has a style set to it} \usage{ hasHtmlTableStyle(x, style_name) } \arguments{ \item{x}{The object intended for \code{\link[=htmlTable]{htmlTable()}}.} \item{style_name}{A string that contains the style name.} } \value{ \code{logical} \code{TRUE} if the attribute and style is not \code{NULL} } \description{ If the attribute \code{htmlTable.style} is set it will check if the \code{style_name} exists and return a \code{logical}. } \examples{ library(magrittr) mx <- matrix(1:4, ncol = 2) colnames(mx) <- LETTERS[1:2] mx \%>\% addHtmlTableStyle(align = "l|r") \%>\% hasHtmlTableStyle("align") } \seealso{ Other htmlTableStyle: \code{\link{addHtmlTableStyle}()} } \concept{htmlTableStyle} htmlTable/man/splitLines4Table.Rd0000644000176200001440000000074113701421460016412 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{splitLines4Table} \alias{splitLines4Table} \title{See \code{\link[=txtMergeLines]{txtMergeLines()}}} \usage{ splitLines4Table(...) } \arguments{ \item{...}{passed onto \code{\link[=txtMergeLines]{txtMergeLines()}}} } \description{ See \code{\link[=txtMergeLines]{txtMergeLines()}} } \examples{ \dontrun{ # Deprecated function splitLines4Table("hello", "world") } } \keyword{internal} htmlTable/man/setHtmlTableTheme.Rd0000644000176200001440000001531513730316012016604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_theme.R \name{setHtmlTableTheme} \alias{setHtmlTableTheme} \title{Set or update theme for \code{\link[=htmlTable]{htmlTable()}}} \usage{ setHtmlTableTheme( theme = NULL, align = NULL, align.header = NULL, align.cgroup = NULL, css.rgroup = NULL, css.rgroup.sep = NULL, css.tspanner = NULL, css.tspanner.sep = NULL, css.total = NULL, css.cell = NULL, css.cgroup = NULL, css.header = NULL, css.header.border_bottom = NULL, css.class = NULL, css.table = NULL, pos.rowlabel = NULL, pos.caption = NULL, col.rgroup = NULL, col.columns = NULL, padding.rgroup = NULL, padding.tspanner = NULL, spacer.celltype = NULL, spacer.css.cgroup.bottom.border = NULL, spacer.css = NULL, spacer.content = NULL ) } \arguments{ \item{theme}{A \code{list} containing all the styles or a \code{string} that is matched to some of the preset style (See details below in the \emph{Theme options} section). \emph{Note}: the full name of the theme is not required as they are matched using \code{\link[base:match.arg]{base::match.arg()}}.} \item{align}{A character strings specifying column alignments, defaulting to \code{'c'} to center. Valid chars for alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{align.header}{A character strings specifying alignment for column header, defaulting to centered, i.e. \verb{[paste][base::paste](rep('c',ncol(x)),collapse='')}.} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.rgroup}{CSS style for the rgroup, if different styles are wanted for each of the rgroups you can just specify a vector with the number of elements.} \item{css.rgroup.sep}{The line between different rgroups. The line is set to the TR element of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with the expected function. This is only used for rgroups that are printed. You can specify different separators if you give a vector of rgroup - 1 length (this is since the first rgroup doesn't have a separator).} \item{css.tspanner}{The CSS style for the table spanner.} \item{css.tspanner.sep}{The line between different spanners.} \item{css.total}{The css of the total row if such is activated.} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} \item{css.header}{The header style, not including the cgroup style} \item{css.header.border_bottom}{The header bottom-border style, e.g. \verb{border-bottom: 1px solid grey}} \item{css.class}{The html CSS class for the table. This allows directing html formatting through \href{https://www.w3schools.com/Css/}{CSS} directly at all instances of that class. \emph{Note:} unfortunately the CSS is frequently ignored by word processors. This option is mostly inteded for web-presentations.} \item{css.table}{You can specify the the style of the table-element using this parameter} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{pos.caption}{Set to \code{"bottom"} to position a caption below the table instead of the default of \code{"top"}.} \item{col.rgroup}{Alternating colors (zebra striping/banded rows) for each \code{rgroup}; one or two colors is recommended and will be recycled.} \item{col.columns}{Alternating colors for each column.} \item{padding.rgroup}{Generally two non-breakings spaces, i.e. \verb{  }, but some journals only have a bold face for the rgroup and leaves the subelements unindented.} \item{padding.tspanner}{The table spanner is usually without padding but you may specify padding similar to \code{padding.rgroup} and it will be added to all elements, including the rgroup elements. This allows for a 3-level hierarchy if needed.} \item{spacer.celltype}{When using cgroup the table headers are separated through a empty HTML cell that is by default filled with \verb{ } (no-breaking-space) that prevents the cell from collapsing. The purpose of this is to prevent the headers underline to bleed into one as the underline is for the entire cell. You can alter this behavior by changing this option, valid options are \code{single_empty}, \code{skip}, \code{double_cell}. The \code{single_empty} is the default, the \code{skip} lets the header bleed into one and skips entirely, \code{double_cell} is for having two cells so that a vertical border ends up centered (specified using the \code{align} option). The arguments are matched internally using \link[base:match.arg]{base::match.arg} so you can specify only a part of the name, e.g. \code{"sk"} will match \code{"skip"}.} \item{spacer.css.cgroup.bottom.border}{Defaults to \code{none} and used for separating cgroup headers. Due to a browser bug this is sometimes ignored and you may therefore need to set this to \verb{1px solid white} to enforce a white border.} \item{spacer.css}{If you want the spacer cells to share settings you can set it here} \item{spacer.content}{Defaults to \verb{ } as this guarantees that the cell is not collapsed and is highly compatible when copy-pasting to word processors.} } \value{ An invisible \code{list} with the new theme } \description{ The theme guides many of the non-data objects visual appearance. The theme can be over-ridden by settings for each table. Too get a more complete understanding of the options, see \code{\link[=addHtmlTableStyle]{addHtmlTableStyle()}}. } \section{Theme options}{ The styles available are: \itemize{ \item \code{standard}: The traditional standard style used in \code{\link[=htmlTable]{htmlTable()}} since the early days \item \verb{Google docs}: A style that is optimized for copy-pasting into documents on Google drive. This is geared towards minimal padding and margins so that the table is as dense as possible. \item \code{blank}: Just as the name suggests the style is completly empty in terms of CSS. Positions for rowlabel and caption are set to \code{bottom} as these cannot be blank. } You can also provide your own style. Each style should be a names vector, e.g. \code{c(width = "100px", color = "red")} or just a real css string, \verb{width: 100px; color: red;}. } \examples{ \dontrun{ setHtmlTableTheme("Google", align = "r") } } htmlTable/man/interactiveTable.Rd0000644000176200001440000000617614517434555016544 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interactiveTable.R \name{interactiveTable} \alias{interactiveTable} \alias{interactiveTable.htmlTable} \alias{knit_print.interactiveTable} \alias{print.interactiveTable} \title{An interactive table that allows you to limit the size of boxes} \usage{ interactiveTable( x, ..., txt.maxlen = 20, button = getOption("htmlTable.interactiveTable.button", default = FALSE), minimized.columns = NULL, js.scripts = c() ) \method{interactiveTable}{htmlTable}( x, ..., txt.maxlen = 20, button = getOption("htmlTable.interactiveTable.button", default = FALSE), minimized.columns = NULL, js.scripts = c() ) \method{knit_print}{interactiveTable}(x, ...) \method{print}{interactiveTable}(x, useViewer, ...) } \arguments{ \item{x}{The table to be printed} \item{...}{The exact same parameters as \code{\link[=htmlTable]{htmlTable()}} uses} \item{txt.maxlen}{The maximum length of a text} \item{button}{Indicator if the cell should be clickable or if a button should appear with a plus/minus} \item{minimized.columns}{Notifies if any particular columns should be collapsed from start} \item{js.scripts}{If you want to add your own JavaScript code you can just add it here. All code is merged into one string where each section is wrapped in it's own \verb{} element.} \item{useViewer}{If you are using RStudio there is a viewer thar can render the table within that is envoced if in \code{\link[base:interactive]{base::interactive()}} mode. Set this to \code{FALSE} if you want to remove that functionality. You can also force the function to call a specific viewer by setting this to a viewer function, e.g. \code{useViewer = utils::browseURL} if you want to override the default RStudio viewer. Another option that does the same is to set the \code{options(viewer=utils::browseURL)} and it will default to that particular viewer (this is how RStudio decides on a viewer). \emph{Note:} If you want to force all output to go through the \code{\link[base:cat]{base::cat()}} the set \verb{[options][base::options](htmlTable.cat = TRUE)}.} } \value{ An htmlTable with a javascript attribute containing the code that is then printed } \description{ This function wraps the htmlTable and adds JavaScript code for toggling the amount of text shown in any particular cell. } \examples{ library(magrittr) # A simple output long_txt <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" short_txt <- gsub("(^[^.]+).*", "\\\\1", long_txt) cbind(rep(short_txt, 2), rep(long_txt, 2)) \%>\% addHtmlTableStyle(col.rgroup = c("#FFF", "#EEF")) \%>\% interactiveTable(minimized.columns = ncol(.), header = c("Short", "Long"), rnames = c("First", "Second")) } htmlTable/man/prMergeClr.Rd0000644000176200001440000000122013701421460015263 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_mergeClr.R \name{prMergeClr} \alias{prMergeClr} \title{Merges multiple colors} \usage{ prMergeClr(clrs) } \arguments{ \item{clrs}{The colors} } \value{ \code{character} A hexadecimal color } \description{ Uses the \code{\link[grDevices:colorRamp]{colorRampPalette()}} for merging colors. \emph{Note:} When merging more than 2 colors the order in the color presentation matters. Each color is merged with its neigbors before merging with next. If there is an uneven number of colors the middle color is mixed with both left and right side. } \keyword{internal} htmlTable/man/prGetCgroupHeader.Rd0000644000176200001440000000506513730316012016604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render_getCgroupHeader.R \name{prGetCgroupHeader} \alias{prGetCgroupHeader} \title{Retrieve a header row} \usage{ prGetCgroupHeader( x, cgroup_vec, n.cgroup_vec, cgroup_vec.just, row_no, top_row_style, rnames, rowlabel = NULL, cgroup_spacer_cells, style_list, prepped_cell_css, css_4_cgroup_vec ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cgroup_vec}{The \code{cgroup} may be a \code{matrix}, this is just one row of that \code{matrix}} \item{n.cgroup_vec}{The same as above but for the counter} \item{cgroup_vec.just}{The same as above bot for the justification} \item{row_no}{The row number within the header group. Useful for multi-row headers when we need to output the \code{rowlabel} at the \code{pos.rowlabel} level.} \item{top_row_style}{The top row has a special style depending on the \code{ctable} option in the \code{htmlTable} call.} \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} \item{rowlabel}{If the table has row names or \code{rnames}, \code{rowlabel} is a character string containing the column heading for the \code{rnames}.} \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. With multiple rows in cgroup we need to keep track of how many spacer cells occur between the columns. This variable contains is of the size \code{ncol(x)-1} and 0 if there is no cgroup element between.} \item{style_list}{The list with all the styles} } \value{ \code{string} } \description{ This function retrieves a header row, i.e. a row within the \verb{} elements on top of the table. Used by \code{\link[=htmlTable]{htmlTable()}}. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prGetThead.Rd0000644000176200001440000000747213701421460015267 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render_getThead.R \name{prGetThead} \alias{prGetThead} \title{Renders the table head (thead)} \usage{ prGetThead( x, header = NULL, cgroup = NULL, n.cgroup = NULL, caption = NULL, compatibility, total_columns, css.cgroup, top_row_style, rnames, rowlabel = NULL, cgroup_spacer_cells, prepped_cell_css, style_list, cell_style ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base:colnames]{colnames(x)}}} \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the \code{n.cgroup} is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{caption}{Adds a table caption.} \item{compatibility}{Is default set to \code{LibreOffice} as some settings need to be in old HTML format as Libre Office can't handle some commands such as the css caption-alignment. Note: this option is not yet fully implemented for all details, in the future I aim to generate a HTML-correct table and one that is aimed at Libre Office compatibility. Word-compatibility is difficult as Word ignores most settings and destroys all layout attempts (at least that is how my 2010 version behaves). You can additinally use the \code{options(htmlTableCompat = "html")} if you want a change to apply to the entire document. MS Excel sometimes misinterprets certain cell data when opening HTML-tables (eg. 1/2 becomes 1. February). To avoid this please specify the correct Microsoft Office format for each cell in the table using the css.cell-argument. To make MS Excel interpret everything as text use "mso-number-format:\"\\@\"".} \item{total_columns}{The total number of columns including the rowlabel and the specer cells} \item{top_row_style}{The top row has a special style depending on the \code{ctable} option in the \code{htmlTable} call.} \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} \item{rowlabel}{If the table has row names or \code{rnames}, \code{rowlabel} is a character string containing the column heading for the \code{rnames}.} \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. With multiple rows in cgroup we need to keep track of how many spacer cells occur between the columns. This variable contains is of the size \code{ncol(x)-1} and 0 if there is no cgroup element between.} \item{style_list}{The list with all the styles} } \value{ \code{string} Returns the html string for the \verb{...} element } \description{ Renders the table head (thead) } \keyword{internal} htmlTable/man/pvalueFormatter.Rd0000644000176200001440000000101313701421460016401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{pvalueFormatter} \alias{pvalueFormatter} \title{Deprecated use \code{\link[=txtPval]{txtPval()}} instead} \usage{ pvalueFormatter(...) } \arguments{ \item{...}{Currently only used for generating warnings of deprecated call} } \description{ Deprecated use \code{\link[=txtPval]{txtPval()}} instead } \examples{ \dontrun{ # Deprecated function pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) } } \keyword{internal} htmlTable/man/prGetRowlabelPos.Rd0000644000176200001440000000260013730316012016455 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_getRowlabelPos.R \name{prGetRowlabelPos} \alias{prGetRowlabelPos} \title{Gets the rowlabel position} \usage{ prGetRowlabelPos(cgroup = NULL, pos.rowlabel, header = NULL) } \arguments{ \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base:colnames]{colnames(x)}}} } \value{ \code{integer} Returns the position within the header rows to print the \code{rowlabel} argument } \description{ Gets the rowlabel position } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prConvertDfFactors.Rd0000644000176200001440000000110413701421460017000 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_convertDfFactors.R \name{prConvertDfFactors} \alias{prConvertDfFactors} \title{Convert all factors to characters to print them as they expected} \usage{ prConvertDfFactors(x) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} } \value{ The data frame with factors as characters } \description{ Convert all factors to characters to print them as they expected } htmlTable/man/htmlTableWidget.Rd0000644000176200001440000000242513572272225016322 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTableWidget.R \name{htmlTableWidget} \alias{htmlTableWidget} \title{htmlTable with pagination widget} \usage{ htmlTableWidget( x, number_of_entries = c(10, 25, 100), width = NULL, height = NULL, elementId = NULL, ... ) } \arguments{ \item{x}{A data frame to be rendered} \item{number_of_entries}{a numeric vector with the number of entries per page to show. If there is more than one number given, the user will be able to show the number of rows per page in the table.} \item{width}{Fixed width for widget (in css units). The default is \code{NULL}, which results in intelligent automatic sizing based on the widget's container.} \item{height}{Fixed height for widget (in css units). The default is \code{NULL}, which results in intelligent automatic sizing based on the widget's container.} \item{elementId}{Use an explicit element ID for the widget (rather than an automatically generated one). Useful if you have other JavaScript that needs to explicitly discover and interact with a specific widget instance.} \item{...}{Additional parameters passed to htmlTable} } \value{ an htmlwidget showing the paginated table } \description{ This widget renders a table with pagination into an htmlwidget } htmlTable/man/prTblNo.Rd0000644000176200001440000000220013730316012014576 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_tblNo.R \name{prTblNo} \alias{prTblNo} \title{Gets the table counter string} \usage{ prTblNo(caption = NULL) } \arguments{ \item{caption}{The caption if any} } \value{ \code{string} Returns a string formatted according to the table_counter_str and table_counter_roman. The number is decided by the table_counter variable } \description{ Returns the string used for htmlTable to number the different tables. Uses options \code{table_counter}, \code{table_counter_str}, and \code{table_counter_roman} to produce the final string. You can set each option by simply calling \code{options()}. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/prPrepareCss.Rd0000644000176200001440000000224413701421460015641 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_prepareCss.R \name{prPrepareCss} \alias{prPrepareCss} \title{Prepares the cell style} \usage{ prPrepareCss( x, css, rnames, header = NULL, name = deparse(substitute(css)), style_list = NULL ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{css}{The CSS styles that are to be converted into a matrix.} \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base:colnames]{colnames(x)}}} \item{name}{The name of the CSS style that is prepared} } \value{ \code{matrix} } \description{ Prepares the cell style } \keyword{internal} htmlTable/man/prBindDataListIntoColumns.Rd0000644000176200001440000000105513701421460020266 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidyHtmlTable_helpers_bindDataListIntoColumns.r \name{prBindDataListIntoColumns} \alias{prBindDataListIntoColumns} \title{Merge columns into a tibble} \usage{ prBindDataListIntoColumns(dataList) } \arguments{ \item{dataList}{\code{list} with the columns/data.frames} } \value{ \code{data.frame} object } \description{ Almost the same as \code{\link[tibble:tibble]{tibble::tibble()}} but it solves the issue with some of the arguments being columns and some just being vectors. } htmlTable/man/tblNoLast.Rd0000644000176200001440000000125513701421460015133 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tblNo.R \name{tblNoLast} \alias{tblNoLast} \title{Gets the last table number} \usage{ tblNoLast(roman = getOption("table_counter_roman", FALSE)) } \arguments{ \item{roman}{Whether or not to use roman numbers instead of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} } \description{ The function relies on \code{options("table_counter")} in order to keep track of the last number. } \examples{ org_opts <- options(table_counter=1) tblNoLast() options(org_opts) } \seealso{ Other table functions: \code{\link{htmlTable}}, \code{\link{tblNoNext}()} } \concept{table functions} htmlTable/man/prGetAlign.Rd0000644000176200001440000000161013730316012015256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_getAlign.R \name{prGetAlign} \alias{prGetAlign} \title{Gets alignment} \usage{ prGetAlign( align, index, style_list = NULL, spacerCell = FALSE, followed_by_spacer_cell = FALSE, previous_was_spacer_cell = FALSE ) } \arguments{ \item{align}{A character strings specifying column alignments, defaulting to \code{'c'} to center. Valid chars for alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{index}{The index of the align parameter of interest} } \description{ Gets alignment } \concept{hidden helper functions for} \keyword{internal} htmlTable/man/prGetRgroupLine.Rd0000644000176200001440000000342313701421460016320 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render_getRgroupLine.R \name{prGetRgroupLine} \alias{prGetRgroupLine} \title{Gets the number of \code{rgroup} HTML line} \usage{ prGetRgroupLine( x, total_columns = NULL, rgroup = NULL, rgroup_iterator = NULL, cspan = NULL, rnames = NULL, style = NULL, cgroup_spacer_cells = NULL, style_list = NULL, prepped_row_css = NULL ) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{total_columns}{The total number of columns including the \code{rowlabel} and the spacer cells} \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{rgroup_iterator}{An integer indicating the \code{rgroup}} \item{cspan}{The column span of the current \code{rgroup}} \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} \item{style}{The css style corresponding to the \code{rgroup} css style that includes the color specific for the \code{rgroup}, i.e. \code{col.rgroup}.} \item{cgroup_spacer_cells}{The vector indicating the position of the \code{cgroup} spacer cells} \item{prepped_row_css}{The \code{css.cell} information for this particular row.} } \description{ Gets the number of \code{rgroup} HTML line } \keyword{internal} htmlTable/man/txtInt.Rd0000644000176200001440000000226114165130172014523 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtInt} \alias{txtInt} \title{SI or English formatting of an integer} \usage{ txtInt( x, language = getOption("htmlTable.language", default = "en"), html = getOption("htmlTable.html", default = TRUE), ... ) } \arguments{ \item{x}{The integer variable} \item{language}{The ISO-639-1 two-letter code for the language of interest. Currently only English is distinguished from the ISO format using a ',' as the separator.} \item{html}{If the format is used in HTML context then the space should be a non-breaking space, \verb{ }} \item{...}{Passed to \code{\link[base:format]{base::format()}}} } \value{ \code{string} } \description{ English uses ',' between every 3 numbers while the SI format recommends a ' ' if x > 10^4. The scientific form 10e+? is furthermore avoided. } \examples{ txtInt(123) # Supplying a matrix txtInt(matrix(c(1234, 12345, 123456, 1234567), ncol = 2)) # Missing are returned as empty strings, i.e. "" txtInt(c(NA, 1e7)) } \seealso{ Other text formatters: \code{\link{txtMergeLines}()}, \code{\link{txtPval}()}, \code{\link{txtRound}()} } \concept{text formatters} htmlTable/man/htmlTableWidget-shiny.Rd0000644000176200001440000000226413701421460017442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTableWidget.R \name{htmlTableWidget-shiny} \alias{htmlTableWidget-shiny} \alias{htmlTableWidgetOutput} \alias{renderHtmlTableWidget} \title{Shiny bindings for htmlTableWidget} \usage{ htmlTableWidgetOutput(outputId, width = "100\%", height = "400px") renderHtmlTableWidget(expr, env = parent.frame(), quoted = FALSE) } \arguments{ \item{outputId}{output variable to read from} \item{width, height}{Must be a valid CSS unit (like \code{'100\%'}, \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a string and have \code{'px'} appended.} \item{expr}{An expression that generates a \code{\link[=htmlTableWidget]{htmlTableWidget()}}} \item{env}{The environment in which to evaluate \code{expr}.} \item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This is useful if you want to save an expression in a variable.} } \description{ Output and render functions for using htmlTableWidget within Shiny applications and interactive Rmd documents. } \examples{ \dontrun{ # In the UI: htmlTableWidgetOutput("mywidget") # In the server: renderHtmlTableWidget({ htmlTableWidget(iris) }) } } htmlTable/man/innerJoinByCommonCols.Rd0000644000176200001440000000074413701421460017453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidyHtmlTable_helpers_innerJoinByCommonCols.r \name{innerJoinByCommonCols} \alias{innerJoinByCommonCols} \title{A simple function for joining two tables by their intersected columns} \usage{ innerJoinByCommonCols(x, y) } \arguments{ \item{x}{\code{data.frame}} \item{y}{\code{data.frame}} } \value{ \code{data.frame} } \description{ A simple function for joining two tables by their intersected columns } htmlTable/man/vector2string.Rd0000644000176200001440000000132013701421460016035 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vector2string.R \name{vector2string} \alias{vector2string} \title{Collapse vector to string} \usage{ vector2string( x, quotation_mark = "'", collapse = sprintf("\%s, \%s", quotation_mark, quotation_mark) ) } \arguments{ \item{x}{The vector to collapse} \item{quotation_mark}{The type of quote to use} \item{collapse}{The string that separates each element} } \value{ A string with \code{', '} separation } \description{ Merges all the values and outputs a string formatted as '1st element', '2nd element', ... } \examples{ vector2string(1:4) vector2string(c("a", "b'b", "c")) vector2string(c("a", "b'b", "c"), quotation_mark = '"') } htmlTable/man/prIsNotebook.Rd0000644000176200001440000000065413701421460015651 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_isNotebook.R \name{prIsNotebook} \alias{prIsNotebook} \title{Detects if the call is made from within an RStudio Rmd file or a file with the html_notebook output set.} \usage{ prIsNotebook() } \description{ Detects if the call is made from within an RStudio Rmd file or a file with the html_notebook output set. } \keyword{internal} htmlTable/man/prEscapeHtml.Rd0000644000176200001440000000177013730316012015620 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_escapeHtml.R \name{prEscapeHtml} \alias{prEscapeHtml} \title{Remove html entities from table} \usage{ prEscapeHtml(x) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} } \value{ \code{x} without the html entities } \description{ Removes the htmlEntities from table input data. Note that this also replaces $ signs in order to remove the MathJax issue. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} htmlTable/man/prPrepareCgroup.Rd0000644000176200001440000000400413730316012016342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_prepareCgroup.R \name{prPrepareCgroup} \alias{prPrepareCgroup} \title{Prepares the cgroup argument} \usage{ prPrepareCgroup(x, cgroup = NULL, n.cgroup = NULL, style_list) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cgroup}{A vector, matrix or list of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector, matrix or list containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the \code{n.cgroup} is one less than the number of columns in the matrix/data.frame then it automatically adds those.} } \value{ \code{list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)} } \description{ Due to the complicated structure of multilevel cgroups there some preparation for the cgroup options is required. } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/txtPval.Rd0000644000176200001440000000340613701421460014673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtPval} \alias{txtPval} \title{Formats the p-values} \usage{ txtPval(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html = TRUE, ...) } \arguments{ \item{pvalues}{The p-values} \item{lim.2dec}{The limit for showing two decimals. E.g. the p-value may be \code{0.056} and we may want to keep the two decimals in order to emphasize the proximity to the all-mighty \code{0.05} p-value and set this to \eqn{10^-2}. This allows that a value of \code{0.0056} is rounded to \code{0.006} and this makes intuitive sense as the \code{0.0056} level as this is well below the \code{0.05} value and thus not as interesting to know the exact proximity to \code{0.05}. \emph{Disclaimer:} The \code{0.05}-limit is really silly and debated, unfortunately it remains a standard and this package tries to adapt to the current standards in order to limit publication associated issues.} \item{lim.sig}{The significance limit for the less than sign, i.e. the '\code{<}'} \item{html}{If the less than sign should be \code{<} or \verb{<} as needed for HTML output.} \item{...}{Currently only used for generating warnings of deprecated call parameters.} } \value{ vector } \description{ Gets formatted p-values. For instance you often want \code{0.1234} to be \code{0.12} while also having two values up until a limit, i.e. \code{0.01234} should be \code{0.012} while \code{0.001234} should be \code{0.001}. Furthermore you want to have \verb{< 0.001} as it becomes ridiculous to report anything below that value. } \examples{ txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) } \seealso{ Other text formatters: \code{\link{txtInt}()}, \code{\link{txtMergeLines}()}, \code{\link{txtRound}()} } \concept{text formatters} htmlTable/man/getHtmlTableStyle.Rd0000644000176200001440000000132213730316012016617 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_style_handlers.R \name{getHtmlTableStyle} \alias{getHtmlTableStyle} \title{Get style options for object} \usage{ getHtmlTableStyle(x) } \arguments{ \item{x}{The object intended for \code{\link[=htmlTable]{htmlTable()}}.} } \value{ A \code{list} if the attribute exists, otherwise \code{NULL} } \description{ A wrap around the \code{\link[base:attr]{base::attr()}} that retrieves the style attribute used by \code{\link[=htmlTable]{htmlTable()}} (\code{htmlTable.style}). } \examples{ library(magrittr) mx <- matrix(1:4, ncol = 2) colnames(mx) <- LETTERS[1:2] mx \%>\% addHtmlTableStyle(align = "l|r") \%>\% getHtmlTableStyle() } htmlTable/man/prExtractElementsAndConvertToTbl.Rd0000644000176200001440000000104713701421460021632 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in % R/tidyHtmlTable_helpers_extractElementsAndConvertToTbl.R \name{prExtractElementsAndConvertToTbl} \alias{prExtractElementsAndConvertToTbl} \title{Extract the elements and generate a table with unique elements} \usage{ prExtractElementsAndConvertToTbl(x, elements) } \arguments{ \item{x}{\code{list} with columns to be joined} \item{elements}{\code{char} vector with the elements to select} } \description{ Extract the elements and generate a table with unique elements } htmlTable/man/prPrepareColors.Rd0000644000176200001440000000111013701421460016341 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_prepareColors.R \name{prPrepareColors} \alias{prPrepareColors} \title{Prepares the alternating colors} \usage{ prPrepareColors(clr, n = NULL, ng = NULL, gtxt) } \arguments{ \item{clr}{The colors} \item{n}{The number of rows/columns applicable to the color} \item{ng}{The n.rgroup/n.cgroup argument if applicable} \item{gtxt}{The rgroup/cgroup texts} } \value{ \code{character} A vector containing hexadecimal colors } \description{ Prepares the alternating colors } \keyword{internal} htmlTable/man/addStyles.Rd0000644000176200001440000002007413730316012015163 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_style_handlers.R \name{addHtmlTableStyle} \alias{addHtmlTableStyle} \alias{appendHtmlTableStyle} \title{Add/set css and other style options} \usage{ addHtmlTableStyle( x, align = NULL, align.header = NULL, align.cgroup = NULL, css.rgroup = NULL, css.rgroup.sep = NULL, css.tspanner = NULL, css.tspanner.sep = NULL, css.total = NULL, css.cell = NULL, css.cgroup = NULL, css.header = NULL, css.header.border_bottom = NULL, css.class = NULL, css.table = NULL, pos.rowlabel = NULL, pos.caption = NULL, col.rgroup = NULL, col.columns = NULL, padding.rgroup = NULL, padding.tspanner = NULL, spacer.celltype = NULL, spacer.css.cgroup.bottom.border = NULL, spacer.css = NULL, spacer.content = NULL ) appendHtmlTableStyle( x, align = NULL, align.header = NULL, align.cgroup = NULL, css.rgroup = NULL, css.rgroup.sep = NULL, css.tspanner = NULL, css.tspanner.sep = NULL, css.total = NULL, css.cell = NULL, css.cgroup = NULL, css.header = NULL, css.header.border_bottom = NULL, css.class = NULL, css.table = NULL, pos.rowlabel = NULL, pos.caption = NULL, col.rgroup = NULL, col.columns = NULL, padding.rgroup = NULL, padding.tspanner = NULL, spacer.celltype = NULL, spacer.css.cgroup.bottom.border = NULL, spacer.css = NULL, spacer.content = NULL ) } \arguments{ \item{x}{The object that you later want to pass into \code{\link[=htmlTable]{htmlTable()}}.} \item{align}{A character strings specifying column alignments, defaulting to \code{'c'} to center. Valid chars for alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{align.header}{A character strings specifying alignment for column header, defaulting to centered, i.e. \verb{[paste][base::paste](rep('c',ncol(x)),collapse='')}.} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.rgroup}{CSS style for the rgroup, if different styles are wanted for each of the rgroups you can just specify a vector with the number of elements.} \item{css.rgroup.sep}{The line between different rgroups. The line is set to the TR element of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with the expected function. This is only used for rgroups that are printed. You can specify different separators if you give a vector of rgroup - 1 length (this is since the first rgroup doesn't have a separator).} \item{css.tspanner}{The CSS style for the table spanner.} \item{css.tspanner.sep}{The line between different spanners.} \item{css.total}{The css of the total row if such is activated.} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} \item{css.header}{The header style, not including the cgroup style} \item{css.header.border_bottom}{The header bottom-border style, e.g. \verb{border-bottom: 1px solid grey}} \item{css.class}{The html CSS class for the table. This allows directing html formatting through \href{https://www.w3schools.com/Css/}{CSS} directly at all instances of that class. \emph{Note:} unfortunately the CSS is frequently ignored by word processors. This option is mostly inteded for web-presentations.} \item{css.table}{You can specify the the style of the table-element using this parameter} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{pos.caption}{Set to \code{"bottom"} to position a caption below the table instead of the default of \code{"top"}.} \item{col.rgroup}{Alternating colors (zebra striping/banded rows) for each \code{rgroup}; one or two colors is recommended and will be recycled.} \item{col.columns}{Alternating colors for each column.} \item{padding.rgroup}{Generally two non-breakings spaces, i.e. \verb{  }, but some journals only have a bold face for the rgroup and leaves the subelements unindented.} \item{padding.tspanner}{The table spanner is usually without padding but you may specify padding similar to \code{padding.rgroup} and it will be added to all elements, including the rgroup elements. This allows for a 3-level hierarchy if needed.} \item{spacer.celltype}{When using cgroup the table headers are separated through a empty HTML cell that is by default filled with \verb{ } (no-breaking-space) that prevents the cell from collapsing. The purpose of this is to prevent the headers underline to bleed into one as the underline is for the entire cell. You can alter this behavior by changing this option, valid options are \code{single_empty}, \code{skip}, \code{double_cell}. The \code{single_empty} is the default, the \code{skip} lets the header bleed into one and skips entirely, \code{double_cell} is for having two cells so that a vertical border ends up centered (specified using the \code{align} option). The arguments are matched internally using \link[base:match.arg]{base::match.arg} so you can specify only a part of the name, e.g. \code{"sk"} will match \code{"skip"}.} \item{spacer.css.cgroup.bottom.border}{Defaults to \code{none} and used for separating cgroup headers. Due to a browser bug this is sometimes ignored and you may therefore need to set this to \verb{1px solid white} to enforce a white border.} \item{spacer.css}{If you want the spacer cells to share settings you can set it here} \item{spacer.content}{Defaults to \verb{ } as this guarantees that the cell is not collapsed and is highly compatible when copy-pasting to word processors.} } \value{ \code{x} with the style added as an attribute that the htmlTable then can use for formatting. } \description{ This function is a preprocessing step before applying the \code{\link[=htmlTable]{htmlTable()}} function. You use this to style your tables with HTML cascading style sheet features. } \details{ The function stores the current theme (see \code{\link[=setHtmlTableTheme]{setHtmlTableTheme()}}) + custom styles to the provided object as an \code{\link[base:attributes]{base::attributes()}}. It is stored under the element \code{htmlTable.style} in the form of a list object. } \section{The \code{css.cell} argument}{ The \code{css.cell} parameter allows you to add any possible CSS style to your table cells. \code{css.cell} can be either a vector or a matrix. If \code{css.cell} is a \emph{vector}, it's assumed that the styles should be repeated throughout the rows (that is, each element in css.cell specifies the style for a whole column of 'x'). In the case of \code{css.cell} being a \emph{matrix} of the same size of the \code{x} argument, each element of \code{x} gets the style from the corresponding element in css.cell. Additionally, the number of rows of \code{css.cell} can be \code{nrow(x) + 1} so the first row of of \code{css.cell} specifies the style for the header of \code{x}; also the number of columns of \code{css.cell} can be \code{ncol(x) + 1} to include the specification of style for row names of \code{x}. Note that the \code{text-align} CSS field in the \code{css.cell} argument will be overriden by the \code{align} argument. Excel has a specific css-style, \code{mso-number-format} that can be used for improving the copy-paste functionality. E.g. the style could be written as: \verb{css_matrix <- matrix( data = "mso-number-format:\\"\\\\@\\"", nrow = nrow(df), ncol = ncol(df))} } \examples{ library(magrittr) matrix(1:4, ncol = 2) \%>\% addHtmlTableStyle(align = "c", css.cell = "background-color: orange;") \%>\% htmlTable(caption = "A simple style example") } \seealso{ Other htmlTableStyle: \code{\link{hasHtmlTableStyle}()} } \concept{htmlTableStyle} htmlTable/man/prAddSemicolon2StrEnd.Rd0000644000176200001440000000167213730316012017337 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_addSemicolon2StrEnd.R \name{prAddSemicolon2StrEnd} \alias{prAddSemicolon2StrEnd} \title{Add a ; at the end} \usage{ prAddSemicolon2StrEnd(my_str) } \arguments{ \item{my_str}{The string that is to be processed} } \value{ \code{string} } \description{ The CSS expects a semicolon at the end of each argument this function just adds a semicolong if none is given and remove multiple semicolon if such exist } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddCells}()}, \code{\link{prAddEmptySpacerCell}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/man/txtMergeLines.Rd0000644000176200001440000000233714165130172016027 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtMergeLines} \alias{txtMergeLines} \title{A merges lines while preserving the line break for HTML/LaTeX} \usage{ txtMergeLines(..., html = 5) } \arguments{ \item{...}{The lines that you want to be joined} \item{html}{If HTML compatible output should be used. If \code{FALSE} it outputs LaTeX formatting. Note if you set this to 5 then the HTML5 version of \emph{br} will be used: \verb{
} otherwise it uses the \verb{
} that is compatible with the XHTML-formatting.} } \value{ \code{string} with \code{asis_output} wrapping if html output is activated } \description{ This function helps you to do a table header with multiple lines in both HTML and in LaTeX. In HTML this isn't that tricky, you just use the \verb{
} command but in LaTeX I often find myself writing \code{vbox}/\code{hbox} stuff and therefore I've created this simple helper function } \examples{ txtMergeLines("hello", "world") txtMergeLines("hello", "world", html=FALSE) txtMergeLines("hello", "world", list("A list", "is OK")) } \seealso{ Other text formatters: \code{\link{txtInt}()}, \code{\link{txtPval}()}, \code{\link{txtRound}()} } \concept{text formatters} htmlTable/man/prepGroupCounts.Rd0000644000176200001440000000103013701421460016377 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/prepGroupCounts.R \name{prepGroupCounts} \alias{prepGroupCounts} \title{Retrieves counts for rgroup, cgroup, & tspanner arguments} \usage{ prepGroupCounts(x) } \arguments{ \item{x}{The vector to process} } \value{ \code{list(n = rle$lengths, names = rle$values)} } \description{ This function is a wrapper to \code{\link[base:rle]{base::rle()}} that does exactly this but is a little too picky about input values. } \examples{ prepGroupCounts(c(1:3, 3:1)) } htmlTable/man/prAttr4RgroupAdd.Rd0000644000176200001440000000127513701421460016403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_attr4RgroupAdd.R \name{prAttr4RgroupAdd} \alias{prAttr4RgroupAdd} \title{Get the add attribute element} \usage{ prAttr4RgroupAdd(rgroup, rgroup_iterator, no_cols) } \arguments{ \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{rgroup_iterator}{The rgroup number of interest} \item{no_cols}{The \code{ncol(x)} of the core htmlTable x argument} } \description{ Gets the add element attribute if it exists. If non-existant it will return NULL. } \keyword{internal} htmlTable/man/SCB.Rd0000644000176200001440000000274414517434555013663 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-SCB.R \docType{data} \name{SCB} \alias{SCB} \title{Average age in Sweden} \description{ For the vignettes there is a dataset downloaded by using the \code{get_pxweb_data()} call. The data is from SCB (\href{https://www.scb.se//}{Statistics Sweden}) and downloaded using the \href{https://github.com/rOpenGov/pxweb}{pxweb package}: } \examples{ \dontrun{ # The data was generated through downloading via the API library(pxweb) # Get the last 15 years of data (the data always lags 1 year) current_year <- as.integer(format(Sys.Date(), "\%Y")) -1 SCB <- get_pxweb_data( url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", dims = list(Region = c('00', '01', '03', '25'), Kon = c('1', '2'), ContentsCode = c('BE0101G9'), Tid = (current_year-14):current_year), clean = TRUE) # Some cleaning was needed before use SCB$region <- factor(substring(as.character(SCB$region), 4)) Swe_ltrs <- c("å" = "å", "Å" = "Å", "ä" = "ä", "Ä" = "Ä", "ö" = "ö", "Ö" = "Ö") for (i in 1:length(Swe_ltrs)){ levels(SCB$region) <- gsub(names(Swe_ltrs)[i], Swe_ltrs[i], levels(SCB$region)) } save(SCB, file = "data/SCB.rda") } } \references{ \url{https://www.scb.se/} } \author{ Max Gordon \email{max@gforge.se} } \keyword{data} htmlTable/man/concatHtmlTables.Rd0000644000176200001440000000437214165130172016465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/concatHtmlTables.R \name{concatHtmlTables} \alias{concatHtmlTables} \title{Function for concatenating \code{\link[=htmlTable]{htmlTable()}}s} \usage{ concatHtmlTables(tables, headers = NULL) } \arguments{ \item{tables}{A list of \code{\link[=htmlTable]{htmlTable()}}s to be concatenated} \item{headers}{Either a string or a vector of strings that function as a header for each table. If none is provided it will use the names of the table list or a numeric number.} } \value{ \code{\link[=htmlTable]{htmlTable()}} class object } \description{ Function for concatenating \code{\link[=htmlTable]{htmlTable()}}s } \examples{ library(magrittr) # Basic example tables <- list() output <- matrix(1:4, ncol = 2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) tables[["Simple table"]] <- htmlTable(output) # An advanced output output <- matrix(ncol = 6, nrow = 8) for (nr in 1:nrow(output)) { for (nc in 1:ncol(output)) { output[nr, nc] <- paste0(nr, ":", nc) } } tables[["Fancy table"]] <- output \%>\% addHtmlTableStyle(align = "r", col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") \%>\% htmlTable(header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption = "Basic table with both column spanners (groups) and row groups", tfoot = "† A table footer commment", cspan.rgroup = 2) concatHtmlTables(tables) } htmlTable/man/prSkipRownames.Rd0000644000176200001440000000133613701421460016215 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers_skipRownames.R \name{prSkipRownames} \alias{prSkipRownames} \title{Returns if rownames should be printed for the htmlTable} \usage{ prSkipRownames(rnames) } \arguments{ \item{rnames}{Default row names are generated from \code{\link[base:colnames]{rownames(x)}}. If you provide \code{FALSE} then it will skip the row names. \emph{Note:} For \code{data.frames} if you do \code{\link[base:colnames]{rownames(my_dataframe) <- NULL}} it still has row names. Thus you need to use \code{FALSE} if you want to supress row names for \code{data.frames}.} } \description{ Returns if rownames should be printed for the htmlTable } \keyword{internal} htmlTable/man/getHtmlTableTheme.Rd0000644000176200001440000000075413701421460016573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_theme.R \name{getHtmlTableTheme} \alias{getHtmlTableTheme} \title{Retrieve the \code{\link[=htmlTable]{htmlTable()}} theme list} \usage{ getHtmlTableTheme() } \value{ \code{list} with the styles to be applied to the table } \description{ A wrapper for a \code{\link[base:options]{getOption("htmlTable.theme")()}} call that returns the standard theme unless one is set. } \examples{ getHtmlTableTheme() } htmlTable/man/outputInt.Rd0000644000176200001440000000067013701421460015244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{outputInt} \alias{outputInt} \title{Deprecated use \code{\link[=txtInt]{txtInt()}} instead.} \usage{ outputInt(...) } \arguments{ \item{...}{Passed to \code{\link[=txtInt]{txtInt()}}} } \description{ Deprecated use \code{\link[=txtInt]{txtInt()}} instead. } \examples{ \dontrun{ # Deprecated function outputInt(123456) } } \keyword{internal} htmlTable/man/txtRound.Rd0000644000176200001440000000725514165130172015070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt_round.R, R/txtFrmt_round_data.frame.R \name{txtRound} \alias{txtRound} \alias{txtRound.default} \alias{txtRound.table} \alias{txtRound.matrix} \alias{txtRound.data.frame} \title{A convenient rounding function} \usage{ txtRound(x, ...) \method{txtRound}{default}( x, digits = 0, digits.nonzero = NA, txt.NA = "", dec = getOption("htmlTable.decimal_marker", default = "."), scientific = NULL, txtInt_args = getOption("htmlTable.round_int", default = NULL), ... ) \method{txtRound}{table}(x, ...) \method{txtRound}{matrix}(x, digits = 0, excl.cols = NULL, excl.rows = NULL, ...) \method{txtRound}{data.frame}(x, ..., digits = 0L) } \arguments{ \item{x}{The value/vector/data.frame/matrix to be rounded} \item{...}{Passed to next method} \item{digits}{The number of digits to round each element to. For \code{matrix} or \code{data.frame} input you can provide a \code{vector}/\code{list}. An unnamed \code{vector}/\code{list} must equal the length of the columns to round. If you provide a named vector you can provide specify per column the number of digits, and then use \code{.default} for those columns that we don't need to have separate values for.} \item{digits.nonzero}{The number of digits to keep if the result is close to zero. Sometimes we have an entire table with large numbers only to have a few but interesting observation that are really interesting} \item{txt.NA}{The string to exchange \code{NA} with} \item{dec}{The decimal marker. If the text is in non-English decimal and string formatted you need to change this to the appropriate decimal indicator. The option for this is \code{htmlTable.decimal_marker}.} \item{scientific}{If the value should be in scientific format.} \item{txtInt_args}{A list of arguments to pass to \code{\link[=txtInt]{txtInt()}} if that is to be used for large values that may require a thousands separator. The option for this is \code{htmlTable.round_int}. If \code{TRUE} it will activate the \code{txtInt} functionality.} \item{excl.cols}{Columns to exclude from the rounding procedure when provided a matrix. This can be either a number or regular expression. Skipped if \code{x} is a vector.} \item{excl.rows}{Rows to exclude from the rounding procedure when provided a matrix. This can be either a number or regular expression.} } \value{ \code{matrix/data.frame} } \description{ Regular round often looses trailing 0:s as these are truncated, this function converts everything to strings with all 0:s intact so that tables have the correct representation, e.g. \code{txtRound(1.01, digits = 1)} turns into \code{1.0}. } \section{Tidy-select with \code{data.frame}}{ The \code{txtRound} can use \code{data.frame} for input. This allows us to use \href{https://tidyselect.r-lib.org/articles/tidyselect.html}{tidyselect} patterns as popularized by \strong{dplyr}. } \examples{ # Basic usage txtRound(1.023, digits = 1) # > "1.0" txtRound(pi, digits = 2) # > "3.14" txtRound(12344, digits = 1, txtInt_args = TRUE) # > "12,344.0" # Using matrix mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) txtRound(mx, digits = 1) #> [,1] [,2] [,3] #> [1,] "1.0" "1.1" "1.2" #> [2,] "2.5" "2.5" "2.5" #> [3,] "3.2" "3.0" "3.1" # Using a data.frame directly library(magrittr) data("mtcars") # If we want to round all the numerical values mtcars \%>\% txtRound(digits = 1) # If we want only want to round some columns mtcars \%>\% txtRound(wt, qsec_txt = qsec, digits = 1) } \seealso{ Other text formatters: \code{\link{txtInt}()}, \code{\link{txtMergeLines}()}, \code{\link{txtPval}()} } \concept{text formatters} htmlTable/man/prAddCells.Rd0000644000176200001440000000303613730316012015243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render_addCells.R \name{prAddCells} \alias{prAddCells} \title{Add a cell} \usage{ prAddCells( rowcells, cellcode, style_list, style, prepped_cell_css, cgroup_spacer_cells, has_rn_col, offset = 1, style_list_align_key = "align" ) } \arguments{ \item{rowcells}{The cells with the values that are to be added} \item{cellcode}{Type of cell, can either be \code{th} or \code{td}} \item{style_list}{The style_list} \item{style}{The cell style} \item{cgroup_spacer_cells}{The number of cells that occur between columns due to the cgroup arguments.} \item{has_rn_col}{Due to the alignment issue we need to keep track of if there has already been printed a rowname column or not and therefore we have this has_rn_col that is either 0 or 1.} \item{offset}{For rgroup rows there may be an offset != 1} } \value{ \code{string} Returns the string with the new cell elements } \description{ Adds a row of cells \verb{val...} to a table string for \code{\link[=htmlTable]{htmlTable()}} } \seealso{ Other hidden helper functions for htmlTable: \code{\link{prAddEmptySpacerCell}()}, \code{\link{prAddSemicolon2StrEnd}()}, \code{\link{prEscapeHtml}()}, \code{\link{prGetCgroupHeader}()}, \code{\link{prGetRowlabelPos}()}, \code{\link{prGetStyle}()}, \code{\link{prPrepInputMatrixDimensions}()}, \code{\link{prPrepareAlign}()}, \code{\link{prPrepareCgroup}()}, \code{\link{prTblNo}()} } \concept{hidden helper functions for htmlTable} \keyword{internal} htmlTable/DESCRIPTION0000644000176200001440000000254514647053220013705 0ustar liggesusersPackage: htmlTable Version: 2.4.3 Title: Advanced Tables for Markdown/HTML Authors@R: c( person("Max", "Gordon", email = "max@gforge.se", role = c("aut", "cre")), person("Stephen", "Gragg", role=c("aut")), person("Peter", "Konings", role=c("aut"))) Maintainer: Max Gordon Description: Tables with state-of-the-art layout elements such as row spanners, column spanners, table spanners, zebra striping, and more. While allowing advanced layout, the underlying css-structure is simple in order to maximize compatibility with common word processors. The package also contains a few text formatting functions that help outputting text compatible with HTML/LaTeX. License: GPL (>= 3) URL: https://gforge.se/packages/ BugReports: https://github.com/gforge/htmlTable/issues Biarch: yes Depends: R (>= 4.1) Imports: stringr, knitr (>= 1.6), magrittr (>= 1.5), methods, checkmate, htmlwidgets, htmltools, rstudioapi (>= 0.6) Suggests: testthat, XML, xml2, Hmisc, rmarkdown, chron, lubridate, tibble, purrr, tidyselect, glue, rlang, tidyr (>= 0.7.2), dplyr (>= 0.7.4) Encoding: UTF-8 NeedsCompilation: no VignetteBuilder: knitr RoxygenNote: 7.2.2 Packaged: 2024-07-20 06:52:16 UTC; max Author: Max Gordon [aut, cre], Stephen Gragg [aut], Peter Konings [aut] Repository: CRAN Date/Publication: 2024-07-21 00:30:08 UTC