Fixing Viewer and as_html for \n manual varlabels (#742)

* Fixing Viewer and as_html for \n manual varlabels * fixes
insightsengineering · Oct 12, 2023 · e66e159 · e66e159
1 parent 3dd7f50
commit e66e159
Show file tree

Hide file tree

Showing 5 changed files with 67 additions and 9 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -2,6 +2,9 @@
 ### New Features
 * Added support for white spaces in all labels and text by redesigning of wrapping functions in `formatters`.
 
+### Bug Fixes
+* Fixed a bug causing `Viewer` and `as_html` to fail when new line characters were added.
+
 ## rtables 0.6.4
 ### New Features
  * Added support for `.docx` exports with `export_as_docx()`.

diff --git a/R/Viewer.R b/R/Viewer.R
@@ -12,7 +12,6 @@ NULL
 #' @param ... arguments passed to \code{as_html}
 #'
 #'
-#' @export
 #'
 #' @return not meaningful. Called for the side effect of opening a browser or viewer pane.
 #'
@@ -42,8 +41,8 @@ NULL
 #' Viewer(tbl, tbl2)
 #'
 #' }
+#' @export
 Viewer <- function(x, y = NULL, row.names.bold = FALSE, ...) {
-
   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
@@ -34,8 +34,6 @@ div_helper <- function(lst, class) {
 #' @param link_label link anchor label (not including \code{tab:} prefix) for the table.
 #'
 #' @return A \code{shiny.tag} object representing \code{x} in HTML.
-#' @importFrom htmltools tags
-#' @export
 #'
 #' @examples
 #'
@@ -56,6 +54,9 @@ div_helper <- function(lst, class) {
 #' \dontrun{
 #' Viewer(tbl)
 #' }
+#' 
+#' @importFrom htmltools tags
+#' @export
 as_html <- function(x,
                     width = NULL,
                     class_table = "table table-condensed table-hover",
@@ -75,8 +76,8 @@ as_html <- function(x,
   nrh <- mf_nrheader(mat)
   nc <- ncol(x) + 1
 
-  cells <- matrix(rep(list(list()), (nrh + nrow(x)) * (nc)),
-                  ncol = nc)
+  # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions
+  cells <- matrix(rep(list(list()), (nrh + nrow(x)) * (nc)), ncol = nc)
 
   for(i in unique(mat$line_grouping)) {
     rows <- which(mat$line_grouping == i)
@@ -118,8 +119,30 @@ as_html <- function(x,
                                                                style = paste0("padding-left: ", indent * 3, "ch"))
     }
   }
-
-  cells[!mat$display] <- NA_integer_
+
+  if (any(!mat$display)) {
+      # Check that expansion kept the same display info
+      check_expansion <- c()
+      for(ii in unique(mat$line_grouping)) {
+          rows <- which(mat$line_grouping == ii)
+          check_expansion <- c(
+            check_expansion,
+            apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x))
+          )
+      }
+
+      if (!all(check_expansion)) {
+          stop("Found that a group of rows have different display options even if ",
+               "they belong to the same line group. This should not happen. Please ",
+               "file an issue or report to the maintainers.") # nocov
+      }
+
+      for (ii in unique(mat$line_grouping)) {
+          rows <- which(mat$line_grouping == ii)
+          should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)
+          cells[ii, !should_display_col] <- NA_integer_
+      }
+  }
 
   rows <- apply(cells, 1, function(row) {
     tags$tr(

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
@@ -194,7 +194,39 @@ test_that("as_html smoke test", {
 
     tbl <- tt_to_export()
     oldo <- options(viewer = identity)
-    fl <- Viewer(tbl)
+    expect_silent(fl <- Viewer(tbl))
+    xml2::read_html(fl)
+    expect_true(TRUE)
+    options(oldo)
+})
+
+test_that("as_html Viewer with newline test", {
+
+    tmpf <- tempfile(fileext = ".html")
+
+    colfuns <- list(function(x) rcell(mean(x), format = "xx.x"),
+                    function(x) rcell(sd(x), format = "xx.x"))
+    varlabs <- c("Mean Age", "SD\nLine Break!!! \nAge")
+
+    lyt <- basic_table() %>%
+        split_cols_by_multivar(c("AGE", "AGE"), varlabels = varlabs) %>%
+        analyze_colvars(afun = colfuns)
+
+    tbl_wrapping <- build_table(lyt, DM)
+
+    tbl_normal <- rtable(
+        header = c("Treatement\nN=100", "Comparison\nN=300"),
+        format = "xx (xx.xx%)",
+        rrow("A", c(104, .2), c(100, .4)),
+        rrow("B", c(23, .4), c(43, .5)),
+        rrow(),
+        rrow("this is a very long section header"),
+        rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
+        rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
+    )
+    oldo <- options(viewer = identity)
+    expect_silent(fl <- Viewer(tbl_wrapping))
+    expect_silent(fl <- Viewer(tbl_normal))
     xml2::read_html(fl)
     expect_true(TRUE)
     options(oldo)