Fix as_html newlines and add parameters to export_as_tsv

DESCRIPTION

@@ -66,7 +66,7 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Collate:
     '00tabletrees.R'
     'Viewer.R'

NEWS.md

@@ -1,4 +1,9 @@
 ## rtables 0.6.9.9000
+### Bug Fixes
+ * Fixed `"\n"` newline issues in `as_html` by relying onto output devices for newline handling. Added `expand_newlines = FALSE` default to allow previous behavior.
+
+### Miscellaneous
+ * Added option to change `sep = "\t"` and set other parameters via `...` parameter propagation in `export_as_tsv`.
 
 ## rtables 0.6.9
 ### Miscellaneous

R/as_html.R

@@ -36,6 +36,8 @@ div_helper <- function(lst, class) {
 #'   to `TRUE`.
 #' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults
 #'   to `FALSE`.
+#' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).
+#'   Doing this keeps the structure of the cells but may depend on the output device.
 #'
 #' @importFrom htmltools tags
 #'
@@ -69,14 +71,15 @@ as_html <- function(x,
                     link_label = NULL,
                     bold = c("header"),
                     header_sep_line = TRUE,
-                    no_spaces_between_cells = FALSE) {
+                    no_spaces_between_cells = FALSE,
+                    expand_newlines = FALSE) {
   if (is.null(x)) {
     return(tags$p("Empty Table"))
   }
 
   stopifnot(is(x, "VTableTree"))
 
-  mat <- matrix_form(x, indent_rownames = TRUE)
+  mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines)
 
   nlh <- mf_nlheader(mat)
   nc <- ncol(x) + 1

R/tt_export.R

@@ -16,6 +16,8 @@ NULL
 #' @inheritParams gen_args
 #' @inheritParams data.frame_export
 #' @param file (`string`)\cr the path of the file to written to or read from.
+#' @param sep (`string`)\cr defaults to `\t`. See [utils::write.table()] for more details.
+#' @param ... (`any`)\cr additional arguments to be passed to [utils::write.table()].
 #'
 #' @return
 #' * `export_as_tsv` returns `NULL` silently.
@@ -27,9 +29,9 @@ NULL
 #' @rdname tsv_io
 #' @export
 export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,
-                          value_fun = collapse_values) {
+                          value_fun = collapse_values, sep = "\t", ...) {
   df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)
-  write.table(df, file, sep = "\t")
+  write.table(df, file, sep = sep, ...)
 }
 
 #' @rdname tsv_io

README.Rmd

@@ -146,7 +146,7 @@ Maximo Carreras, Francois Collins, Saibah Chohan, Tadeusz Lewandowski, Nick Pasz
 ## Presentations
 
 - R in Pharma 2023
-  - Generating Tables, Listings, and Graphs using NEST / [falcon](https://pharmaverse.github.io/falcon/) [[Video](https://www.youtube.com/watch?v=YPmbLPSYFYM)]
+  - Generating Tables, Listings, and Graphs using NEST / [cardinal](https://pharmaverse.github.io/cardinal/) [[Video](https://www.youtube.com/watch?v=YPmbLPSYFYM)]
   - BBS Session on Regulatory Submissions of Clinical Trials [[Video](https://www.youtube.com/watch?v=yZS4OBuJe_Q)]
 - R Medicine Virtual Conference 2023 [[Video](https://www.youtube.com/watch?v=sxFsavKI7s4)]
 - Advanced rtables Training 2023 [[Part 1 Slides](https://github.com/insightsengineering/rtables/blob/main/inst/extdata/Advanced_rtables_part1.pdf)] [[Part 2 Slides](https://github.com/insightsengineering/rtables/blob/main/inst/extdata/Advances_rtables_part2.pdf)]

README.md

@@ -207,7 +207,7 @@ Nick Paszty, Nina Qi, Jana Stoilova, Heng Wang, Godwin Yung
 
 - R in Pharma 2023
   - Generating Tables, Listings, and Graphs using NEST /
-    [falcon](https://pharmaverse.github.io/falcon/)
+    [cardinal](https://pharmaverse.github.io/cardinal/)
     \[[Video](https://www.youtube.com/watch?v=YPmbLPSYFYM)\]
   - BBS Session on Regulatory Submissions of Clinical Trials
     \[[Video](https://www.youtube.com/watch?v=yZS4OBuJe_Q)\]

tests/testthat/test-as_html.R

@@ -0,0 +1,139 @@
+context("Exporting to HTML")
+
+test_that("as_html smoke test", {
+  tmpf <- tempfile(fileext = ".html")
+
+  tbl <- tt_to_export()
+  oldo <- options(viewer = identity)
+  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)
+})
+
+test_that("as_html does not trim whitespace", {
+  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)
+  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/872
+test_that("as_html indentation is translated to rows with linebreaks", {
+  lyt <- basic_table() %>%
+    split_cols_by("ARM") %>%
+    split_rows_by("SEX") %>%
+    analyze("AGE", afun = function(x) {
+      mn <- round(mean(x), 2)
+      if (!is.nan(mn) && mn > mean(DM$AGE)) {
+        val <- paste(mn, "  ^  ", sep = "\n")
+      } else {
+        val <- paste(mn)
+      }
+      in_rows(my_row_label = rcell(val,
+        format = "xx"
+      ))
+    })
+  tbl <- build_table(lyt, DM)
+
+  # Resolves correctly \n
+  expect_silent(res <- as_html(tbl, expand_newlines = TRUE))
+  expect_equal(
+    as.character(res$children[[1]][[2]]$children[[7]]$children[[1]][[1]]),
+    '<td style="text-align: left; padding-left: 3ch;"></td>'
+  )
+  expect_equal(
+    as.character(res$children[[1]][[2]]$children[[7]]$children[[1]][[2]]),
+    '<td style="text-align: center;">  ^  </td>'
+  )
+})
+
+test_that("as_html expands or not newlines depending on expand_newlines", {
+  # Table with both col/row names with newlines
+  iris_mod <- iris %>%
+    mutate(Species2 = as.factor(paste0("General", "\n ", as.character(Species)))) %>%
+    mutate(Species = as.factor(sample(paste0("Petal", "\n ", as.character(Species)))))
+
+  # Also the statistic has a newline
+  lyt <- basic_table() %>%
+    split_cols_by("Species") %>%
+    split_rows_by("Species2") %>%
+    analyze("Sepal.Length", afun = function(x) {
+      list(
+        "mean \n (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
+        "range" = diff(range(x))
+      )
+    })
+
+  tbl <- build_table(lyt, iris_mod)
+  thtml <- as_html(tbl)
+  thtml_expanded_newlines <- as_html(tbl, expand_newlines = TRUE)
+
+  expect_true(grepl(as.character(thtml), pattern = "General\\n setosa"))
+  expect_false(grepl(as.character(thtml_expanded_newlines), pattern = "General\\n setosa")) # diff cells!
+})

tests/testthat/test-exporters.R

@@ -1,4 +1,4 @@
-context("Exporters")
+context("Exporting to txt, pdf, rtf, and docx")
 
 test_that("export_as_txt works with and without pagination", {
   lyt <- basic_table() %>%
@@ -209,120 +209,6 @@ test_that("exporting pdf does the inset", {
   expect_error(export_as_pdf(tbl, file = tmpf), "Width of row labels equal to or larger than")
 })
 
-
-test_that("as_html smoke test", {
-  tmpf <- tempfile(fileext = ".html")
-
-  tbl <- tt_to_export()
-  oldo <- options(viewer = identity)
-  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)
-})
-
-test_that("as_html does not trim whitespace", {
-  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)
-  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/872
-test_that("as_html indentation is translated to rows with linebreaks", {
-  lyt <- basic_table() %>%
-    split_cols_by("ARM") %>%
-    split_rows_by("SEX") %>%
-    analyze("AGE", afun = function(x) {
-      mn <- round(mean(x), 2)
-      if (!is.nan(mn) && mn > mean(DM$AGE)) {
-        val <- paste(mn, "  ^  ", sep = "\n")
-      } else {
-        val <- paste(mn)
-      }
-      in_rows(my_row_label = rcell(val,
-        format = "xx"
-      ))
-    })
-  tbl <- build_table(lyt, DM)
-
-  # Resolves correctly \n
-  expect_silent(res <- as_html(tbl))
-  expect_equal(
-    as.character(res$children[[1]][[2]]$children[[7]]$children[[1]][[1]]),
-    '<td style="text-align: left; padding-left: 3ch;"></td>'
-  )
-  expect_equal(
-    as.character(res$children[[1]][[2]]$children[[7]]$children[[1]][[2]]),
-    '<td style="text-align: center;">  ^  </td>'
-  )
-})
-
 ## https://github.com/insightsengineering/rtables/issues/308
 test_that("path_enriched_df works for tables with a column that has all length 1 elements", {
   my_table <- basic_table() %>%