diff --git a/NEWS.md b/NEWS.md index 94b4e20fb..b43c8f030 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +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, 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/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/R/as_html.R b/R/as_html.R index fccb5ee67..f97118d7a 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -26,12 +26,18 @@ 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 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 \code{shiny.tag} object representing \code{x} in HTML. +#' @return A `shiny.tag` object representing `x` in HTML. #' #' @examples #' @@ -47,7 +53,7 @@ div_helper <- function(lst, class) { #' #' as_html(tbl, class_table = "table", class_tr = "row") #' -#' as_html(tbl, class_td = "aaa") +#' as_html(tbl, bold = c("header", "row_names")) #' #' \dontrun{ #' Viewer(tbl) @@ -59,9 +65,11 @@ 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) { + link_label = NULL, + bold = c("header"), + header_sep_line = TRUE, + no_spaces_between_cells = FALSE) { if (is.null(x)) { return(tags$p("Empty Table")) } @@ -92,6 +100,8 @@ 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;", + style = if (i == nrh && header_sep_line) "border-bottom: 1px solid black;", colspan = if (curspn != 1) curspn, insert_brs(curstrs) ) @@ -101,23 +111,56 @@ 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 ) - # indent row names + 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))) { 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_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") + 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 check_expansion <- c() @@ -147,23 +190,25 @@ 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) ) }) + 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), 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" ) ) @@ -177,9 +222,13 @@ 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", hdrtag + style = "caption-side: top;", + .noWS = "after-begin" ) ) ) @@ -210,10 +259,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(), # line break if (length(prov_footer(x)) > 0) pftr ) + if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst) ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)] ftrtag <- div_helper( @@ -223,7 +275,8 @@ as_html <- function(x, div_helper( class = "rtables-all-parts-block", - list( # hdrtag, + list( + hdrtag, tabletag, ftrtag ) 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. diff --git a/man/as_html.Rd b/man/as_html.Rd index 2168cc114..91d99d208 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -9,25 +9,35 @@ as_html( width = NULL, class_table = "table table-condensed table-hover", class_tr = NULL, - class_td = NULL, class_th = NULL, - link_label = NULL + link_label = NULL, + bold = c("header"), + 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} \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}{elements in table output that should be bold. Options are \code{"main_title"}, \code{"subtitles"}, +\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}.} + +\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. @@ -49,7 +59,7 @@ as_html(tbl) as_html(tbl, class_table = "table", class_tr = "row") -as_html(tbl, class_td = "aaa") +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 8640407eb..14e366eba 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -255,8 +255,34 @@ 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 - expect_true(all(sapply(1:4, function(x) html_parts[[x]]$attribs$style == "white-space:pre;"))) + html_parts <- html_tbl$children[[1]][[2]]$children + 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