Align table html output with ASCII output (#780)

Closes #247 #572
insightsengineering · Nov 14, 2023 · e329e75 · e329e75
1 parent 5375bca
commit e329e75
Show file tree

Hide file tree

Showing 6 changed files with 126 additions and 42 deletions.
diff --git 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
@@ -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
@@ -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
diff --git a/man/as_html.Rd b/man/as_html.Rd
diff --git 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