From a148378fcefeaa90b4011d1519570b6a416f6a33 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 7 Nov 2023 18:32:22 -0500 Subject: [PATCH 1/9] Clean up html output formatting --- R/as_html.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index fccb5ee67..c604e7d26 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -152,12 +152,14 @@ as_html <- function(x, ) }) + hsep_line <- tags$hr(class = "solid") + hdrtag <- div_helper( class = "rtables-titles-block", list( div_helper( class = "rtables-main-titles-block", - lapply(main_title(x), tags$p, + lapply(main_title(x), tags$b, class = "rtables-main-title" ) ), @@ -179,7 +181,7 @@ as_html <- function(x, class = class_table, tags$caption(sprintf("(\\#tag:%s)", link_label), style = "caption-side:top;", - .noWS = "after-begin", hdrtag + .noWS = "after-begin" ) ) ) @@ -210,10 +212,13 @@ as_html <- function(x, ## we want them to be there but empty?? ftrlst <- list( if (length(mat$ref_footnotes) > 0) rfnotes, + if (length(mat$ref_footnotes) > 0) hsep_line, if (length(main_footer(x)) > 0) mftr, + if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), if (length(prov_footer(x)) > 0) pftr ) + if (length(ftrlst) > 0) ftrlst <- c(list(hsep_line), ftrlst) ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)] ftrtag <- div_helper( @@ -223,7 +228,8 @@ as_html <- function(x, div_helper( class = "rtables-all-parts-block", - list( # hdrtag, + list( + hdrtag, tabletag, ftrtag ) From 87e57cd3f25853060b33a4e3413a50c7ef38e131 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 7 Nov 2023 20:04:09 -0500 Subject: [PATCH 2/9] Update tests --- tests/testthat/test-exporters.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index 8640407eb..992b80f99 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -255,7 +255,7 @@ test_that("as_html does not trim whitespace", { rrow("r3 ", indent = 2) ) html_tbl <- as_html(tbl) - html_parts <- html_tbl$children[[1]][[1]]$children + html_parts <- html_tbl$children[[1]][[2]]$children expect_true(all(sapply(1:4, function(x) html_parts[[x]]$attribs$style == "white-space:pre;"))) }) From 584cb01c3b1e90388fc3afba8f2a90ea19e5eea3 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Wed, 8 Nov 2023 12:01:49 -0500 Subject: [PATCH 3/9] Add option to bold main title in html format --- R/as_html.R | 6 ++++-- man/as_html.Rd | 5 ++++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index c604e7d26..deecfabd1 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -30,6 +30,7 @@ div_helper <- function(lst, class) { #' @param class_th class for `th` tag #' @param width width #' @param link_label link anchor label (not including \code{tab:} prefix) for the table. +#' @param bold_main_title whether the main title should be in bold. Defaults to `FALSE`. #' #' @return A \code{shiny.tag} object representing \code{x} in HTML. #' @@ -61,7 +62,8 @@ as_html <- function(x, class_tr = NULL, class_td = NULL, class_th = NULL, - link_label = NULL) { + link_label = NULL, + bold_main_title = FALSE) { if (is.null(x)) { return(tags$p("Empty Table")) } @@ -159,7 +161,7 @@ as_html <- function(x, list( div_helper( class = "rtables-main-titles-block", - lapply(main_title(x), tags$b, + lapply(main_title(x), if (bold_main_title) tags$b else tags$p, class = "rtables-main-title" ) ), diff --git a/man/as_html.Rd b/man/as_html.Rd index 2168cc114..f92c68ea4 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -11,7 +11,8 @@ as_html( class_tr = NULL, class_td = NULL, class_th = NULL, - link_label = NULL + link_label = NULL, + bold_main_title = FALSE ) } \arguments{ @@ -28,6 +29,8 @@ as_html( \item{class_th}{class for \code{th} tag} \item{link_label}{link anchor label (not including \code{tab:} prefix) for the table.} + +\item{bold_main_title}{whether the main title should be in bold. Defaults to \code{FALSE}.} } \value{ A \code{shiny.tag} object representing \code{x} in HTML. From 7c6ac41bcdc7519da44e1306a4d86367a1b0334a Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 9 Nov 2023 14:40:49 -0500 Subject: [PATCH 4/9] Clean up documentation for Viewer, remove unused arguments --- R/Viewer.R | 14 +++++--------- man/Viewer.Rd | 11 ++++------- 2 files changed, 9 insertions(+), 16 deletions(-) diff --git a/R/Viewer.R b/R/Viewer.R index 317f6b04e..d57d9ecf5 100644 --- a/R/Viewer.R +++ b/R/Viewer.R @@ -1,17 +1,13 @@ #' @importFrom utils browseURL NULL -#' Display an \code{\link{rtable}} object in the Viewer pane in `RStudio` or in a -#' browser +#' Display an [`rtable`] object in the Viewer pane in RStudio or in a browser #' #' The table will be displayed using the bootstrap styling for tables. #' -#' @param x object of class \code{rtable} or \code{shiny.tag} (defined in \code{htmltools}) -#' @param y optional second argument of same type as \code{x} -#' @param row.names.bold row.names.bold boolean, make `row.names` bold -#' @param ... arguments passed to \code{as_html} -#' -#' +#' @param x object of class `rtable` or `shiny.tag` (defined in [htmltools]) +#' @param y optional second argument of same type as `x` +#' @param ... arguments passed to [`as_html`] #' #' @return not meaningful. Called for the side effect of opening a browser or viewer pane. #' @@ -43,7 +39,7 @@ NULL #' Viewer(tbl, tbl2) #' } #' @export -Viewer <- function(x, y = NULL, row.names.bold = FALSE, ...) { +Viewer <- function(x, y = NULL, ...) { check_convert <- function(x, name, accept_NULL = FALSE) { if (accept_NULL && is.null(x)) { NULL diff --git a/man/Viewer.Rd b/man/Viewer.Rd index 3c123d278..74cff9ee3 100644 --- a/man/Viewer.Rd +++ b/man/Viewer.Rd @@ -2,19 +2,16 @@ % Please edit documentation in R/Viewer.R \name{Viewer} \alias{Viewer} -\title{Display an \code{\link{rtable}} object in the Viewer pane in \code{RStudio} or in a -browser} +\title{Display an \code{\link{rtable}} object in the Viewer pane in RStudio or in a browser} \usage{ -Viewer(x, y = NULL, row.names.bold = FALSE, ...) +Viewer(x, y = NULL, ...) } \arguments{ -\item{x}{object of class \code{rtable} or \code{shiny.tag} (defined in \code{htmltools})} +\item{x}{object of class \code{rtable} or \code{shiny.tag} (defined in \link{htmltools})} \item{y}{optional second argument of same type as \code{x}} -\item{row.names.bold}{row.names.bold boolean, make \code{row.names} bold} - -\item{...}{arguments passed to \code{as_html}} +\item{...}{arguments passed to \code{\link{as_html}}} } \value{ not meaningful. Called for the side effect of opening a browser or viewer pane. From f454dcbfe67bd39dfc24423c541d13cc28834a77 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 9 Nov 2023 15:00:33 -0500 Subject: [PATCH 5/9] Add `bold` argument to `as_html`, remove unused `class_td` --- R/as_html.R | 55 +++++++++++++++++++++++++++++++++++++------------- man/as_html.Rd | 13 ++++++------ 2 files changed, 47 insertions(+), 21 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index deecfabd1..228bfa275 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -26,13 +26,14 @@ div_helper <- function(lst, class) { #' @param x `rtable` object #' @param class_table class for `table` tag #' @param class_tr class for `tr` tag -#' @param class_td class for `td` tag #' @param class_th class for `th` tag #' @param width width -#' @param link_label link anchor label (not including \code{tab:} prefix) for the table. -#' @param bold_main_title whether the main title should be in bold. Defaults to `FALSE`. +#' @param link_label link anchor label (not including `tab:` prefix) for the table. +#' @param bold elements in table output that should be bold. Options are `"main_title"`, `"subtitles"`, +#' `"header"`, `"row_labels"`, `"label_rows"`, and `"content_rows"` (which includes any non-label rows). +#' Defaults to `"header"`. #' -#' @return A \code{shiny.tag} object representing \code{x} in HTML. +#' @return A `shiny.tag` object representing `x` in HTML. #' #' @examples #' @@ -48,7 +49,7 @@ div_helper <- function(lst, class) { #' #' as_html(tbl, class_table = "table", class_tr = "row") #' -#' as_html(tbl, class_td = "aaa") +#' as_html(tbl) #' #' \dontrun{ #' Viewer(tbl) @@ -60,10 +61,9 @@ as_html <- function(x, width = NULL, class_table = "table table-condensed table-hover", class_tr = NULL, - class_td = NULL, class_th = NULL, link_label = NULL, - bold_main_title = FALSE) { + bold = c("header")) { if (is.null(x)) { return(tags$p("Empty Table")) } @@ -94,6 +94,7 @@ as_html <- function(x, cells[i, j][[1]] <- tagfun( class = if (inhdr) class_th else class_tr, class = if (j > 1 || i > nrh) paste0("text-", algn), + style = if (inhdr && !"header" %in% bold) "font-weight: normal;", colspan = if (curspn != 1) curspn, insert_brs(curstrs) ) @@ -110,15 +111,41 @@ as_html <- function(x, SIMPLIFY = FALSE ) - # indent row names + # row labels style for (i in seq_len(nrow(x))) { indent <- mat$row_info$indent[i] - if (indent > 0) { + if (indent > 0) { # indentation cells[i + nrh, 1][[1]] <- htmltools::tagAppendAttributes(cells[i + nrh, 1][[1]], - style = paste0("padding-left: ", indent * 3, "ch") + style = paste0("padding-left: ", indent * 3, "ch;") + ) + } + if ("row_labels" %in% bold) { # font weight + cells[i + nrh, 1][[1]] <- htmltools::tagAppendAttributes( + cells[i + nrh, 1][[1]], + style = paste0("font-weight: bold;") ) } } + + # label rows style + if ("label_rows" %in% bold) { + which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") + cells[which_lbl_rows + nrh, ] <- lapply( + cells[which_lbl_rows + nrh, ], + htmltools::tagAppendAttributes, + style = "font-weight: bold;" + ) + } + + # content rows style + if ("content_rows" %in% bold) { + which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow")) + cells[which_cntnt_rows + nrh, ] <- lapply( + cells[which_cntnt_rows + nrh, ], + htmltools::tagAppendAttributes, + style = "font-weight: bold;" + ) + } if (any(!mat$display)) { # Check that expansion kept the same display info @@ -161,13 +188,13 @@ as_html <- function(x, list( div_helper( class = "rtables-main-titles-block", - lapply(main_title(x), if (bold_main_title) tags$b else tags$p, + lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p, class = "rtables-main-title" ) ), div_helper( class = "rtables-subtitles-block", - lapply(subtitles(x), tags$p, + lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p, class = "rtables-subtitle" ) ) @@ -216,11 +243,11 @@ as_html <- function(x, if (length(mat$ref_footnotes) > 0) rfnotes, if (length(mat$ref_footnotes) > 0) hsep_line, if (length(main_footer(x)) > 0) mftr, - if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), + if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break if (length(prov_footer(x)) > 0) pftr ) - if (length(ftrlst) > 0) ftrlst <- c(list(hsep_line), ftrlst) + if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst) ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)] ftrtag <- div_helper( diff --git a/man/as_html.Rd b/man/as_html.Rd index f92c68ea4..0cc9fe95e 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -9,10 +9,9 @@ as_html( width = NULL, class_table = "table table-condensed table-hover", class_tr = NULL, - class_td = NULL, class_th = NULL, link_label = NULL, - bold_main_title = FALSE + bold = c("header") ) } \arguments{ @@ -24,13 +23,13 @@ as_html( \item{class_tr}{class for \code{tr} tag} -\item{class_td}{class for \code{td} tag} - \item{class_th}{class for \code{th} tag} -\item{link_label}{link anchor label (not including \code{tab:} prefix) for the table.} +\item{link_label}{link anchor label (not including \verb{tab:} prefix) for the table.} -\item{bold_main_title}{whether the main title should be in bold. Defaults to \code{FALSE}.} +\item{bold}{elements in table output that should be bold. Options are \code{"main_title"}, \code{"subtitles"}, +\code{"header"}, \code{"row_labels"}, \code{"label_rows"}, and \code{"content_rows"} (which includes any non-label rows). +Defaults to \code{"header"}.} } \value{ A \code{shiny.tag} object representing \code{x} in HTML. @@ -52,7 +51,7 @@ as_html(tbl) as_html(tbl, class_table = "table", class_tr = "row") -as_html(tbl, class_td = "aaa") +as_html(tbl) \dontrun{ Viewer(tbl) From c3f596ca486858616b5eb6f190015634c72b5b31 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 9 Nov 2023 15:02:20 -0500 Subject: [PATCH 6/9] Update NEWS --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 94b4e20fb..900e59a62 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,7 @@ ## rtables 0.6.5.9011 ### New Features * Removed `ref_group` reordering in column splits so not to change the order. + * Added `bold` argument to `as_html` to bold specified elements in rendered HTML output. ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. From 0f6cb751f8a5c9c82e95fe62bf18ac3c617a5ae0 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 9 Nov 2023 16:06:57 -0500 Subject: [PATCH 7/9] Add `header_sep_line` parameter to `as_html` --- NEWS.md | 3 ++- R/as_html.R | 18 ++++++++++++++---- man/as_html.Rd | 7 +++++-- 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index 900e59a62..b43c8f030 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,8 @@ ## rtables 0.6.5.9011 ### New Features * Removed `ref_group` reordering in column splits so not to change the order. - * Added `bold` argument to `as_html` to bold specified elements in rendered HTML output. + * Added `bold` argument to `as_html` to bold specified elements, and `header_sep_line` argument to print a horizontal line under the table header in rendered HTML output. + ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. diff --git a/R/as_html.R b/R/as_html.R index 228bfa275..e1a3b9b51 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -32,6 +32,7 @@ div_helper <- function(lst, class) { #' @param bold elements in table output that should be bold. Options are `"main_title"`, `"subtitles"`, #' `"header"`, `"row_labels"`, `"label_rows"`, and `"content_rows"` (which includes any non-label rows). #' Defaults to `"header"`. +#' @param header_sep_line whether a black line should be printed to under the table header. Defaults to `TRUE`. #' #' @return A `shiny.tag` object representing `x` in HTML. #' @@ -49,7 +50,7 @@ div_helper <- function(lst, class) { #' #' as_html(tbl, class_table = "table", class_tr = "row") #' -#' as_html(tbl) +#' as_html(tbl, bold = c("header", "row_labels")) #' #' \dontrun{ #' Viewer(tbl) @@ -63,7 +64,8 @@ as_html <- function(x, class_tr = NULL, class_th = NULL, link_label = NULL, - bold = c("header")) { + bold = c("header"), + header_sep_line = TRUE) { if (is.null(x)) { return(tags$p("Empty Table")) } @@ -95,6 +97,7 @@ as_html <- function(x, class = if (inhdr) class_th else class_tr, class = if (j > 1 || i > nrh) paste0("text-", algn), style = if (inhdr && !"header" %in% bold) "font-weight: normal;", + style = if (i == nrh && header_sep_line) "border-bottom: 1px solid black;", colspan = if (curspn != 1) curspn, insert_brs(curstrs) ) @@ -110,6 +113,13 @@ as_html <- function(x, algn = mat$aligns[1:nrh, 1], SIMPLIFY = FALSE ) + + if (header_sep_line) { + cells[nrh][[1]] <- htmltools::tagAppendAttributes( + cells[nrh, 1][[1]], + style = "border-bottom: 1px solid black;" + ) + } # row labels style for (i in seq_len(nrow(x))) { @@ -176,7 +186,7 @@ as_html <- function(x, rows <- apply(cells, 1, function(row) { tags$tr( class = class_tr, - style = "white-space:pre;", + style = "white-space: pre;", Filter(function(x) !identical(x, NA_integer_), row) ) }) @@ -209,7 +219,7 @@ as_html <- function(x, list( class = class_table, tags$caption(sprintf("(\\#tag:%s)", link_label), - style = "caption-side:top;", + style = "caption-side: top;", .noWS = "after-begin" ) ) diff --git a/man/as_html.Rd b/man/as_html.Rd index 0cc9fe95e..ad4ba1e8f 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -11,7 +11,8 @@ as_html( class_tr = NULL, class_th = NULL, link_label = NULL, - bold = c("header") + bold = c("header"), + header_sep_line = TRUE ) } \arguments{ @@ -30,6 +31,8 @@ as_html( \item{bold}{elements in table output that should be bold. Options are \code{"main_title"}, \code{"subtitles"}, \code{"header"}, \code{"row_labels"}, \code{"label_rows"}, and \code{"content_rows"} (which includes any non-label rows). Defaults to \code{"header"}.} + +\item{header_sep_line}{whether a black line should be printed to under the table header. Defaults to \code{TRUE}.} } \value{ A \code{shiny.tag} object representing \code{x} in HTML. @@ -51,7 +54,7 @@ as_html(tbl) as_html(tbl, class_table = "table", class_tr = "row") -as_html(tbl) +as_html(tbl, bold = c("header", "row_labels")) \dontrun{ Viewer(tbl) From 032f160a90a8d41b5447a144c4d3080a3242bb8e Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 9 Nov 2023 16:43:34 -0500 Subject: [PATCH 8/9] Add tests --- R/as_html.R | 16 ++++++++-------- man/as_html.Rd | 4 ++-- tests/testthat/test-exporters.R | 28 +++++++++++++++++++++++++++- 3 files changed, 37 insertions(+), 11 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index e1a3b9b51..dd8b140f0 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -29,8 +29,8 @@ div_helper <- function(lst, class) { #' @param class_th class for `th` tag #' @param width width #' @param link_label link anchor label (not including `tab:` prefix) for the table. -#' @param bold elements in table output that should be bold. Options are `"main_title"`, `"subtitles"`, -#' `"header"`, `"row_labels"`, `"label_rows"`, and `"content_rows"` (which includes any non-label rows). +#' @param bold elements in table output that should be bold. Options are `"main_title"`, `"subtitles"`, +#' `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label rows). #' Defaults to `"header"`. #' @param header_sep_line whether a black line should be printed to under the table header. Defaults to `TRUE`. #' @@ -50,7 +50,7 @@ div_helper <- function(lst, class) { #' #' as_html(tbl, class_table = "table", class_tr = "row") #' -#' as_html(tbl, bold = c("header", "row_labels")) +#' as_html(tbl, bold = c("header", "row_names")) #' #' \dontrun{ #' Viewer(tbl) @@ -107,13 +107,13 @@ as_html <- function(x, ## special casing hax for top_left. We probably want to do this better someday cells[1:nrh, 1] <- mapply( FUN = function(x, algn) { - tags$th(x, class = class_th, style = "white-space:pre;") + tags$th(x, class = class_th, style = "white-space: pre;") }, x = mat$strings[1:nrh, 1], algn = mat$aligns[1:nrh, 1], SIMPLIFY = FALSE ) - + if (header_sep_line) { cells[nrh][[1]] <- htmltools::tagAppendAttributes( cells[nrh, 1][[1]], @@ -129,14 +129,14 @@ as_html <- function(x, style = paste0("padding-left: ", indent * 3, "ch;") ) } - if ("row_labels" %in% bold) { # font weight + if ("row_names" %in% bold) { # font weight cells[i + nrh, 1][[1]] <- htmltools::tagAppendAttributes( cells[i + nrh, 1][[1]], style = paste0("font-weight: bold;") ) } } - + # label rows style if ("label_rows" %in% bold) { which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") @@ -146,7 +146,7 @@ as_html <- function(x, style = "font-weight: bold;" ) } - + # content rows style if ("content_rows" %in% bold) { which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow")) diff --git a/man/as_html.Rd b/man/as_html.Rd index ad4ba1e8f..63e035a6a 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -29,7 +29,7 @@ as_html( \item{link_label}{link anchor label (not including \verb{tab:} prefix) for the table.} \item{bold}{elements in table output that should be bold. Options are \code{"main_title"}, \code{"subtitles"}, -\code{"header"}, \code{"row_labels"}, \code{"label_rows"}, and \code{"content_rows"} (which includes any non-label rows). +\code{"header"}, \code{"row_names"}, \code{"label_rows"}, and \code{"content_rows"} (which includes any non-label rows). Defaults to \code{"header"}.} \item{header_sep_line}{whether a black line should be printed to under the table header. Defaults to \code{TRUE}.} @@ -54,7 +54,7 @@ as_html(tbl) as_html(tbl, class_table = "table", class_tr = "row") -as_html(tbl, bold = c("header", "row_labels")) +as_html(tbl, bold = c("header", "row_names")) \dontrun{ Viewer(tbl) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index 992b80f99..14e366eba 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -256,7 +256,33 @@ test_that("as_html does not trim whitespace", { ) html_tbl <- as_html(tbl) html_parts <- html_tbl$children[[1]][[2]]$children - expect_true(all(sapply(1:4, function(x) html_parts[[x]]$attribs$style == "white-space:pre;"))) + expect_true(all(sapply(1:4, function(x) "white-space: pre;" %in% html_parts[[x]]$attribs))) +}) + +test_that("as_html bolding works", { + tbl <- rtable( + header = LETTERS[1:3], + format = "xx", + rrow(" r1", 1, 2, 3), + rrow(" r 2 ", 4, 3, 2, indent = 1), + rrow("r3 ", indent = 2) + ) + html_tbl <- as_html(tbl, bold = "row_names") + html_parts <- html_tbl$children[[1]][[2]]$children + expect_true(all(sapply(2:4, function(x) "font-weight: bold;" %in% html_parts[[x]]$children[[1]][[1]]$attribs))) +}) + +test_that("as_html header line works", { + tbl <- rtable( + header = LETTERS[1:3], + format = "xx", + rrow(" r1", 1, 2, 3), + rrow(" r 2 ", 4, 3, 2, indent = 1), + rrow("r3 ", indent = 2) + ) + html_tbl <- as_html(tbl, header_sep_line = TRUE) + html_parts <- html_tbl$children[[1]][[2]]$children[[1]]$children[[1]] + expect_true(all(sapply(1:4, function(x) "border-bottom: 1px solid black;" %in% html_parts[[x]]$attribs))) }) ## https://github.com/insightsengineering/rtables/issues/308 From c686adfcd417b5f37e880414c1fd7da80c1a6f1c Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 14 Nov 2023 14:47:49 -0500 Subject: [PATCH 9/9] Add option to remove cell spaces (to print in viewer), update docs --- R/as_html.R | 12 ++++++++++-- man/as_html.Rd | 9 +++++++-- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index dd8b140f0..f97118d7a 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -27,12 +27,15 @@ div_helper <- function(lst, class) { #' @param class_table class for `table` tag #' @param class_tr class for `tr` tag #' @param class_th class for `th` tag -#' @param width width +#' @param width a string to indicate the desired width of the table. Common input formats include a +#' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). +#' Defaults to `NULL`. #' @param link_label link anchor label (not including `tab:` prefix) for the table. #' @param bold elements in table output that should be bold. Options are `"main_title"`, `"subtitles"`, #' `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label rows). #' Defaults to `"header"`. #' @param header_sep_line whether a black line should be printed to under the table header. Defaults to `TRUE`. +#' @param no_spaces_between_cells whether spaces between table cells should be collapsed. Defaults to `FALSE`. #' #' @return A `shiny.tag` object representing `x` in HTML. #' @@ -65,7 +68,8 @@ as_html <- function(x, class_th = NULL, link_label = NULL, bold = c("header"), - header_sep_line = TRUE) { + header_sep_line = TRUE, + no_spaces_between_cells = FALSE) { if (is.null(x)) { return(tags$p("Empty Table")) } @@ -218,6 +222,10 @@ as_html <- function(x, rows, list( class = class_table, + style = paste( + if (no_spaces_between_cells) "border-collapse: collapse;", + if (!is.null(width)) paste("width:", width) + ), tags$caption(sprintf("(\\#tag:%s)", link_label), style = "caption-side: top;", .noWS = "after-begin" diff --git a/man/as_html.Rd b/man/as_html.Rd index 63e035a6a..91d99d208 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -12,13 +12,16 @@ as_html( class_th = NULL, link_label = NULL, bold = c("header"), - header_sep_line = TRUE + header_sep_line = TRUE, + no_spaces_between_cells = FALSE ) } \arguments{ \item{x}{\code{rtable} object} -\item{width}{width} +\item{width}{a string to indicate the desired width of the table. Common input formats include a +percentage of the viewer window width (e.g. \code{"100\%"}) or a distance value (e.g. \code{"300px"}). +Defaults to \code{NULL}.} \item{class_table}{class for \code{table} tag} @@ -33,6 +36,8 @@ as_html( Defaults to \code{"header"}.} \item{header_sep_line}{whether a black line should be printed to under the table header. Defaults to \code{TRUE}.} + +\item{no_spaces_between_cells}{whether spaces between table cells should be collapsed. Defaults to \code{FALSE}.} } \value{ A \code{shiny.tag} object representing \code{x} in HTML.