diff --git a/NEWS.md b/NEWS.md index 0d08ff788..d11aa0b3f 100644 --- 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 index 46ef08644..19526285a 100644 --- 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 index a7a3f255d..3e2c0806c 100644 --- 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 index 29c82f6c3..5045515f5 100644 --- a/man/as_html.Rd +++ b/man/as_html.Rd @@ -54,4 +54,5 @@ as_html(tbl, class_td = "aaa") \dontrun{ Viewer(tbl) } + } diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index 2625ab640..abf2a0cac 100644 --- 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)