From 951ce71af9cab97e7b35a5e9790082dfec98f91e Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Tue, 7 Nov 2023 09:21:37 -0500 Subject: [PATCH 01/27] Fix bug preventing footnote path from working with names (#772) --- R/index_footnotes.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/index_footnotes.R b/R/index_footnotes.R index 6ff7ec816..776c49cd6 100644 --- a/R/index_footnotes.R +++ b/R/index_footnotes.R @@ -118,7 +118,7 @@ update_ref_indexing <- function(tt) { } for (i in seq_len(nrow(rdf))) { - path <- rdf$path[[i]] + path <- unname(rdf$path[[i]]) tt_at_path(tt, path) <- .idx_helper( tt_at_path(tt, path), From f8343352c16dde67ec71f729cd68614d9cb2b899 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 7 Nov 2023 14:23:05 +0000 Subject: [PATCH 02/27] [skip actions] Bump version to 0.6.5.9010 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b569e2646..ef0cae16b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9009 -Date: 2023-11-01 +Version: 0.6.5.9010 +Date: 2023-11-07 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 9808b3c80..b51312724 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9009 +## rtables 0.6.5.9010 ### New Features * Removed `ref_group` reordering in column splits so not to change the order. From e1c121da49bfe1525d707bcbb05216eb41bec186 Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Tue, 7 Nov 2023 15:09:33 -0500 Subject: [PATCH 03/27] Keep whitespace in html tables (#777) Closes #775 --- NEWS.md | 5 ++--- R/as_html.R | 1 + tests/testthat/test-exporters.R | 12 ++++++++++++ 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index b51312724..2a4de944b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. + * Added Developer Guide to pkgdown site with Debugging, Split Machinery, and Tabulation sections. + * Whitespace is not trimmed when rendering tables with `as_html`. ## rtables 0.6.5 ### New Features @@ -17,9 +19,6 @@ ### Miscellaneous * Added slide decks for advanced training as internal files. -### Miscellaneous -* Added Developer Guide to pkgdown site with Debugging, Split Machinery, Table Hierarchy, and Tabulation sections. - ## rtables 0.6.4 ### New Features * Added support for `.docx` exports with `export_as_docx()`. diff --git a/R/as_html.R b/R/as_html.R index b1f3096b3..fccb5ee67 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -147,6 +147,7 @@ as_html <- function(x, rows <- apply(cells, 1, function(row) { tags$tr( class = class_tr, + style = "white-space:pre;", Filter(function(x) !identical(x, NA_integer_), row) ) }) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index c757078dd..8640407eb 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -246,6 +246,18 @@ test_that("as_html Viewer with newline test", { 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]][[1]]$children + expect_true(all(sapply(1:4, function(x) html_parts[[x]]$attribs$style == "white-space:pre;"))) +}) ## https://github.com/insightsengineering/rtables/issues/308 test_that("path_enriched_df works for tables with a column that has all length 1 elements", { From 5375bca951c51ee609046812f80d4b1f794be5b6 Mon Sep 17 00:00:00 2001 From: edelarua Date: Tue, 7 Nov 2023 20:10:36 +0000 Subject: [PATCH 04/27] [skip actions] Bump version to 0.6.5.9011 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ef0cae16b..a9f0d2f9a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9010 +Version: 0.6.5.9011 Date: 2023-11-07 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", diff --git a/NEWS.md b/NEWS.md index 2a4de944b..94b4e20fb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9010 +## rtables 0.6.5.9011 ### New Features * Removed `ref_group` reordering in column splits so not to change the order. From e329e7556fbe871dd0636a5c0a7dbb550d5ad413 Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Tue, 14 Nov 2023 14:59:58 -0500 Subject: [PATCH 05/27] Align table html output with ASCII output (#780) Closes #247 #572 --- NEWS.md | 2 + R/Viewer.R | 14 ++---- R/as_html.R | 87 ++++++++++++++++++++++++++------- man/Viewer.Rd | 11 ++--- man/as_html.Rd | 24 ++++++--- tests/testthat/test-exporters.R | 30 +++++++++++- 6 files changed, 126 insertions(+), 42 deletions(-) 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 From f7f9290d1e9a9667cf193d4d7b8127184edef1b8 Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Wed, 15 Nov 2023 16:53:59 -0500 Subject: [PATCH 06/27] Fix `as_html` header alignment (#787) --- R/Viewer.R | 2 +- R/as_html.R | 51 ++++++++++++++++++--------------------------------- man/Viewer.Rd | 2 +- 3 files changed, 20 insertions(+), 35 deletions(-) diff --git a/R/Viewer.R b/R/Viewer.R index d57d9ecf5..35c29bd6a 100644 --- a/R/Viewer.R +++ b/R/Viewer.R @@ -5,7 +5,7 @@ NULL #' #' The table will be displayed using the bootstrap styling for tables. #' -#' @param x object of class `rtable` or `shiny.tag` (defined in [htmltools]) +#' @param x object of class `rtable` or `shiny.tag` (defined in `htmltools` package) #' @param y optional second argument of same type as `x` #' @param ... arguments passed to [`as_html`] #' diff --git a/R/as_html.R b/R/as_html.R index f97118d7a..0e4865a72 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -78,49 +78,34 @@ as_html <- function(x, mat <- matrix_form(x) - nrh <- mf_nrheader(mat) + nlh <- mf_nlheader(mat) nc <- ncol(x) + 1 # 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) + cells <- matrix(rep(list(list()), (nlh + nrow(x)) * (nc)), ncol = nc) - for (i in unique(mat$line_grouping)) { - rows <- which(mat$line_grouping == i) + for (i in seq_len(nrow(mat$strings))) { for (j in seq_len(ncol(mat$strings))) { - curstrs <- mat$strings[rows, j] - curspans <- mat$spans[rows, j] - curaligns <- mat$aligns[rows, j] + curstrs <- mat$strings[i, j] + curspn <- mat$spans[i, j] + algn <- mat$aligns[i, j] - curspn <- unique(curspans) - stopifnot(length(curspn) == 1) - inhdr <- i <= nrh + inhdr <- i <= nlh tagfun <- if (inhdr) tags$th else tags$td - algn <- unique(curaligns) - stopifnot(length(algn) == 1) cells[i, j][[1]] <- tagfun( class = if (inhdr) class_th else class_tr, - class = if (j > 1 || i > nrh) paste0("text-", algn), + style = paste0("text-align: ", algn, ";"), style = if (inhdr && !"header" %in% bold) "font-weight: normal;", - style = if (i == nrh && header_sep_line) "border-bottom: 1px solid black;", + style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;", colspan = if (curspn != 1) curspn, insert_brs(curstrs) ) } } - ## 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;") - }, - x = mat$strings[1:nrh, 1], - algn = mat$aligns[1:nrh, 1], - SIMPLIFY = FALSE - ) - if (header_sep_line) { - cells[nrh][[1]] <- htmltools::tagAppendAttributes( - cells[nrh, 1][[1]], + cells[nlh][[1]] <- htmltools::tagAppendAttributes( + cells[nlh, 1][[1]], style = "border-bottom: 1px solid black;" ) } @@ -129,13 +114,13 @@ as_html <- function(x, for (i in seq_len(nrow(x))) { indent <- mat$row_info$indent[i] if (indent > 0) { # indentation - cells[i + nrh, 1][[1]] <- htmltools::tagAppendAttributes(cells[i + nrh, 1][[1]], + cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes(cells[i + nlh, 1][[1]], 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]], + cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes( + cells[i + nlh, 1][[1]], style = paste0("font-weight: bold;") ) } @@ -144,8 +129,8 @@ as_html <- function(x, # 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, ], + cells[which_lbl_rows + nlh, ] <- lapply( + cells[which_lbl_rows + nlh, ], htmltools::tagAppendAttributes, style = "font-weight: bold;" ) @@ -154,8 +139,8 @@ as_html <- function(x, # 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, ], + cells[which_cntnt_rows + nlh, ] <- lapply( + cells[which_cntnt_rows + nlh, ], htmltools::tagAppendAttributes, style = "font-weight: bold;" ) diff --git a/man/Viewer.Rd b/man/Viewer.Rd index 74cff9ee3..01d886f34 100644 --- a/man/Viewer.Rd +++ b/man/Viewer.Rd @@ -7,7 +7,7 @@ Viewer(x, y = NULL, ...) } \arguments{ -\item{x}{object of class \code{rtable} or \code{shiny.tag} (defined in \link{htmltools})} +\item{x}{object of class \code{rtable} or \code{shiny.tag} (defined in \code{htmltools} package)} \item{y}{optional second argument of same type as \code{x}} From 4a445e72e303a403b2ac7ab5585ce14f211b2f7a Mon Sep 17 00:00:00 2001 From: cicdguy Date: Thu, 16 Nov 2023 00:17:59 +0000 Subject: [PATCH 07/27] [skip actions] Bump version to 0.6.5.9012 --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a9f0d2f9a..b073dd26c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9011 -Date: 2023-11-07 +Version: 0.6.5.9012 +Date: 2023-11-16 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), From 5f19f73aa99638ff955e174a57b19b6f070bb230 Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Thu, 23 Nov 2023 15:07:57 -0500 Subject: [PATCH 08/27] Combine duplicate ref footnotes (#781) Closes #779 --- DESCRIPTION | 2 +- NAMESPACE | 4 ++ NEWS.md | 3 +- R/index_footnotes.R | 24 ++++++---- R/tree_accessors.R | 60 ++++++++++++++++++++++-- R/tt_paginate.R | 4 +- R/tt_pos_and_access.R | 2 +- R/tt_toString.R | 7 ++- man/int_methods.Rd | 22 +++++---- man/ref_fnotes.Rd | 9 ++++ tests/testthat/test-exporters.R | 2 +- tests/testthat/test-pagination.R | 73 +++++++++++++++++++++++++++++ tests/testthat/test-subset-access.R | 6 +-- 13 files changed, 183 insertions(+), 35 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b073dd26c..81beb2e67 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,7 +29,7 @@ URL: https://github.com/insightsengineering/rtables, https://insightsengineering.github.io/rtables/ BugReports: https://github.com/insightsengineering/rtables/issues Depends: - formatters (>= 0.5.4), + formatters (>= 0.5.4.9003), magrittr (>= 1.5), methods, R (>= 2.10) diff --git a/NAMESPACE b/NAMESPACE index 4124e66b4..6636fcefe 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ export("cell_footnotes<-") export("clayout<-") export("col_counts<-") export("col_fnotes_here<-") +export("col_footnotes<-") export("col_info<-") export("col_total<-") export("colcount_format<-") @@ -64,6 +65,7 @@ export(clear_indent_mods) export(col_counts) export(col_exprs) export(col_fnotes_here) +export(col_footnotes) export(col_info) export(col_paths) export(col_paths_summary) @@ -198,6 +200,7 @@ exportMethods("cell_footnotes<-") exportMethods("clayout<-") exportMethods("col_counts<-") exportMethods("col_fnotes_here<-") +exportMethods("col_footnotes<-") exportMethods("col_info<-") exportMethods("col_total<-") exportMethods("colcount_format<-") @@ -228,6 +231,7 @@ exportMethods(clayout) exportMethods(clear_indent_mods) exportMethods(col_counts) exportMethods(col_fnotes_here) +exportMethods(col_footnotes) exportMethods(col_info) exportMethods(col_total) exportMethods(colcount_format) diff --git a/NEWS.md b/NEWS.md index b43c8f030..83b4393c9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,12 +2,13 @@ ### 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. - + * Duplicate referential footnotes are consolidated when tables are rendered. ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. * Added Developer Guide to pkgdown site with Debugging, Split Machinery, and Tabulation sections. * Whitespace is not trimmed when rendering tables with `as_html`. + * Started deprecation cycle for `col_fnotes_here` to be replaced with `col_footnotes`. ## rtables 0.6.5 ### New Features diff --git a/R/index_footnotes.R b/R/index_footnotes.R index 776c49cd6..fad316bda 100644 --- a/R/index_footnotes.R +++ b/R/index_footnotes.R @@ -9,7 +9,7 @@ ## to begin with idx <- ref_index(refi) if (is.na(idx) || !is.na(as.integer(idx))) { - ref_index(refi) <- cur_idx_fun() + ref_index(refi) <- cur_idx_fun(refi) } refi }) @@ -63,8 +63,8 @@ index_col_refs <- function(tt, cur_idx_fun) { .index_col_refs_inner <- function(ctree, cur_idx_fun) { - col_fnotes_here(ctree) <- .reindex_one_pos( - col_fnotes_here(ctree), + col_footnotes(ctree) <- .reindex_one_pos( + col_footnotes(ctree), cur_idx_fun ) @@ -75,9 +75,9 @@ index_col_refs <- function(tt, cur_idx_fun) { ) } ctree - ## cfs <- col_fnotes_here(ctree) + ## cfs <- col_footnotes(ctree) ## if(length(unlist(cfs)) > 0) { - ## col_fnotes_here(ctree) <- .reindex_one_pos(lapply(cfs, + ## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs, ## function(refs) lapply(refs, function(refi) { } @@ -95,11 +95,17 @@ index_col_refs <- function(tt, cur_idx_fun) { #' manually. #' @export update_ref_indexing <- function(tt) { - curind <- 0L - cur_index <- function() { - curind <<- curind + 1L - curind + col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt)) + row_fnotes <- row_footnotes(tt) + cell_fnotes <- cell_footnotes(tt) + all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes)) + all_fns <- unlist(t(all_fns)) + unique_fnotes <- unique(sapply(all_fns, ref_msg)) + + cur_index <- function(ref_fn) { + match(ref_msg(ref_fn), unique_fnotes) } + if (ncol(tt) > 0) { tt <- index_col_refs(tt, cur_index) } ## col_info(tt) <- index_col_refs(col_info(tt), cur_index) diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 638ac4acb..88681dc25 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -2877,33 +2877,83 @@ setMethod("cell_footnotes<-", "ContentRow", definition = .cfn_set_helper ) +# Deprecated methods #' @export #' @rdname ref_fnotes setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here")) #' @export +#' @rdname ref_fnotes +setMethod("col_fnotes_here", "ANY", function(obj) { + .Deprecated( + new = "col_footnotes", + old = "col_fnotes_here", + msg = "col_fnotes_here was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes instead." + ) + col_footnotes(obj) +}) +#' @export +#' @rdname ref_fnotes +setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-")) +#' @export #' @rdname int_methods -setMethod("col_fnotes_here", c("LayoutColTree"), function(obj) obj@col_footnotes) +setMethod("col_fnotes_here<-", "ANY", function(obj, value) { + .Deprecated( + new = "col_footnotes<-", + old = "col_fnotes_here<-", + msg = "col_fnotes_here<- was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes<- instead." + ) + col_footnotes(obj) <- value +}) + +#' @export +#' @rdname ref_fnotes +setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes")) + #' @export #' @rdname int_methods -setMethod("col_fnotes_here", c("LayoutColLeaf"), function(obj) obj@col_footnotes) +setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes) + +#' @export +#' @rdname int_methods +setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes) #' @export #' @rdname ref_fnotes -setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-")) +setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-")) + #' @export #' @rdname int_methods -setMethod("col_fnotes_here<-", "LayoutColTree", function(obj, value) { +setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) { obj@col_footnotes <- make_ref_value(value) obj }) #' @export #' @rdname int_methods -setMethod("col_fnotes_here<-", "LayoutColLeaf", function(obj, value) { +setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) { obj@col_footnotes <- make_ref_value(value) obj }) +#' @export +#' @rdname int_methods +setMethod( + "col_footnotes", "VTableTree", + function(obj) { + ctree <- coltree(obj) + cols <- tree_children(ctree) + while (all(sapply(cols, is, "LayoutColTree"))) { + cols <- lapply(cols, tree_children) + cols <- unlist(cols, recursive = FALSE) + } + all_col_fnotes <- lapply(cols, col_footnotes) + if (is.null(unlist(all_col_fnotes))) { + return(NULL) + } + + return(all_col_fnotes) + } +) #' @export #' @rdname ref_fnotes diff --git a/R/tt_paginate.R b/R/tt_paginate.R index a9088ffb9..fb3f5143b 100644 --- a/R/tt_paginate.R +++ b/R/tt_paginate.R @@ -444,7 +444,7 @@ setMethod( sibpos = sibpos, nsibs = nsibs, leaf_indices = colnum, - col_fnotes = col_fnotes_here(ct) + col_fnotes = col_footnotes(ct) )) } ) @@ -484,7 +484,7 @@ setMethod( sibpos = sibpos, nsibs = nsibs, pth = thispth, - col_fnotes = col_fnotes_here(ct) + col_fnotes = col_footnotes(ct) )) ret <- c(thisone, ret) } diff --git a/R/tt_pos_and_access.R b/R/tt_pos_and_access.R index 030b54498..5462efb02 100644 --- a/R/tt_pos_and_access.R +++ b/R/tt_pos_and_access.R @@ -96,7 +96,7 @@ coltree_split <- function(ctree) ctree@split col_fnotes_at_path <- function(ctree, path, fnotes) { if (length(path) == 0) { - col_fnotes_here(ctree) <- fnotes + col_footnotes(ctree) <- fnotes return(ctree) } diff --git a/R/tt_toString.R b/R/tt_toString.R index fc31d3d5b..e10bb98e2 100644 --- a/R/tt_toString.R +++ b/R/tt_toString.R @@ -435,13 +435,12 @@ get_formatted_fnotes <- function(tt) { ) inds <- vapply(lst, ref_index, 1L) - stopifnot(all(is.na(inds)) || !is.unsorted(inds)) + ord <- order(inds) + lst <- lst[ord] syms <- vapply(lst, ref_symbol, "") keep <- is.na(syms) | !duplicated(syms) - inds <- inds[keep] lst <- lst[keep] - syms <- syms[keep] - vapply(lst, format_fnote_note, "") + unique(vapply(lst, format_fnote_note, "")) diff --git a/man/int_methods.Rd b/man/int_methods.Rd index db2053b11..e5d1fd063 100644 --- a/man/int_methods.Rd +++ b/man/int_methods.Rd @@ -315,10 +315,12 @@ \alias{cell_footnotes<-,CellValue-method} \alias{cell_footnotes<-,DataRow-method} \alias{cell_footnotes<-,ContentRow-method} -\alias{col_fnotes_here,LayoutColTree-method} -\alias{col_fnotes_here,LayoutColLeaf-method} -\alias{col_fnotes_here<-,LayoutColTree-method} -\alias{col_fnotes_here<-,LayoutColLeaf-method} +\alias{col_fnotes_here<-,ANY-method} +\alias{col_footnotes,LayoutColTree-method} +\alias{col_footnotes,LayoutColLeaf-method} +\alias{col_footnotes<-,LayoutColTree-method} +\alias{col_footnotes<-,LayoutColLeaf-method} +\alias{col_footnotes,VTableTree-method} \alias{ref_index,RefFootnote-method} \alias{ref_index<-,RefFootnote-method} \alias{ref_symbol,RefFootnote-method} @@ -1023,13 +1025,17 @@ spl_varnames(object) <- value \S4method{cell_footnotes}{ContentRow}(obj) <- value -\S4method{col_fnotes_here}{LayoutColTree}(obj) +\S4method{col_fnotes_here}{ANY}(obj) <- value -\S4method{col_fnotes_here}{LayoutColLeaf}(obj) +\S4method{col_footnotes}{LayoutColTree}(obj) -\S4method{col_fnotes_here}{LayoutColTree}(obj) <- value +\S4method{col_footnotes}{LayoutColLeaf}(obj) -\S4method{col_fnotes_here}{LayoutColLeaf}(obj) <- value +\S4method{col_footnotes}{LayoutColTree}(obj) <- value + +\S4method{col_footnotes}{LayoutColLeaf}(obj) <- value + +\S4method{col_footnotes}{VTableTree}(obj) \S4method{ref_index}{RefFootnote}(obj) diff --git a/man/ref_fnotes.Rd b/man/ref_fnotes.Rd index ec15488ab..852926ebe 100644 --- a/man/ref_fnotes.Rd +++ b/man/ref_fnotes.Rd @@ -6,7 +6,10 @@ \alias{cell_footnotes} \alias{cell_footnotes<-} \alias{col_fnotes_here} +\alias{col_fnotes_here,ANY-method} \alias{col_fnotes_here<-} +\alias{col_footnotes} +\alias{col_footnotes<-} \alias{ref_index} \alias{ref_index<-} \alias{ref_symbol} @@ -25,8 +28,14 @@ cell_footnotes(obj) <- value col_fnotes_here(obj) +\S4method{col_fnotes_here}{ANY}(obj) + col_fnotes_here(obj) <- value +col_footnotes(obj) + +col_footnotes(obj) <- value + ref_index(obj) ref_index(obj) <- value diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index 14e366eba..f01f1bf22 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -333,7 +333,7 @@ test_that("Can create flextable object that works with different styles", { expect_equal(sum(unlist(nrow(ft))), 20) ft2 <- tt_to_flextable(tbl, paginate = TRUE, lpp = 20, verbose = TRUE) - expect_equal(length(ft2), 6) + expect_equal(length(ft2), 2) expect_silent(ft3 <- tt_to_flextable(tbl, theme = NULL)) diff --git a/tests/testthat/test-pagination.R b/tests/testthat/test-pagination.R index 4abb0da6e..ee9ffc80b 100644 --- a/tests/testthat/test-pagination.R +++ b/tests/testthat/test-pagination.R @@ -497,3 +497,76 @@ test_that("Pagination works with wrapped titles/footers", { expect_equal(nchar(res2_str2_spl[nrow_res2 - 1]), 58) expect_equal(nchar(res2_str2_spl[nrow_res2]), 7) }) + +test_that("Pagination works with referential footnotes", { + lyt <- basic_table( + title = "main title", + subtitles = "subtitle", + main_footer = "main footer", + prov_footer = "provenance footer" + ) %>% + split_cols_by("ARM") %>% + split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>% + split_rows_by("STRATA1", split_fun = keep_split_levels(c("A", "B")), page_by = TRUE, page_prefix = "Stratum") %>% + split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>% + summarize_row_groups() %>% + analyze("AGE", afun = function(x, ...) { + in_rows( + "mean (sd)" = rcell( + c(mean(x), sd(x)), + format = "xx.x (xx.x)" + ), + "range" = rcell(range(x), format = "xx.x - xx.x") + ) + }) + + tt <- build_table(lyt, ex_adsl) + + fnotes_at_path(tt, rowpath = c("STRATA1", "B", "RACE", "WHITE")) <- "3 Row footnote" + fnotes_at_path( + tt, + rowpath = c("STRATA1", "A", "RACE", "WHITE", "AGE", "range"), + colpath = c("ARM", "C: Combination", "SEX", "M") + ) <- "2 Cell footnote" + fnotes_at_path(tt, rowpath = c("STRATA1", "A", "RACE", "ASIAN")) <- "1 Row footnote" + fnotes_at_path( + tt, + rowpath = c("STRATA1", "B", "RACE", "WHITE", "AGE", "mean (sd)"), + colpath = c("ARM", "B: Placebo", "SEX", "F") + ) <- "2 Cell footnote" + + main_title(tt) <- "title with a\nnewline" + main_footer(tt) <- "wrapped footer with\nnewline" + + res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE)) + expect_identical(main_title(res[[1]]), main_title(res[[2]])) + expect_identical(main_title(res[[1]]), main_title(tt)) + expect_identical(main_footer(res[[1]]), main_footer(res[[2]])) + expect_identical(main_footer(res[[1]]), main_footer(tt)) + + main_title(tt) <- "this is a long long table title that should be wrapped to a new line" + main_footer(tt) <- "this is an extra long table main footer and should also be wrapped" + + res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE)) + expect_equal(length(res), 4) + + ref_fn_res1 <- matrix_form(res[[1]])$ref_fnote_df + expect_equal(ref_fn_res1$msg, "1 Row footnote") + expect_equal(ref_fn_res1$ref_index, 1) + expect_equal(ref_fn_res1$symbol, "1") + + ref_fn_res2 <- matrix_form(res[[2]])$ref_fnote_df + expect_equal(ref_fn_res2$msg, c("1 Row footnote", "2 Cell footnote")) + expect_equal(ref_fn_res2$ref_index, 1:2) + expect_equal(ref_fn_res2$symbol, c("1", "2")) + + ref_fn_res3 <- matrix_form(res[[3]])$ref_fnote_df + expect_equal(ref_fn_res3$msg, c("3 Row footnote", "2 Cell footnote")) + expect_equal(ref_fn_res3$ref_index, 1:2) + expect_equal(ref_fn_res3$symbol, c("3", "2")) + + ref_fn_res4 <- matrix_form(res[[4]])$ref_fnote_df + expect_equal(ref_fn_res4$msg, "3 Row footnote") + expect_equal(ref_fn_res4$ref_index, 1) + expect_equal(ref_fn_res4$symbol, "3") +}) diff --git a/tests/testthat/test-subset-access.R b/tests/testthat/test-subset-access.R index ba269dbbb..223219845 100644 --- a/tests/testthat/test-subset-access.R +++ b/tests/testthat/test-subset-access.R @@ -287,15 +287,15 @@ test_that("top_left, title, footers retention behaviors are correct across all s # referential footnotes expect_identical( mf_rfnotes(matrix_form(tbl[2, 1])), - c("F.AGE.mean" = paste0("{1} - ", rf)) + paste0("{1} - ", rf) ) expect_identical( mf_rfnotes(matrix_form(tbl[4, 1])), - c("M.AGE.mean" = paste0("{1} - ", rf)) + paste0("{1} - ", rf) ) expect_identical( mf_rfnotes(matrix_form(tbl[4, 1, reindex_refs = FALSE])), - c("M.AGE.mean" = paste0("{2} - ", rf)) + paste0("{1} - ", rf) ) expect_identical(mf_rfnotes(matrix_form(tbl[1, 1])), character()) From 3de3da7e8b4711a7b826b26ecaeaec403fcaa9b4 Mon Sep 17 00:00:00 2001 From: edelarua Date: Thu, 23 Nov 2023 20:09:00 +0000 Subject: [PATCH 09/27] [skip actions] Bump version to 0.6.5.9013 --- .pre-commit-config.yaml | 2 +- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 36e3c573a..143a9ef58 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -2,7 +2,7 @@ # R specific hooks: https://github.com/lorenzwalthert/precommit repos: - repo: https://github.com/lorenzwalthert/precommit - rev: v0.3.2.9025 + rev: v0.3.2.9027 hooks: - id: roxygenize # roxygen requires loading pkg -> add dependencies from DESCRIPTION diff --git a/DESCRIPTION b/DESCRIPTION index 81beb2e67..021a4eb28 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9012 -Date: 2023-11-16 +Version: 0.6.5.9013 +Date: 2023-11-23 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 83b4393c9..7fd12fbd7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9011 +## rtables 0.6.5.9013 ### 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. From 9b4409edfc1ed084b0b0ab3f4b3e9b4ff7f4b394 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Fri, 24 Nov 2023 09:46:35 +0100 Subject: [PATCH 10/27] 761 better getter seeters@221 fix separator div@main (#782) * update ref_group column ordering * testing formatter issue #221 * minor changes and fixes * update, getting closer * init setter getter * More info * renamings * Update NEWS.md Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini * reverting the concept of section div from layout perspective * Fixed reversion + benefits * almost there * update, revisions * documenting * final touch * minors, docs * adding 1 * Fix * styling * fix for vignette * small error fix * fixing minor docs * fix integration * fixing docs * Update R/tree_accessors.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini * Update R/tree_accessors.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini * Update R/tree_accessors.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini * Update R/tree_accessors.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini * Update R/tree_accessors.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini * roxygenizing --------- Signed-off-by: Davide Garolini Signed-off-by: Davide Garolini Co-authored-by: Liming Li Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Co-authored-by: Emily de la Rua --- NAMESPACE | 4 + NEWS.md | 12 +- R/00tabletrees.R | 62 +++--- R/argument_conventions.R | 10 +- R/colby_constructors.R | 3 + R/tree_accessors.R | 366 ++++++++++++++++++++++++------- R/tt_dotabulation.R | 47 ++-- R/tt_paginate.R | 25 ++- R/tt_toString.R | 1 + _pkgdown.yml | 4 + man/avarspl.Rd | 14 +- man/basic_table.Rd | 6 + man/constr_args.Rd | 12 +- man/rowclasses.Rd | 13 +- man/section_div.Rd | 124 +++++++++++ man/tabclasses.Rd | 13 +- tests/testthat/test-accessors.R | 182 +++++++++++++++ tests/testthat/test-printing.R | 58 +++++ vignettes/dev-guide/dg_notes.Rmd | 148 +++++++++++++ 19 files changed, 945 insertions(+), 159 deletions(-) create mode 100644 man/section_div.Rd create mode 100644 vignettes/dev-guide/dg_notes.Rmd diff --git a/NAMESPACE b/NAMESPACE index 6636fcefe..b0ccfe48d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,12 +12,14 @@ export("col_total<-") export("colcount_format<-") export("content_table<-") export("fnotes_at_path<-") +export("header_section_div<-") export("horizontal_sep<-") export("indent_mod<-") export("label_at_path<-") export("ref_index<-") export("ref_symbol<-") export("row_footnotes<-") +export("section_div<-") export("top_left<-") export("tree_children<-") export("tt_at_path<-") @@ -92,6 +94,7 @@ export(find_degen_struct) export(format_rcell) export(get_formatted_cells) export(head) +export(header_section_div) export(horizontal_sep) export(import_from_tsv) export(in_rows) @@ -144,6 +147,7 @@ export(rrowl) export(rtable) export(rtablel) export(sanitize_table_struct) +export(section_div) export(section_properties_landscape) export(section_properties_portrait) export(select_all_levels) diff --git a/NEWS.md b/NEWS.md index 7fd12fbd7..83df355e5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,14 +1,24 @@ ## rtables 0.6.5.9013 ### 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. + * 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. * Duplicate referential footnotes are consolidated when tables are rendered. + * Section divisors can be set for analysis rows. + * Added setter and getter for section dividers (`section_div` and `section_div<-`). They also accept + split section structure assignment. + * Added `header_section_div` setters and getters for layout and table objects along with + related `basic_table` parameter. + +### Bug Fixes + * Fixed a bug that was failing when wrapping and section dividers were used at the same time. ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. * Added Developer Guide to pkgdown site with Debugging, Split Machinery, and Tabulation sections. * Whitespace is not trimmed when rendering tables with `as_html`. * Started deprecation cycle for `col_fnotes_here` to be replaced with `col_footnotes`. + * Exported `section_div` methods now have a dedicated documentation page that is visible to users. ## rtables 0.6.5 ### New Features diff --git a/R/00tabletrees.R b/R/00tabletrees.R index 694cf17d4..d9cbfb3db 100644 --- a/R/00tabletrees.R +++ b/R/00tabletrees.R @@ -1,5 +1,4 @@ -## Split types -## ----------- +## Split types ----------------------------------------------------------------- ## variable: split on distinct values of a variable ## all: include all observations (root 'split') ## rawcut: cut on static values of a variable @@ -647,7 +646,8 @@ AnalyzeVarSplit <- function(var, extra_args = list(), indent_mod = 0L, label_pos = "default", - cvar = "") { + cvar = "", + section_div = NA_character_) { check_ok_label(split_label) label_pos <- match.arg(label_pos, c("default", label_pos_values)) if (!any(nzchar(defrowlab))) { @@ -674,7 +674,7 @@ AnalyzeVarSplit <- function(var, var_label_position = label_pos, content_var = cvar, page_title_prefix = NA_character_, - child_section_div = NA_character_ + child_section_div = section_div ) ## no content_extra_args } @@ -696,7 +696,8 @@ AnalyzeColVarSplit <- function(afun, extra_args = list(), indent_mod = 0L, label_pos = "default", - cvar = "") { + cvar = "", + section_div = NA_character_) { label_pos <- match.arg(label_pos, c("default", label_pos_values)) new("AnalyzeColVarSplit", payload = NA_character_, @@ -716,7 +717,7 @@ AnalyzeColVarSplit <- function(afun, var_label_position = label_pos, content_var = cvar, page_title_prefix = NA_character_, - child_section_div = NA_character_ + child_section_div = section_div ) ## no content_extra_args } @@ -828,7 +829,8 @@ AnalyzeMultiVars <- function(var, indent_mod = indent_mod, label_pos = show_kidlabs, split_format = split_format, - split_na_str = split_na_str + split_na_str = split_na_str, + section_div = section_div ), ## rvis), SIMPLIFY = FALSE ) @@ -1015,8 +1017,7 @@ make_child_pos <- function(parpos, } -### -### Virtual Classes +# Virtual Classes for Tree Nodes and Layouts ================================= ### ### Virtual class hiearchy for the various types of ### trees in use in the S4 implementation of the TableTree @@ -1148,7 +1149,7 @@ LayoutColLeaf <- function(lev = 0L, -## Instantiated column info class +## Instantiated column info class ============================================== ## ## This is so we don't need multiple arguments ## in the recursive functions that track @@ -1236,10 +1237,7 @@ InstantiatedColumnInfo <- function(treelyt = LayoutColTree(), } - - - -## TableTrees +## TableTrees and row classes ================================================== ## XXX Rowspans as implemented dont really work ## they're aren't attached to the right data structures ## during conversions. @@ -1264,7 +1262,8 @@ setClass("TableRow", var_analyzed = "character", ## var_label = "character", label = "character", - row_footnotes = "list" + row_footnotes = "list", + trailing_section_div = "character" ) ) @@ -1286,7 +1285,8 @@ LabelRow <- function(lev = 1L, vis = !is.na(label) && nzchar(label), cinfo = EmptyColInfo, indent_mod = 0L, - table_inset = 0L) { + table_inset = 0L, + trailing_section_div = NA_character_) { check_ok_label(label) new("LabelRow", leaf_value = list(), @@ -1299,7 +1299,8 @@ LabelRow <- function(lev = 1L, col_info = cinfo, visible = vis, indent_modifier = as.integer(indent_mod), - table_inset = as.integer(table_inset) + table_inset = as.integer(table_inset), + trailing_section_div = trailing_section_div ) } @@ -1353,7 +1354,8 @@ setClass("LabelRow", klass, indent_mod = 0L, footnotes = list(), - table_inset = 0L) { + table_inset = 0L, + trailing_section_div = NA_character_) { if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) { name <- label } @@ -1380,7 +1382,8 @@ setClass("LabelRow", na_str = NA_character_, indent_modifier = indent_mod, row_footnotes = footnotes, - table_inset = table_inset + table_inset = table_inset, + trailing_section_div = trailing_section_div ) rw <- set_format_recursive(rw, format, na_str, FALSE) rw @@ -1413,6 +1416,7 @@ setClass("VTableTree", labelrow = "LabelRow", page_titles = "character", horizontal_sep = "character", + header_section_div = "character", trailing_section_div = "character" ) ) @@ -1516,8 +1520,9 @@ ElementaryTable <- function(kids = list(), subtitles = character(), main_footer = character(), prov_footer = character(), + header_section_div = NA_character_, hsep = default_hsep(), - trailing_sep = NA_character_, + trailing_section_div = NA_character_, inset = 0L) { check_ok_label(label) if (is.null(cinfo)) { @@ -1551,7 +1556,8 @@ ElementaryTable <- function(kids = list(), main_footer = main_footer, provenance_footer = prov_footer, horizontal_sep = hsep, - trailing_section_div = trailing_sep + header_section_div = header_section_div, + trailing_section_div = trailing_section_div ) tab <- set_format_recursive(tab, format, na_str, FALSE) table_inset(tab) <- as.integer(inset) @@ -1615,7 +1621,8 @@ TableTree <- function(kids = list(), prov_footer = character(), page_title = NA_character_, hsep = default_hsep(), - trailing_sep = NA_character_, + header_section_div = NA_character_, + trailing_section_div = NA_character_, inset = 0L) { check_ok_label(label) cinfo <- .calc_cinfo(cinfo, cont, kids) @@ -1648,7 +1655,8 @@ TableTree <- function(kids = list(), main_footer = main_footer, prov_footer = prov_footer, hsep = hsep, - trailing_sep = trailing_sep, + header_section_div = header_section_div, + trailing_section_div = trailing_section_div, inset = inset ) } else { @@ -1670,12 +1678,13 @@ TableTree <- function(kids = list(), provenance_footer = prov_footer, page_title_prefix = page_title, horizontal_sep = "-", - trailing_section_div = trailing_sep + header_section_div = header_section_div, + trailing_section_div = trailing_section_div ) ## this is overridden below to get recursiveness tab <- set_format_recursive(tab, format, na_str, FALSE) ## these is recursive - ## XXX combine thse probably + ## XXX combine these probably horizontal_sep(tab) <- hsep table_inset(tab) <- as.integer(inset) tab @@ -1796,6 +1805,7 @@ setClass("PreDataTableLayouts", row_layout = "PreDataRowLayout", col_layout = "PreDataColLayout", top_left = "character", + header_section_div = "character", table_inset = "integer" ) ) @@ -1807,6 +1817,7 @@ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), subtitles = character(), main_footer = character(), prov_footer = character(), + header_section_div = NA_character_, table_inset = 0L) { new("PreDataTableLayouts", row_layout = rlayout, @@ -1816,6 +1827,7 @@ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), subtitles = subtitles, main_footer = main_footer, provenance_footer = prov_footer, + header_section_div = header_section_div, table_inset = table_inset ) } diff --git a/R/argument_conventions.R b/R/argument_conventions.R index 14aa26747..70c6cd964 100644 --- a/R/argument_conventions.R +++ b/R/argument_conventions.R @@ -219,20 +219,24 @@ lyt_args <- function(lyt, var, vars, label, labels_var, varlabels, varnames, spl #' Generally should not be modified by hand. #' @param footnotes list or NULL. Referential footnotes to be applied at current #' level. In post-processing, this can be achieved with [`fnotes_at_path<-`]. -#' @param trailing_sep character(1). String which will be used as a section +#' @param trailing_section_div character(1). String which will be used as a section #' divider after the printing of the last row contained in this (sub)-table, #' unless that row is also the last table row to be printed overall, or #' `NA_character_` for none (the default). When generated via layouting, this #' would correspond to the `section_div` of the split under which this table #' represents a single facet. +#' @param header_section_div character(1). String which will be used to divide the header +#' from the table. See [header_section_div()] for getter and setter of these. +#' Please consider changing last element of [section_div()] when concatenating +#' tables that need a divider between them. #' @param page_title character. Page specific title(s). #' @rdname constr_args constr_args <- function(kids, cont, lev, iscontent, cinfo, labelrow, vals, cspan, label_pos, cindent_mod, cvar, label, cextra_args, child_names, title, subtitles, main_footer, prov_footer, footnotes, page_title, page_prefix, section_div, - trailing_sep, split_na_str, - cna_str, inset, table_inset) { + trailing_section_div, split_na_str, + cna_str, inset, table_inset, header_section_div) { NULL } diff --git a/R/colby_constructors.R b/R/colby_constructors.R index 0c4a21187..80ba3c7fb 100644 --- a/R/colby_constructors.R +++ b/R/colby_constructors.R @@ -2049,6 +2049,7 @@ basic_table <- function(title = "", subtitles = character(), main_footer = character(), prov_footer = character(), + header_section_div = NA_character_, show_colcounts = FALSE, colcount_format = "(N=xx)", inset = 0L) { @@ -2056,11 +2057,13 @@ basic_table <- function(title = "", if (is.na(inset) || inset < 0L) { stop("Got invalid table_inset value, must be an integer > 0") } + .check_header_section_div(header_section_div) ret <- PreDataTableLayouts( title = title, subtitles = subtitles, main_footer = main_footer, prov_footer = prov_footer, + header_section_div = header_section_div, table_inset = as.integer(inset) ) if (show_colcounts) { diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 88681dc25..616be3e60 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -3003,10 +3003,6 @@ setMethod( ) - - - - #' @export #' @rdname ref_fnotes setGeneric("ref_msg", function(obj) standardGeneric("ref_msg")) @@ -3069,7 +3065,6 @@ setMethod( ) - #' @param rowpath character or NULL. Path within row structure. \code{NULL} #' indicates the footnote should go on the column rather than cell. #' @param colpath character or NULL. Path within column structure. \code{NULL} @@ -3168,7 +3163,7 @@ setMethod("page_titles<-", "VTableTree", function(obj, value) { }) - +## Horizontal separator -------------------------------------------------------- #' Access or recursively set header-body separator for tables #' #' @inheritParams gen_args @@ -3223,20 +3218,15 @@ setMethod( ) - +## Section dividers ------------------------------------------------------------ +# Used for splits setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div")) - setMethod( "spl_section_div", "Split", function(obj) obj@child_section_div ) - -setGeneric( - "spl_section_div<-", - function(obj, value) standardGeneric("spl_section_div<-") -) - +setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-")) setMethod( "spl_section_div<-", "Split", function(obj, value) { @@ -3245,7 +3235,286 @@ setMethod( } ) +# Used for table object parts +setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div")) +setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div) +setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div) +setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div) + +setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-")) +setMethod("trailing_section_div<-", "VTableTree", function(obj, value) { + obj@trailing_section_div <- value + obj +}) +setMethod("trailing_section_div<-", "LabelRow", function(obj, value) { + obj@trailing_section_div <- value + obj +}) +setMethod("trailing_section_div<-", "TableRow", function(obj, value) { + obj@trailing_section_div <- value + obj +}) + +#' @title Section dividers getter and setter +#' +#' @description +#' `section_div` can be used to set or get the section divider for a table object +#' produced by [build_table()]. When assigned in post-processing (`section_div<-`) +#' the table can have a section divider after every row, each assigned independently. +#' If assigning during layout creation, only [split_rows_by()] (and its related row-wise +#' splits) and [analyze()] have a `section_div` parameter that will produce separators +#' between split sections and data subgroups, respectively. +#' +#' @param obj Table object. This can be of any class that inherits from `VTableTree` +#' or `TableRow`/`LabelRow`. +#' @param only_sep_sections logical(1). Defaults to `FALSE` for `section_div<-`. Allows +#' you to set the section divider only for sections that are splits or analyses if the number of +#' values is less than the number of rows in the table. If `TRUE`, the section divider will +#' be set for all rows of the table. +#' @param value character. Vector of single characters to use as section dividers. Each character +#' is repeated such that all section dividers span the width of the table. Each character that is +#' not `NA_character_` will produce a trailing separator for each row of the table. `value` length +#' should reflect the number of rows, or be between 1 and the number of splits/levels. +#' See the Details section below for more information. +#' +#' @return The section divider string. Each line that does not have a trailing separator +#' will have `NA_character_` as section divider. +#' +#' @seealso [basic_table()] parameter `header_section_div` for a global section divider. +#' +#' @details +#' Assigned value to section divider must be a character vector. If any value is `NA_character_` +#' the section divider will be absent for that row or section. When you want to only affect sections +#' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows. +#' Ideally, the length of the vector should be less than the number of splits with, eventually, the +#' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted, +#' only the first split will be affected. +#' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table +#' construction, the section divider will be set for all the splits and eventually analyses, but +#' not for the header or each row of the table. This can be set with `header_section_div` in +#' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section +#' divider will be set for all the rows of the table. +#' +#' @examples +#' # Data +#' df <- data.frame( +#' cat = c( +#' "really long thing its so ", "long" +#' ), +#' value = c(6, 3, 10, 1) +#' ) +#' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2) +#' +#' tbl <- basic_table() %>% +#' split_rows_by("cat", section_div = "~") %>% +#' analyze("value", afun = fast_afun, section_div = " ") %>% +#' build_table(df) +#' +#' # Getter +#' section_div(tbl) +#' +#' # Setter +#' section_div(tbl) <- letters[seq_len(nrow(tbl))] +#' tbl +#' +#' # last letter can appear if there is another table +#' rbind(tbl, tbl) +#' +#' # header_section_div +#' header_section_div(tbl) <- "+" +#' tbl +#' +#' @docType methods +#' @rdname section_div +#' @export +setGeneric("section_div", function(obj) standardGeneric("section_div")) + +#' @rdname section_div +#' @aliases section_div,VTableTree-method +setMethod("section_div", "VTableTree", function(obj) { + content_row_tbl <- content_table(obj) + is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL + if (labelrow_visible(obj) || is_content_table) { + section_div <- trailing_section_div(obj) + labelrow_div <- trailing_section_div(tt_labelrow(obj)) + rest_of_tree <- section_div(tree_children(obj)) + # Case it is the section itself and not the labels to have a trailing sep + if (!is.na(section_div)) { + rest_of_tree[length(rest_of_tree)] <- section_div + } + unname(c(labelrow_div, rest_of_tree)) + } else { + unname(section_div(tree_children(obj))) + } +}) +#' @rdname section_div +#' @aliases section_div,list-method +setMethod("section_div", "list", function(obj) { + unlist(lapply(obj, section_div)) +}) +#' @rdname section_div +#' @aliases section_div,TableRow-method +setMethod("section_div", "TableRow", function(obj) { + trailing_section_div(obj) +}) + +# section_div setter from table object +#' @rdname section_div +#' @export +setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) { + standardGeneric("section_div<-") +}) +#' @rdname section_div +#' @aliases section_div<-,VTableTree-method +setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) { + char_v <- as.character(value) + tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1))) + max_tree_depth <- max(tree_depths) + stopifnot(is.logical(only_sep_sections)) + .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj)) + + # Automatic establishment of intent + if (length(char_v) < nrow(obj)) { + only_sep_sections <- TRUE + } + + # Case where only separators or splits need to change externally + if (only_sep_sections && length(char_v) < nrow(obj)) { + # Case where char_v is longer than the max depth + char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))] + # Filling up with NAs the rest of the tree depth section div chr vector + missing_char_v_len <- max_tree_depth - length(char_v) + char_v <- c(char_v, rep(NA_character_, missing_char_v_len)) + } + + # Retrieving if it is a contentRow (no need for labelrow to be visible in this case) + content_row_tbl <- content_table(obj) + is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 + + # Main table structure change + if (labelrow_visible(obj) || is_content_table) { + if (only_sep_sections) { + # Only tables are modified + trailing_section_div(tt_labelrow(obj)) <- NA_character_ + trailing_section_div(obj) <- char_v[1] + section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] + } else { + # All leaves are modified + trailing_section_div(tt_labelrow(obj)) <- char_v[1] + trailing_section_div(obj) <- NA_character_ + section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] + } + } else { + section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v + } + obj +}) +#' @rdname section_div +#' @aliases section_div<-,list-method +setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) { + char_v <- as.character(value) + for (i in seq_along(obj)) { + stopifnot(is(obj[[i]], "VTableTree") || + is(obj[[i]], "TableRow") || + is(obj[[i]], "LabelRow")) + list_element_size <- nrow(obj[[i]]) + if (only_sep_sections) { + char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))] + char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i))) + } else { + init <- (i - 1) * list_element_size + 1 + chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1) + char_v_i <- char_v[chunk_of_char_v_to_take] + } + section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i + } + obj +}) +#' @rdname section_div +#' @aliases section_div<-,TableRow-method +setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) { + trailing_section_div(obj) <- value + obj +}) +#' @rdname section_div +#' @aliases section_div<-,LabelRow-method +setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) { + trailing_section_div(obj) <- value + obj +}) + +# Helper check function +.check_char_vector_for_section_div <- function(char_v, min_splits, max) { + lcv <- length(char_v) + if (lcv < 1 || lcv > max) { + stop("section_div must be a vector of length between 1 and numer of table rows.") + } + if (lcv > min_splits && lcv < max) { + warning( + "section_div will be truncated to the number of splits (", min_splits, ")", + " because it is shorter than the number of rows (", max, ")." + ) + } + nchar_check_v <- nchar(char_v) + if (any(nchar_check_v > 1, na.rm = TRUE)) { + stop("section_div must be a vector of single characters or NAs") + } +} + +#' @rdname section_div +#' @export +setGeneric("header_section_div", function(obj) standardGeneric("header_section_div")) + +#' @rdname section_div +#' @aliases header_section_div,PreDataTableLayouts-method +setMethod( + "header_section_div", "PreDataTableLayouts", + function(obj) obj@header_section_div +) +#' @rdname section_div +#' @aliases header_section_div,PreDataTableLayouts-method +setMethod( + "header_section_div", "VTableTree", + function(obj) obj@header_section_div +) + +#' @rdname section_div +#' @export +setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-")) + +#' @rdname section_div +#' @aliases header_section_div<-,PreDataTableLayouts-method +setMethod( + "header_section_div<-", "PreDataTableLayouts", + function(obj, value) { + .check_header_section_div(value) + obj@header_section_div <- value + obj + } +) +#' @rdname section_div +#' @aliases header_section_div<-,PreDataTableLayouts-method +setMethod( + "header_section_div<-", "VTableTree", + function(obj, value) { + .check_header_section_div(value) + obj@header_section_div <- value + obj + } +) +.check_header_section_div <- function(chr) { + if (!is.na(chr) && + (!is.character(chr) || + length(chr) > 1 || + nchar(chr) > 1 || + nchar(chr) == 0)) { + stop("header_section_div must be a single character or NA_character_ if not used") + } + invisible(TRUE) +} + +## table_inset ---------------------------------------------------------- #' @rdname formatters_methods #' @export setMethod( @@ -3253,7 +3522,6 @@ setMethod( function(obj) obj@table_inset ) - #' @rdname formatters_methods #' @export setMethod( @@ -3266,7 +3534,6 @@ setMethod( ## setMethod("table_inset", "InstantiatedColumnInfo", ## function(obj) obj@table_inset) - #' @rdname formatters_methods #' @export setMethod( @@ -3296,7 +3563,6 @@ setMethod( } ) - #' @rdname formatters_methods #' @export setMethod( @@ -3314,16 +3580,6 @@ setMethod( } ) -## covered now by VTableNodeInfo method - -## #' @rdname formatters_methods -## #' @export -## setMethod("table_inset<-", "TableRow", -## function(obj, value) { -## obj@table_inset <- value -## obj -## }) - #' @rdname formatters_methods #' @export setMethod( @@ -3339,59 +3595,3 @@ setMethod( obj } ) - - - -setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div")) - -setMethod( - "spl_section_div", "Split", - function(obj) obj@child_section_div -) - - -setGeneric( - "spl_section_div<-", - function(obj, value) standardGeneric("spl_section_div<-") -) - -setMethod( - "spl_section_div<-", "Split", - function(obj, value) { - obj@child_section_div <- value - obj - } -) - - - -setGeneric("trailing_sep", function(obj) standardGeneric("trailing_sep")) - -setMethod("trailing_sep", "VTableTree", function(obj) obj@trailing_section_div) - -setGeneric("trailing_sep<-", function(obj, value) standardGeneric("trailing_sep<-")) - -setMethod("trailing_sep<-", "VTableTree", function(obj, value) { - obj@trailing_section_div <- value - obj -}) - -## setGeneric("apply_kids_section_sep", -## function(tbl, sep) standardGeneric("apply_kids_section_sep")) - -## ## eleemntary tables can only have rows and they can't have -## ## trailing separators -## setMethod("apply_kids_section_sep", "ElementaryTable", -## function(tbl, sep) tbl) -## setMethod("apply_kids_section_sep", "TableTree", -## function(tbl, sep) { -## kds <- lapply(tree_children(tbl), -## function(kid) { -## if(is(kid, "VTableTree")) -## trailing_sep(kid) <- sep -## kid -## }) - -## tree_children(tbl) <- kds -## tbl -## }) diff --git a/R/tt_dotabulation.R b/R/tt_dotabulation.R index d2fae7baa..0698bcdc1 100644 --- a/R/tt_dotabulation.R +++ b/R/tt_dotabulation.R @@ -486,7 +486,8 @@ gen_rowvalues <- function(dfpart, } # Makes content table xxx renaming -.make_ctab <- function(df, lvl, ## treepos, +.make_ctab <- function(df, + lvl, ## treepos, name, label, cinfo, @@ -529,6 +530,7 @@ gen_rowvalues <- function(dfpart, call. = FALSE ) } + } else { contkids <- list() } @@ -555,8 +557,7 @@ gen_rowvalues <- function(dfpart, dolab = TRUE, lvl, baselines, - spl_context, - section_sep = NA_character_) { + spl_context) { stopifnot(is(spl, "VAnalyzeSplit")) check_validsplit(spl, df) defrlabel <- spl@default_rowlabel @@ -579,6 +580,10 @@ gen_rowvalues <- function(dfpart, ), error = function(e) e ) + + # Adding section_div for DataRows (analyze leaves) + kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow") + if (is(kids, "error")) { stop("Error applying analysis function (var - ", spl_payload(spl) %||% "colvars", "): ", kids$message, @@ -596,8 +601,7 @@ gen_rowvalues <- function(dfpart, cinfo = cinfo, format = obj_format(spl), na_str = obj_na_str(spl), - indent_mod = indent_mod(spl), - trailing_sep = section_sep + indent_mod = indent_mod(spl) ) labelrow_visible(ret) <- dolab @@ -652,14 +656,14 @@ setMethod( } ) -.set_kids_sect_sep <- function(lst, spl) { - sect_sep <- spl_section_div(spl) - if (!is.na(sect_sep)) { +# Adding section_divisors to TableRow +.set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") { + if (!is.na(trailing_section_div_char)) { lst <- lapply( lst, function(k) { - if (is(k, "VTableTree")) { - trailing_sep(k) <- sect_sep + if (is(k, allowed_class)) { + trailing_section_div(k) <- trailing_section_div_char } k } @@ -686,13 +690,9 @@ setMethod( have_controws = have_controws, make_lrow = make_lrow, spl_context = spl_context, - ..., - section_sep = spl_section_div(spl) + ... )) - - - ## XXX this seems like it should be identical not !identical ## TODO FIXME if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) { @@ -724,7 +724,6 @@ setMethod( }, k = kids, nm = labs, SIMPLIFY = FALSE) nms <- labs } - kids <- .set_kids_sect_sep(kids, spl) nms[is.na(nms)] <- "" @@ -941,10 +940,14 @@ setMethod( splval = splvals, SIMPLIFY = FALSE )) - - inner <- .set_kids_sect_sep(inner, spl) + + # Setting the kids section separator if they inherits VTableTree + inner <- .set_kids_section_div(inner, + trailing_section_div_char = spl_section_div(spl), + allowed_class = "VTableTree") + ## This is where we need to build the structural tables - ## even if they are invisible becasue their labels are not + ## even if they are invisible because their labels are not ## not shown. innertab <- TableTree( kids = inner, @@ -1046,7 +1049,6 @@ recursive_applysplit <- function(df, spl_context = spl_context ) - nonroot <- lvl != 0L if (is.na(make_lrow)) { @@ -1108,7 +1110,6 @@ recursive_applysplit <- function(df, ## previously we checked if the child had an identical label ## but I don't think thats needed anymore. tlabel <- partlabel - ret <- TableTree( cont = ctab, kids = kids, @@ -1335,6 +1336,7 @@ build_table <- function(lyt, df, subtitles(tab) <- subtitles(lyt) main_footer(tab) <- main_footer(lyt) prov_footer(tab) <- prov_footer(lyt) + header_section_div(tab) <- header_section_div(lyt) } else { tab <- TableTree( cont = ctab, @@ -1349,7 +1351,8 @@ build_table <- function(lyt, df, title = main_title(lyt), subtitles = subtitles(lyt), main_footer = main_footer(lyt), - prov_footer = prov_footer(lyt) + prov_footer = prov_footer(lyt), + header_section_div = header_section_div(lyt) ) } diff --git a/R/tt_paginate.R b/R/tt_paginate.R index fb3f5143b..059c1bf07 100644 --- a/R/tt_paginate.R +++ b/R/tt_paginate.R @@ -12,9 +12,6 @@ - - - #' @exportMethod nlines #' @inheritParams formatters::nlines #' @name formatters_methods @@ -207,8 +204,8 @@ setMethod( ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint path <- c(path, obj_name(tt)) } - ret <- list() + ## note this is the **table** not the label row if (!visible_only) { ret <- c( @@ -257,8 +254,10 @@ setMethod( if (NROW(content_table(tt)) > 0) { - cind <- indent + indent_mod(content_table(tt)) - contdf <- make_row_df(content_table(tt), + ct_tt <- content_table(tt) + cind <- indent + indent_mod(ct_tt) + trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt)) + contdf <- make_row_df(ct_tt, colwidths = colwidths, visible_only = visible_only, rownum = rownum, @@ -307,8 +306,10 @@ setMethod( } ret <- do.call(rbind, ret) - if (!is.na(trailing_sep(tt))) { - ret$trailing_sep[nrow(ret)] <- trailing_sep(tt) + + # Case where it has Elementary table or VTableTree section_div it is overridden + if (!is.na(trailing_section_div(tt))) { + ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt) } ret } @@ -349,7 +350,8 @@ setMethod( ## these two are unlist calls cause they come in lists even with no footnotes nrowrefs = length(rrefs), ncellrefs = length(unlist(crefs)), - nreflines = reflines + nreflines = reflines, + trailing_sep = trailing_section_div(tt) ) ret } @@ -387,10 +389,11 @@ setMethod( nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_, colwidths = colwidths, max_width = max_width - )) + )), + trailing_sep = trailing_section_div(tt) ) if (!labelrow_visible(tt)) { - ret <- ret[0, ] + ret <- ret[0, , drop = FALSE] } ret } diff --git a/R/tt_toString.R b/R/tt_toString.R index e10bb98e2..bbbcd6987 100644 --- a/R/tt_toString.R +++ b/R/tt_toString.R @@ -339,6 +339,7 @@ setMethod( main_footer = main_footer(obj), prov_footer = prov_footer(obj), table_inset = table_inset(obj), + header_section_div = header_section_div(obj), indent_size = indent_size ) } diff --git a/_pkgdown.yml b/_pkgdown.yml index 408023e5c..37f8ee873 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -23,6 +23,8 @@ navbar: href: articles/dev-guide/dg_tabulation.html - text: Debugging in {rtables} and Beyond href: articles/dev-guide/dg_debug_rtables.html + - text: Sparse notes on {rtables} internals + href: articles/dev-guide/dg_notes.html repo: url: @@ -81,6 +83,7 @@ articles: - 'dev-guide/dg_split_machinery' - 'dev-guide/dg_tabulation' - 'dev-guide/dg_debug_rtables' + - 'dev-guide/dg_notes' reference: - title: Argument Conventions @@ -178,6 +181,7 @@ reference: - brackets - clear_indent_mods - head + - section_div - title: Validating and Fixing Table Structure contents: diff --git a/man/avarspl.Rd b/man/avarspl.Rd index 91f1d29c6..53c66e6af 100644 --- a/man/avarspl.Rd +++ b/man/avarspl.Rd @@ -20,7 +20,8 @@ AnalyzeVarSplit( extra_args = list(), indent_mod = 0L, label_pos = "default", - cvar = "" + cvar = "", + section_div = NA_character_ ) AnalyzeColVarSplit( @@ -35,7 +36,8 @@ AnalyzeColVarSplit( extra_args = list(), indent_mod = 0L, label_pos = "default", - cvar = "" + cvar = "", + section_div = NA_character_ ) AnalyzeMultiVars( @@ -110,6 +112,10 @@ multiple variables are analyzed at the same level of nesting.} \item{cvar}{character(1). The variable, if any, which the content function should accept. Defaults to NA.} +\item{section_div}{character(1). String which should be repeated as a section +divider after each group defined by this split instruction, or +\code{NA_character_} (the default) for no section divider.} + \item{.payload}{Used internally, not intended to be set by end users.} \item{child_labels}{string. One of \code{"default"}, \code{"visible"}, @@ -119,10 +125,6 @@ which flags the label row as visible only if the child has 0 content rows.} \item{child_names}{character. Names to be given to the sub splits contained by a compound split (typically a \code{AnalyzeMultiVars} split object).} - -\item{section_div}{character(1). String which should be repeated as a section -divider after each group defined by this split instruction, or -\code{NA_character_} (the default) for no section divider.} } \value{ An \code{AnalyzeVarSplit} object. diff --git a/man/basic_table.Rd b/man/basic_table.Rd index 258ea3e60..2b38a189b 100644 --- a/man/basic_table.Rd +++ b/man/basic_table.Rd @@ -9,6 +9,7 @@ basic_table( subtitles = character(), main_footer = character(), prov_footer = character(), + header_section_div = NA_character_, show_colcounts = FALSE, colcount_format = "(N=xx)", inset = 0L @@ -29,6 +30,11 @@ lines.} (\code{\link[=prov_footer]{prov_footer()}}). It can be also a vector of strings, printed on different lines. Generally should not be modified by hand.} +\item{header_section_div}{character(1). String which will be used to divide the header +from the table. See \code{\link[=header_section_div]{header_section_div()}} for getter and setter of these. +Please consider changing last element of \code{\link[=section_div]{section_div()}} when concatenating +tables that need a divider between them.} + \item{show_colcounts}{logical(1). Should column counts be displayed in the resulting table when this layout is applied to data} diff --git a/man/constr_args.Rd b/man/constr_args.Rd index b744a99b7..fd307ed03 100644 --- a/man/constr_args.Rd +++ b/man/constr_args.Rd @@ -27,11 +27,12 @@ constr_args( page_title, page_prefix, section_div, - trailing_sep, + trailing_section_div, split_na_str, cna_str, inset, - table_inset + table_inset, + header_section_div ) } \arguments{ @@ -102,7 +103,7 @@ when forcing pagination between the children of this split/table} divider after each group defined by this split instruction, or \code{NA_character_} (the default) for no section divider.} -\item{trailing_sep}{character(1). String which will be used as a section +\item{trailing_section_div}{character(1). String which will be used as a section divider after the printing of the last row contained in this (sub)-table, unless that row is also the last table row to be printed overall, or \code{NA_character_} for none (the default). When generated via layouting, this @@ -121,6 +122,11 @@ of title, subtitle, and provenance footer. Defaults to 0 (no inset).} \item{table_inset}{numeric(1). Number of spaces to inset the table header, table body, referential footnotes, and main_footer, as compared to alignment of title, subtitle, and provenance footer. Defaults to 0 (no inset).} + +\item{header_section_div}{character(1). String which will be used to divide the header +from the table. See \code{\link[=header_section_div]{header_section_div()}} for getter and setter of these. +Please consider changing last element of \code{\link[=section_div]{section_div()}} when concatenating +tables that need a divider between them.} } \value{ NULL (this is an argument template dummy function) diff --git a/man/rowclasses.Rd b/man/rowclasses.Rd index fe2fffe49..f928b6a09 100644 --- a/man/rowclasses.Rd +++ b/man/rowclasses.Rd @@ -18,7 +18,8 @@ LabelRow( vis = !is.na(label) && nzchar(label), cinfo = EmptyColInfo, indent_mod = 0L, - table_inset = 0L + table_inset = 0L, + trailing_section_div = NA_character_ ) .tablerow( @@ -34,7 +35,8 @@ LabelRow( klass, indent_mod = 0L, footnotes = list(), - table_inset = 0L + table_inset = 0L, + trailing_section_div = NA_character_ ) DataRow(...) @@ -65,6 +67,13 @@ corresponds to the unmodified default behavior.} body, referential footnotes, and main_footer, as compared to alignment of title, subtitle, and provenance footer. Defaults to 0 (no inset).} +\item{trailing_section_div}{character(1). String which will be used as a section +divider after the printing of the last row contained in this (sub)-table, +unless that row is also the last table row to be printed overall, or +\code{NA_character_} for none (the default). When generated via layouting, this +would correspond to the \code{section_div} of the split under which this table +represents a single facet.} + \item{vals}{list. cell values for the row} \item{cspan}{integer. Column span. \code{1} indicates no spanning.} diff --git a/man/section_div.Rd b/man/section_div.Rd new file mode 100644 index 000000000..acaf5a750 --- /dev/null +++ b/man/section_div.Rd @@ -0,0 +1,124 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tree_accessors.R +\docType{methods} +\name{section_div} +\alias{section_div} +\alias{section_div,VTableTree-method} +\alias{section_div,list-method} +\alias{section_div,TableRow-method} +\alias{section_div<-} +\alias{section_div<-,VTableTree-method} +\alias{section_div<-,list-method} +\alias{section_div<-,TableRow-method} +\alias{section_div<-,LabelRow-method} +\alias{header_section_div} +\alias{header_section_div,PreDataTableLayouts-method} +\alias{header_section_div,VTableTree-method} +\alias{header_section_div<-} +\alias{header_section_div<-,PreDataTableLayouts-method} +\alias{header_section_div<-,VTableTree-method} +\title{Section dividers getter and setter} +\usage{ +section_div(obj) + +\S4method{section_div}{VTableTree}(obj) + +\S4method{section_div}{list}(obj) + +\S4method{section_div}{TableRow}(obj) + +section_div(obj, only_sep_sections = FALSE) <- value + +\S4method{section_div}{VTableTree}(obj, only_sep_sections = FALSE) <- value + +\S4method{section_div}{list}(obj, only_sep_sections = FALSE) <- value + +\S4method{section_div}{TableRow}(obj, only_sep_sections = FALSE) <- value + +\S4method{section_div}{LabelRow}(obj, only_sep_sections = FALSE) <- value + +header_section_div(obj) + +\S4method{header_section_div}{PreDataTableLayouts}(obj) + +\S4method{header_section_div}{VTableTree}(obj) + +header_section_div(obj) <- value + +\S4method{header_section_div}{PreDataTableLayouts}(obj) <- value + +\S4method{header_section_div}{VTableTree}(obj) <- value +} +\arguments{ +\item{obj}{Table object. This can be of any class that inherits from \code{VTableTree} +or \code{TableRow}/\code{LabelRow}.} + +\item{only_sep_sections}{logical(1). Defaults to \code{FALSE} for \verb{section_div<-}. Allows +you to set the section divider only for sections that are splits or analyses if the number of +values is less than the number of rows in the table. If \code{TRUE}, the section divider will +be set for all rows of the table.} + +\item{value}{character. Vector of single characters to use as section dividers. Each character +is repeated such that all section dividers span the width of the table. Each character that is +not \code{NA_character_} will produce a trailing separator for each row of the table. \code{value} length +should reflect the number of rows, or be between 1 and the number of splits/levels. +See the Details section below for more information.} +} +\value{ +The section divider string. Each line that does not have a trailing separator +will have \code{NA_character_} as section divider. +} +\description{ +\code{section_div} can be used to set or get the section divider for a table object +produced by \code{\link[=build_table]{build_table()}}. When assigned in post-processing (\verb{section_div<-}) +the table can have a section divider after every row, each assigned independently. +If assigning during layout creation, only \code{\link[=split_rows_by]{split_rows_by()}} (and its related row-wise +splits) and \code{\link[=analyze]{analyze()}} have a \code{section_div} parameter that will produce separators +between split sections and data subgroups, respectively. +} +\details{ +Assigned value to section divider must be a character vector. If any value is \code{NA_character_} +the section divider will be absent for that row or section. When you want to only affect sections +or splits, please use \code{only_sep_sections} or provide a shorter vector than the number of rows. +Ideally, the length of the vector should be less than the number of splits with, eventually, the +leaf-level, i.e. \code{DataRow} where analyze results are. Note that if only one value is inserted, +only the first split will be affected. +If \code{only_sep_sections = TRUE}, which is the default for \code{section_div()} produced from the table +construction, the section divider will be set for all the splits and eventually analyses, but +not for the header or each row of the table. This can be set with \code{header_section_div} in +\code{\link[=basic_table]{basic_table()}} or, eventually, with \code{hsep} in \code{\link[=build_table]{build_table()}}. If \code{FALSE}, the section +divider will be set for all the rows of the table. +} +\examples{ +# Data +df <- data.frame( + cat = c( + "really long thing its so ", "long" + ), + value = c(6, 3, 10, 1) +) +fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2) + +tbl <- basic_table() \%>\% + split_rows_by("cat", section_div = "~") \%>\% + analyze("value", afun = fast_afun, section_div = " ") \%>\% + build_table(df) + +# Getter +section_div(tbl) + +# Setter +section_div(tbl) <- letters[seq_len(nrow(tbl))] +tbl + +# last letter can appear if there is another table +rbind(tbl, tbl) + +# header_section_div +header_section_div(tbl) <- "+" +tbl + +} +\seealso{ +\code{\link[=basic_table]{basic_table()}} parameter \code{header_section_div} for a global section divider. +} diff --git a/man/tabclasses.Rd b/man/tabclasses.Rd index 0ed2e41ec..2c74806b8 100644 --- a/man/tabclasses.Rd +++ b/man/tabclasses.Rd @@ -26,8 +26,9 @@ ElementaryTable( subtitles = character(), main_footer = character(), prov_footer = character(), + header_section_div = NA_character_, hsep = default_hsep(), - trailing_sep = NA_character_, + trailing_section_div = NA_character_, inset = 0L ) @@ -52,7 +53,8 @@ TableTree( prov_footer = character(), page_title = NA_character_, hsep = default_hsep(), - trailing_sep = NA_character_, + header_section_div = NA_character_, + trailing_section_div = NA_character_, inset = 0L ) } @@ -107,12 +109,17 @@ lines.} (\code{\link[=prov_footer]{prov_footer()}}). It can be also a vector of strings, printed on different lines. Generally should not be modified by hand.} +\item{header_section_div}{character(1). String which will be used to divide the header +from the table. See \code{\link[=header_section_div]{header_section_div()}} for getter and setter of these. +Please consider changing last element of \code{\link[=section_div]{section_div()}} when concatenating +tables that need a divider between them.} + \item{hsep}{character(1). Set of character(s) to be repeated as the separator between the header and body of the table when rendered as text. Defaults to a connected horizontal line (unicode 2014) in locals that use a UTF charset, and to \code{-} elsewhere (with a once per session warning).} -\item{trailing_sep}{character(1). String which will be used as a section +\item{trailing_section_div}{character(1). String which will be used as a section divider after the printing of the last row contained in this (sub)-table, unless that row is also the last table row to be printed overall, or \code{NA_character_} for none (the default). When generated via layouting, this diff --git a/tests/testthat/test-accessors.R b/tests/testthat/test-accessors.R index 212224cde..e334e9982 100644 --- a/tests/testthat/test-accessors.R +++ b/tests/testthat/test-accessors.R @@ -223,3 +223,185 @@ test_that("header sep setting works", { horizontal_sep(tbl2) <- "=" hsep_test(tbl2, "=") }) + +# section_div tests ------------------------------------------------------------ +check_pattern <- function(element, letter, len) { + # Regular expression to match exactly len of the same letter + regex <- paste0(rep(letter, len), collapse = "") + return(grepl(regex, element, fixed = TRUE)) +} + +test_structure_with_a_getter <- function(tbl, getter, val_per_lev) { + # Main table obj + expect_identical(tbl %>% getter(), val_per_lev$global) + # Its labelrow (could be also not visible) + expect_identical(tt_labelrow(tbl) %>% getter(), val_per_lev$global_labelrow) + + # First split row + its labels + split1 <- tree_children(tbl)[[1]] + expect_identical(split1 %>% getter(), val_per_lev$split) + expect_identical(tt_labelrow(split1) %>% getter(), val_per_lev$split_labelrow) + + # Content table checks if there + content_elem_tbl <- content_table(split1) + if (nrow(content_elem_tbl) > 0) { + expect_identical(content_elem_tbl %>% getter(), val_per_lev$content) + expect_identical(tt_labelrow(content_elem_tbl) %>% getter(), val_per_lev$content_labelrow) + expect_identical(tree_children(content_elem_tbl)[[1]] %>% getter(), val_per_lev$contentrow) + } + + # The elementary table has it? + leaves_elementary_tbl <- tree_children(split1)[[1]] + expect_identical(leaves_elementary_tbl %>% getter(), val_per_lev$elem_tbl) + expect_identical(tt_labelrow(leaves_elementary_tbl) %>% getter(), val_per_lev$elem_tbl_labelrow) + + # Data rows has it? + for (i in 1:nrow(leaves_elementary_tbl)) { + expect_identical(tree_children(leaves_elementary_tbl)[[i]] %>% getter(), val_per_lev$datarow[i]) + } +} + +test_that("section_div getter and setter works", { + df <- data.frame( + cat = c( + "re", "long" + ), + value = c(6, 3, 10, 1) + ) + fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2) + + tbl <- basic_table() %>% + split_rows_by("cat", section_div = "~") %>% + analyze("value", afun = fast_afun, section_div = " ") %>% + build_table(df) + + tbl_content <- basic_table() %>% + split_rows_by("cat", section_div = "~") %>% + summarize_row_groups() %>% # This makes them not visible + analyze("value", afun = fast_afun, section_div = " ") %>% + build_table(df) + + val_per_lev <- list( + "global" = NA_character_, + "global_labelrow" = NA_character_, + "split" = "~", + "split_labelrow" = NA_character_, + "content" = NA_character_, # If there is a summarize_row_groups this is present + "contentrow" = NA_character_, + "content_labelrow" = NA_character_, + "elem_tbl_labelrow" = NA_character_, + "datarow" = c(" ", " ") + ) + + # Checks of structure - precedence is top to bottom + test_structure_with_a_getter(tbl, + getter = trailing_section_div, + val_per_lev = val_per_lev + ) + test_structure_with_a_getter(tbl_content, + getter = trailing_section_div, + val_per_lev = val_per_lev + ) + + + # Checks that section div and printing works together + expect_identical(section_div(tbl), make_row_df(tbl)$trailing_sep) + expect_identical(section_div(tbl_content), make_row_df(tbl_content)$trailing_sep) + + # MAIN assignment setter - this is clean, i.e. is only node base and not real section div + section_div(tbl) <- section_div(tbl_content) <- letters[seq_len(nrow(tbl))] + + val_per_lev <- list( + "global" = NA_character_, + "global_labelrow" = NA_character_, + "split" = NA_character_, + "split_labelrow" = "a", + "content" = NA_character_, + "contentrow" = NA_character_, + "content_labelrow" = NA_character_, + "elem_tbl_labelrow" = NA_character_, + "datarow" = c("b", "c") + ) + + # Checks of structure - precedence is top to bottom + test_structure_with_a_getter(tbl, + getter = trailing_section_div, + val_per_lev = val_per_lev + ) + test_structure_with_a_getter(tbl_content, + getter = trailing_section_div, + val_per_lev = val_per_lev + ) + + # Checks that section div and printing works together + expect_identical(section_div(tbl), make_row_df(tbl)$trailing_sep) + expect_identical(section_div(tbl_content), make_row_df(tbl_content)$trailing_sep) + + separators <- strsplit(toString(tbl, widths = c(4, 10)), "\n")[[1]][c(4, 6, 9, 11, 13)] + separators2 <- strsplit(toString(tbl_content, widths = c(4, 10)), "\n")[[1]][c(4, 6, 9, 11, 13)] + expect_identical(separators, separators2) + + + mapply(separators, + FUN = check_pattern, + letter = letters[seq_len(nrow(tbl) - 1)], # -1 is the table end + len = 17 + ) %>% + all() %>% + expect_true() +}) + +test_that("the split only setter works", { + fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2) + + tbl <- basic_table() %>% + split_rows_by("ARM", section_div = "=") %>% + split_rows_by("STRATA1", section_div = "-") %>% + analyze("BMRKR1") %>% + build_table(DM) + + replace_sec_div <- section_div(tbl) + replace_sec_div[replace_sec_div == "="] <- "a" + replace_sec_div[replace_sec_div == "-"] <- "b" + section_div(tbl) <- c("a", "b") + expect_identical(section_div(tbl), replace_sec_div) + + # multiple analyze + tbl <- basic_table(header_section_div = " ") %>% + split_cols_by("ARM") %>% + split_rows_by("SEX", split_fun = drop_split_levels) %>% + analyze("AGE") %>% + split_rows_by("RACE", split_fun = drop_split_levels) %>% + split_rows_by("SEX", split_fun = drop_split_levels) %>% + analyze("AGE") %>% + build_table(DM) + tbl2 <- tbl + section_div(tbl) <- c("-", NA_character_) + section_div(tbl2) <- c("-") + expect_identical( + section_div(tbl)[seq_len(6)], + c(NA_character_, "-", NA_character_, "-", NA_character_, NA_character_) + ) + expect_identical( + section_div(tbl), + section_div(tbl2) + ) +}) + + +test_that("header_section_div works", { + lyt <- basic_table(header_section_div = "+") %>% + split_rows_by("STRATA1") %>% + analyze("BMRKR1") + expect_identical(header_section_div(lyt), "+") + header_section_div(lyt) <- "<" + expect_identical(header_section_div(lyt), "<") + + tbl <- lyt %>% build_table(DM) + expect_identical(header_section_div(tbl), "<") + header_section_div(tbl) <- "+" + expect_identical(header_section_div(tbl), "+") + header_sdiv <- strsplit(toString(tbl), "\n")[[1]][3] + + expect_true(check_pattern(header_sdiv, "+", nchar(header_sdiv))) +}) diff --git a/tests/testthat/test-printing.R b/tests/testthat/test-printing.R index 5ea93745e..e944e1553 100644 --- a/tests/testthat/test-printing.R +++ b/tests/testthat/test-printing.R @@ -681,3 +681,61 @@ test_that("Support for newline characters in all the parts", { out <- strsplit(export_as_txt(tt_for_nl, file = NULL, hsep = "-"), "\\n")[[1]] expect_identical(out, expected) }) + +test_that("Separators and wrapping work together with getter and setters", { + ## formatters#221 (bug with wrapping) and #762 (analyze allows it) + df <- data.frame( + cat = c( + "really long thing its so ", "long" + ), + value = c(6, 3, 10, 1) + ) + fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2) + + lyt <- basic_table() %>% + split_rows_by("cat", section_div = "~") + + lyt1 <- lyt %>% + analyze("value", afun = fast_afun, section_div = " ") + + lyt2 <- lyt %>% + summarize_row_groups() %>% + analyze("value", afun = fast_afun, section_div = " ") + + tbl1 <- build_table(lyt1, df) + tbl2 <- build_table(lyt2, df) + mf1 <- matrix_form(tbl1) + mf2 <- matrix_form(tbl2) + expect_identical(mf1$row_info$trailing_sep, mf2$row_info$trailing_sep) + expect_identical(mf1$row_info$trailing_sep, rep(c(NA, " ", "~"), 2)) + + exp1 <- c( + " all obs", + "———————————————————", + "really ", + "long ", + "thing its ", + "so ", + " m 8 ", + " ", + " m/2 5 ", + "~~~~~~~~~~~~~~~~~~~", + "long ", + " m 2 ", + " ", + " m/2 1.5 " + ) + + cw <- propose_column_widths(tbl1) + cw[1] <- ceiling(cw[1] / 3) + expect_identical(strsplit(toString(tbl1, widths = cw), "\n")[[1]], exp1) + + # setter and getter + a_sec_div <- section_div(tbl1) + a_sec_div[1] <- "a" + section_div(tbl1) <- a_sec_div + expect_identical( + strsplit(toString(tbl1[seq_len(2), ]), "\\n")[[1]][4], + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + ) +}) diff --git a/vignettes/dev-guide/dg_notes.Rmd b/vignettes/dev-guide/dg_notes.Rmd new file mode 100644 index 000000000..f162bb7a0 --- /dev/null +++ b/vignettes/dev-guide/dg_notes.Rmd @@ -0,0 +1,148 @@ +--- +title: "Sparse notes on {rtables} internals" +author: "Davide Garolini" +date: '`r Sys.Date()`' +output: + html_document: + theme: spacelab + toc: true + toc_float: + collapsed: false +editor_options: + chunk_output_type: console +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(echo = TRUE) +``` + + +## Disclaimer +This is a collection of notes divided by issues and it is a working document that will end up being a dev vignette one day. + + +## `section_div` notes + +Everything in the layout is built over split objects, that reside in `00_tabletrees.R`. There `section_div` is defined internally in each split object as `child_section_div` and assigned to `NA_character` as default. This needs to be in all split objects that need to have a separator divisor. Object-wise, the virtual class `Split` contains `section_div` and it has the following subclasses. I tagged with "X" constructor that allows for `section_div` to be assigned to a value different than `NA_character`, and "NX" otherwise. + +```{r} +library(rtables) +getClass("Split") +# Known Subclasses: +#? Class "CustomizableSplit", directly # vclass used for grouping different split types (I guess) +# Class "AllSplit", directly # NX +# Class "VarStaticCutSplit", directly # X via make_static_cut_split +# Class "VarDynCutSplit", directly # X +# Class "VAnalyzeSplit", directly # X +#? Class "CompoundSplit", directly # Used only for AnalyzeMultiVars (maybe not needed?) +# Class "VarLevelSplit", by class "CustomizableSplit", distance 2 # X +# Class "MultiVarSplit", by class "CustomizableSplit", distance 2 # X +# Class "RootSplit", by class "AllSplit", distance 2 # NX +# Class "ManualSplit", by class "AllSplit", distance 2 # X +# Class "CumulativeCutSplit", by class "VarStaticCutSplit", distance 2 # X via make_static_cut_split +# Class "AnalyzeVarSplit", by class "VAnalyzeSplit", distance 2 # Virtual +# Class "AnalyzeColVarSplit", by class "VAnalyzeSplit", distance 2 # X +# Class "AnalyzeMultiVars", by class "CompoundSplit", distance 2 # X +# Class "VarLevWBaselineSplit", by class "VarLevelSplit", distance 3 # NX +``` + +This can be updated only by related layout functions. The most important, that are covered by tests are `analyze` and `split_rows_by`. + +Now it is relevant to understand where this information is saved in the table object built by `build_table`. To do that we need to see where it is present and how it is assigned. Let's go back to `00tabletree.R`and look for `trailing_section_div`. As classes definitions goes, you will notice from the search that `trailing_section_div` is present in the virtual classes `TableRow` and `VTableTree`. In the following is the class hierarchy that makes `trailing_section_div: + +```{r} +getClass("TableRow") +# Extends: +# Class "VLeaf", directly +# Class "VTableNodeInfo", directly +# Class "VNodeInfo", by class "VLeaf", distance 2 +# +# Known Subclasses: "DataRow", "ContentRow", "LabelRow" + +getClass("VTableTree") +# Extends: +# Class "VTableNodeInfo", directly +# Class "VTree", directly +# Class "VTitleFooter", directly +# Class "VNodeInfo", by class "VTableNodeInfo", distance 2 +# +# Known Subclasses: "ElementaryTable", "TableTree" +``` + +Always check the constructors after finding the classes. In the above case for example, the `DataRow` and `ContentRow` share the constructor, so we do not need to add identical getter and setters for these two classes but only for the virtual class `TableRow`. Different is the story for `LabelRow` which needs to be handle differently. Now, to understand why only these two have this feature, lets see the structure of a table built with section dividers: + +```{r} +lyt <- basic_table() %>% + split_rows_by("ARM", section_div = "+") %>% + split_rows_by("STRATA1", section_div = "") %>% + analyze("AGE", + afun = function(x) list("Mean" = mean(x), "Standard deviation" = sd(x)), + format = list("Mean" = "xx.", "Standard deviation" = "xx."), + section_div = "~") + +tbl <- build_table(lyt, DM) + +print(tbl) +print(class(tbl)) # TableTree +# methods("trailing_section_div") # to see this please do devtools::load_all() +# [1] trailing_section_div,LabelRow-method +# trailing_section_div,TableRow-method +# trailing_section_div,VTableTree-method +``` + +In the above, we show that `trailing_section_div` has methods for `TableRow` virtual object, `LabelRow`, and `VTableTree`. These three make the whole `section_div` structure as the `VTableTree` is present in `TableTree` and `ElementaryTable` that are the two main table objects. If these are not `NA_character_` then the `section_div` is printed at split divisions. The `LabelRow` and `TableRow` are different as their assignment allows the row-wise modification of separators. When we have a special case for a `ContentRow`, as it is represented as `content_table(obj)` which is a one-line `ElementaryTable`, while label row is turned off. Please take a moment to check the following setter: + +```r{eval=FALSE} +setMethod("section_div<-", "VTableTree", function(obj, value, only_sep_sections = FALSE) { + char_v <- as.character(value) + tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1))) + max_tree_depth <- max(tree_depths) + stopifnot(is.logical(only_sep_sections)) + .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj)) + + # Automatic establishment of intent + if (length(char_v) < nrow(obj)) { + only_sep_sections <- TRUE + } + + # Case where only separators or splits need to change externally + if (only_sep_sections && length(char_v) < nrow(obj)) { + if (length(char_v) == 1) { + char_v <- rep(char_v, max_tree_depth - 1) # -1 is the data row + } + # Case where char_v is longer than the max depth + char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))] + # Filling up with NAs the rest of the tree depth section div chr vector + missing_char_v_len <- max_tree_depth - length(char_v) + char_v <- c(char_v, rep(NA_character_, missing_char_v_len)) + # char_v <- unlist( + # lapply(tree_depths, function(tree_depth_i) char_v[seq_len(tree_depth_i)]), + # use.names = FALSE + # ) + } + + # Retrieving if it is a contentRow (no need for labelrow to be visible in this case) + content_row_tbl <- content_table(obj) + is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 + + # Main table structure change + if (labelrow_visible(obj) || is_content_table) { + if (only_sep_sections) { + # Only tables are modified + trailing_section_div(tt_labelrow(obj)) <- NA_character_ + trailing_section_div(obj) <- char_v[1] + section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] + } else { + # All leaves are modified + trailing_section_div(tt_labelrow(obj)) <- char_v[1] + trailing_section_div(obj) <- NA_character_ + section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] + } + } else { + section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v + } + obj +}) +``` + +`only_sep_sections` is a parameter that is used to change only the separators (between splits) and not the data rows. It is happening forcefully if set to `TRUE`, but it is automatically activated when `section_div(tbl) <- char_v` is a character vector of length `< nrow(tbl)`. Notice that the exception for `ContentRow` is activated by the switcher `is_content_table`. This is because content rows do not have visible label row. You see that in the main table structure change we have two blocks depending on `only_sep_sections`. If `TRUE` only the `VTableTree` are modified leading to only split section separators to be modified. Also consider looking at `section_div` getter and tests in `test-accessors.R` to have more insights on the structure. Also to understand exactly how this is bound to output, please check the result of `make_row_df()` for the column `trailing_sep`. Indeed, an alternative and iterative method is used by `make_row_df` to retrieve the information about the separators for each table row. Being it a trailing separator by definition, we added `header_section_div` as a function and a parameter of `basic_table`, so to possibly add an empty line after the header (e.g. `header_section_div(tbl) = " "`). This is not a trailing separator, but it is a separator that is added after the header. To close the circle, please check how `trailing_sep` and `header_section_div` is propagated and printed/used in `formatters::toString`. From b1977a0de2aa62f6c949b09833a95c825a1f387a Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 24 Nov 2023 08:47:50 +0000 Subject: [PATCH 11/27] [skip actions] Bump version to 0.6.5.9014 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 021a4eb28..038d1c42d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9013 -Date: 2023-11-23 +Version: 0.6.5.9014 +Date: 2023-11-24 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 83df355e5..222229f34 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9013 +## rtables 0.6.5.9014 ### 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` From d16d6d100d46422841988bac562e041162d5d2b0 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Mon, 27 Nov 2023 10:01:31 +0100 Subject: [PATCH 12/27] `hsep` propagation fix (#789) * coming from formatters * small fixes * news * adding more info * newline fix --- NEWS.md | 1 + R/argument_conventions.R | 3 ++- R/tt_toString.R | 6 ++---- man/build_table.Rd | 3 ++- man/export_as_pdf.Rd | 8 +++++--- man/gen_args.Rd | 3 ++- man/paginate.Rd | 4 ++-- man/rtable.Rd | 3 ++- man/tabclasses.Rd | 3 ++- man/table_shell.Rd | 16 +++++++++++----- man/tostring.Rd | 18 ++++++++++++------ man/tt_to_flextable.Rd | 4 ++-- tests/testthat/test-printing.R | 17 +++++++++++++++++ 13 files changed, 62 insertions(+), 27 deletions(-) diff --git a/NEWS.md b/NEWS.md index 222229f34..afb220b1f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -19,6 +19,7 @@ * Whitespace is not trimmed when rendering tables with `as_html`. * Started deprecation cycle for `col_fnotes_here` to be replaced with `col_footnotes`. * Exported `section_div` methods now have a dedicated documentation page that is visible to users. + * When tables are exported as `txt`, they preserve the horizontal separator of the table. ## rtables 0.6.5 ### New Features diff --git a/R/argument_conventions.R b/R/argument_conventions.R index 70c6cd964..bcc7c1bd5 100644 --- a/R/argument_conventions.R +++ b/R/argument_conventions.R @@ -53,7 +53,8 @@ NULL #' @param hsep character(1). Set of character(s) to be repeated as the separator #' between the header and body of the table when rendered as text. Defaults to #' a connected horizontal line (unicode 2014) in locals that use a UTF -#' charset, and to `-` elsewhere (with a once per session warning). +#' charset, and to `-` elsewhere (with a once per session warning). See +#' [formatters::set_default_hsep()] for further information. #' @param indent_size numeric(1). Number of spaces to use per indent level. #' Defaults to 2 #' @param section_div character(1). String which should be repeated as a section diff --git a/R/tt_toString.R b/R/tt_toString.R index bbbcd6987..2f46d5510 100644 --- a/R/tt_toString.R +++ b/R/tt_toString.R @@ -19,12 +19,9 @@ NULL #' Convert an `rtable` object to a string #' +#' @inheritParams formatters::toString #' @inheritParams gen_args #' @inherit formatters::toString -#' @param x table object -#' @param widths widths of row.name and columns -#' @param col_gap gap between columns -#' @param hsep character to create line separator #' @exportMethod toString #' #' @return a string representation of \code{x} as it appears when printed. @@ -340,6 +337,7 @@ setMethod( prov_footer = prov_footer(obj), table_inset = table_inset(obj), header_section_div = header_section_div(obj), + horizontal_sep = horizontal_sep(obj), indent_size = indent_size ) } diff --git a/man/build_table.Rd b/man/build_table.Rd index 3e1cc9528..353a35a4d 100644 --- a/man/build_table.Rd +++ b/man/build_table.Rd @@ -38,7 +38,8 @@ displayed during printing.} \item{hsep}{character(1). Set of character(s) to be repeated as the separator between the header and body of the table when rendered as text. Defaults to a connected horizontal line (unicode 2014) in locals that use a UTF -charset, and to \code{-} elsewhere (with a once per session warning).} +charset, and to \code{-} elsewhere (with a once per session warning). See +\code{\link[formatters:default_horizontal_sep]{formatters::set_default_hsep()}} for further information.} \item{\dots}{currently ignored.} } diff --git a/man/export_as_pdf.Rd b/man/export_as_pdf.Rd index 7af03060a..df34fc3c8 100644 --- a/man/export_as_pdf.Rd +++ b/man/export_as_pdf.Rd @@ -78,7 +78,9 @@ this is calculated automatically based on the specified page size). \code{NULL} indicates no horizontal pagination should occur.} \item{hsep}{character(1). Characters to repeat to create -header/body separator line.} +header/body separator line. If \code{NULL}, the object value will be +used. If \code{" "}, an empty separator will be printed. Check \code{\link[formatters:default_hsep]{default_hsep()}} +for more information.} \item{indent_size}{numeric(1). Indent size in characters. Ignored when \code{x} is already a \code{MatrixPrintForm} object in favor of information @@ -87,9 +89,9 @@ there.} \item{tf_wrap}{logical(1). Should the texts for title, subtitle, and footnotes be wrapped?} -\item{max_width}{integer(1), character(1) or NULL. Width that title +\item{max_width}{integer(1), character(1) or \code{NULL}. Width that title and footer (including footnotes) materials should be -word-wrapped to. If NULL, it is set to the current print width +word-wrapped to. If \code{NULL}, it is set to the current print width of the session (\code{getOption("width")}). If set to \code{"auto"}, the width of the table (plus any table inset) is used. Ignored completely if \code{tf_wrap} is \code{FALSE}.} diff --git a/man/gen_args.Rd b/man/gen_args.Rd index 53ce36782..a965d0de3 100644 --- a/man/gen_args.Rd +++ b/man/gen_args.Rd @@ -89,7 +89,8 @@ when forcing pagination between the children of this split/table} \item{hsep}{character(1). Set of character(s) to be repeated as the separator between the header and body of the table when rendered as text. Defaults to a connected horizontal line (unicode 2014) in locals that use a UTF -charset, and to \code{-} elsewhere (with a once per session warning).} +charset, and to \code{-} elsewhere (with a once per session warning). See +\code{\link[formatters:default_horizontal_sep]{formatters::set_default_hsep()}} for further information.} \item{indent_size}{numeric(1). Number of spaces to use per indent level. Defaults to 2} diff --git a/man/paginate.Rd b/man/paginate.Rd index c4bd27c4b..92bed8aed 100644 --- a/man/paginate.Rd +++ b/man/paginate.Rd @@ -49,9 +49,9 @@ considerations. Defaults to none.} \item{colwidths}{numeric vector. Column widths for use with vertical pagination.} -\item{max_width}{integer(1), character(1) or NULL. Width that title +\item{max_width}{integer(1), character(1) or \code{NULL}. Width that title and footer (including footnotes) materials should be -word-wrapped to. If NULL, it is set to the current print width +word-wrapped to. If \code{NULL}, it is set to the current print width of the session (\code{getOption("width")}). If set to \code{"auto"}, the width of the table (plus any table inset) is used. Ignored completely if \code{tf_wrap} is \code{FALSE}.} diff --git a/man/rtable.Rd b/man/rtable.Rd index 94c82b6e0..5a8e402ab 100644 --- a/man/rtable.Rd +++ b/man/rtable.Rd @@ -24,7 +24,8 @@ format labels.} \item{hsep}{character(1). Set of character(s) to be repeated as the separator between the header and body of the table when rendered as text. Defaults to a connected horizontal line (unicode 2014) in locals that use a UTF -charset, and to \code{-} elsewhere (with a once per session warning).} +charset, and to \code{-} elsewhere (with a once per session warning). See +\code{\link[formatters:default_horizontal_sep]{formatters::set_default_hsep()}} for further information.} \item{inset}{integer(1). The table inset for the row or table being constructed. See \code{\link[formatters]{table_inset}}.} diff --git a/man/tabclasses.Rd b/man/tabclasses.Rd index 2c74806b8..69bd45993 100644 --- a/man/tabclasses.Rd +++ b/man/tabclasses.Rd @@ -117,7 +117,8 @@ tables that need a divider between them.} \item{hsep}{character(1). Set of character(s) to be repeated as the separator between the header and body of the table when rendered as text. Defaults to a connected horizontal line (unicode 2014) in locals that use a UTF -charset, and to \code{-} elsewhere (with a once per session warning).} +charset, and to \code{-} elsewhere (with a once per session warning). See +\code{\link[formatters:default_horizontal_sep]{formatters::set_default_hsep()}} for further information.} \item{trailing_section_div}{character(1). String which will be used as a section divider after the printing of the last row contained in this (sub)-table, diff --git a/man/table_shell.Rd b/man/table_shell.Rd index 824266d7c..31fa94f06 100644 --- a/man/table_shell.Rd +++ b/man/table_shell.Rd @@ -27,18 +27,24 @@ table_shell_str( \item{tt}{\code{TableTree} (or related class). A \code{TableTree} object representing a populated table.} -\item{widths}{widths of row.name and columns} +\item{widths}{numeric (or \code{NULL}). (proposed) widths for the columns +of \code{x}. The expected length of this numeric vector can be +retrieved with \code{ncol() + 1} as the column of row names must +also be considered.} -\item{col_gap}{gap between columns} +\item{col_gap}{numeric(1). Space (in characters) between columns} -\item{hsep}{character to create line separator} +\item{hsep}{character(1). Characters to repeat to create +header/body separator line. If \code{NULL}, the object value will be +used. If \code{" "}, an empty separator will be printed. Check \code{\link[formatters:default_hsep]{default_hsep()}} +for more information.} \item{tf_wrap}{logical(1). Should the texts for title, subtitle, and footnotes be wrapped?} -\item{max_width}{integer(1), character(1) or NULL. Width that title +\item{max_width}{integer(1), character(1) or \code{NULL}. Width that title and footer (including footnotes) materials should be -word-wrapped to. If NULL, it is set to the current print width +word-wrapped to. If \code{NULL}, it is set to the current print width of the session (\code{getOption("width")}). If set to \code{"auto"}, the width of the table (plus any table inset) is used. Ignored completely if \code{tf_wrap} is \code{FALSE}.} diff --git a/man/tostring.Rd b/man/tostring.Rd index 00fb3e691..05903fbc1 100644 --- a/man/tostring.Rd +++ b/man/tostring.Rd @@ -16,13 +16,19 @@ ) } \arguments{ -\item{x}{table object} +\item{x}{ANY. Object to be prepared for rendering.} -\item{widths}{widths of row.name and columns} +\item{widths}{numeric (or \code{NULL}). (proposed) widths for the columns +of \code{x}. The expected length of this numeric vector can be +retrieved with \code{ncol() + 1} as the column of row names must +also be considered.} -\item{col_gap}{gap between columns} +\item{col_gap}{numeric(1). Space (in characters) between columns} -\item{hsep}{character to create line separator} +\item{hsep}{character(1). Characters to repeat to create +header/body separator line. If \code{NULL}, the object value will be +used. If \code{" "}, an empty separator will be printed. Check \code{\link[formatters:default_hsep]{default_hsep()}} +for more information.} \item{indent_size}{numeric(1). Number of spaces to use per indent level. Defaults to 2} @@ -30,9 +36,9 @@ Defaults to 2} \item{tf_wrap}{logical(1). Should the texts for title, subtitle, and footnotes be wrapped?} -\item{max_width}{integer(1), character(1) or NULL. Width that title +\item{max_width}{integer(1), character(1) or \code{NULL}. Width that title and footer (including footnotes) materials should be -word-wrapped to. If NULL, it is set to the current print width +word-wrapped to. If \code{NULL}, it is set to the current print width of the session (\code{getOption("width")}). If set to \code{"auto"}, the width of the table (plus any table inset) is used. Ignored completely if \code{tf_wrap} is \code{FALSE}.} diff --git a/man/tt_to_flextable.Rd b/man/tt_to_flextable.Rd index 64ecd92a6..8befa8e87 100644 --- a/man/tt_to_flextable.Rd +++ b/man/tt_to_flextable.Rd @@ -81,9 +81,9 @@ regardless of page size.} \item{tf_wrap}{logical(1). Should the texts for title, subtitle, and footnotes be wrapped?} -\item{max_width}{integer(1), character(1) or NULL. Width that title +\item{max_width}{integer(1), character(1) or \code{NULL}. Width that title and footer (including footnotes) materials should be -word-wrapped to. If NULL, it is set to the current print width +word-wrapped to. If \code{NULL}, it is set to the current print width of the session (\code{getOption("width")}). If set to \code{"auto"}, the width of the table (plus any table inset) is used. Ignored completely if \code{tf_wrap} is \code{FALSE}.} diff --git a/tests/testthat/test-printing.R b/tests/testthat/test-printing.R index e944e1553..0ab5f8dd0 100644 --- a/tests/testthat/test-printing.R +++ b/tests/testthat/test-printing.R @@ -739,3 +739,20 @@ test_that("Separators and wrapping work together with getter and setters", { "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ) }) + +test_that("horizontal separator is propagated from table to print and export", { + # GitHub error #778 + lyt <- basic_table() %>% + split_cols_by("Species") %>% + analyze("Sepal.Length", afun = function(x) { + list( + "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), + "range" = diff(range(x)) + ) + }) + + tbl <- build_table(lyt, iris, hsep = "~") + tostring_tbl <- strsplit(toString(tbl), "\n")[[1]] + export_txt_tbl <- strsplit(export_as_txt(tbl), "\n")[[1]] + expect_identical(tostring_tbl, export_txt_tbl) +}) From 7d344a1bbbd02d3f05a180ba12454189cdbaa5e3 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Mon, 27 Nov 2023 09:02:40 +0000 Subject: [PATCH 13/27] [skip actions] Bump version to 0.6.5.9015 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 038d1c42d..97b544acd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9014 -Date: 2023-11-24 +Version: 0.6.5.9015 +Date: 2023-11-27 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index afb220b1f..33a3a4506 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9014 +## rtables 0.6.5.9015 ### 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` From 15b394d87c984bd478bed0b44929b8b640ab901e Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Mon, 27 Nov 2023 11:45:46 -0500 Subject: [PATCH 14/27] Add `na_str` argument to `analyze_colvars` (#791) --- NEWS.md | 1 + R/colby_constructors.R | 5 ++++- man/analyze_colvars.Rd | 4 ++++ tests/testthat/test-lyt-tabulation.R | 12 +++++++++++- 4 files changed, 20 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 33a3a4506..e38ecf229 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,6 +9,7 @@ split section structure assignment. * Added `header_section_div` setters and getters for layout and table objects along with related `basic_table` parameter. + * Added `na_str` argument to `analyze_colvars` to set custom string to print in place of missing values. ### Bug Fixes * Fixed a bug that was failing when wrapping and section dividers were used at the same time. diff --git a/R/colby_constructors.R b/R/colby_constructors.R index 80ba3c7fb..5b8bed000 100644 --- a/R/colby_constructors.R +++ b/R/colby_constructors.R @@ -1274,8 +1274,10 @@ get_acolvar_vars <- function(lyt) { #' tbl2 <- build_table(lyt2, ANL) #' tbl2 #' -analyze_colvars <- function(lyt, afun, +analyze_colvars <- function(lyt, + afun, format = NULL, + na_str = NA_character_, nested = TRUE, extra_args = list(), indent_mod = 0L, @@ -1314,6 +1316,7 @@ analyze_colvars <- function(lyt, afun, afun = afun, defrowlab = defrowlab, split_format = format, + split_na_str = na_str, split_name = get_acolvar_name(lyt), indent_mod = indent_mod, extra_args = extra_args, diff --git a/man/analyze_colvars.Rd b/man/analyze_colvars.Rd index 293f51b49..c8dc6d16b 100644 --- a/man/analyze_colvars.Rd +++ b/man/analyze_colvars.Rd @@ -8,6 +8,7 @@ analyze_colvars( lyt, afun, format = NULL, + na_str = NA_character_, nested = TRUE, extra_args = list(), indent_mod = 0L, @@ -27,6 +28,9 @@ parameters as \link{analyze} like \code{afun} and \code{format}. For further inf declared via strings (\code{"xx.x"}) or function. In cases such as \code{analyze} calls, they can character vectors or lists of functions.} +\item{na_str}{character(1). String that should be displayed when the value of \code{x} is missing. +Defaults to \code{"NA"}.} + \item{nested}{boolean. Should this layout instruction be applied within the existing layout structure \emph{if possible} (\code{TRUE}, the default) or as a new top-level element (`FALSE). Ignored if it would nest a split underneath diff --git a/tests/testthat/test-lyt-tabulation.R b/tests/testthat/test-lyt-tabulation.R index 28c3191d2..d8ad24bcf 100644 --- a/tests/testthat/test-lyt-tabulation.R +++ b/tests/testthat/test-lyt-tabulation.R @@ -943,9 +943,19 @@ test_that("analyze_colvars works generally", { cell_values(one_col_tbl), list(Sepal.Width = mean(iris$Sepal.Width)) ) + + # na_str argument works + test$d <- NA + l2 <- basic_table() %>% + split_cols_by_multivar(c("a", "b", "c", "d")) %>% + analyze_colvars(afun = mean, na_str = "no data") + tab2 <- build_table(l2, test) + expect_identical( + toString(tab2[1, 4]), + " d \n——————————————\nmean no data\n" + ) }) - test_that("alt_counts_df works", { minidm <- DM[1, ] From 6329f92b71201a71bf0218de98488ebfd923f762 Mon Sep 17 00:00:00 2001 From: edelarua Date: Mon, 27 Nov 2023 16:47:02 +0000 Subject: [PATCH 15/27] [skip actions] Bump version to 0.6.5.9016 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 97b544acd..3d5c2ea71 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9015 +Version: 0.6.5.9016 Date: 2023-11-27 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", diff --git a/NEWS.md b/NEWS.md index e38ecf229..c989a34bc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9015 +## rtables 0.6.5.9016 ### 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` From 795176a5f32ccd88509c7ea7740cf204686e243c Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Tue, 28 Nov 2023 05:06:57 -0500 Subject: [PATCH 16/27] Fix column name misalignment bug in `as_result_df` (#792) --- NEWS.md | 1 + R/tt_export.R | 3 ++- tests/testthat/test-result_data_frame.R | 16 ++++++++++++++++ 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index c989a34bc..a8741a6d1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,7 @@ ### Bug Fixes * Fixed a bug that was failing when wrapping and section dividers were used at the same time. + * Fixed a bug in `as_result_df` causing misalignment of column names. ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. diff --git a/R/tt_export.R b/R/tt_export.R index a5377d735..10fde5cd6 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -141,8 +141,9 @@ do_data_row <- function(rdfrow, maxlen) { if (pthlen %% 2 == 1) { pth <- pth[-1 * (pthlen - 2)] } + pthlen_new <- length(pth) c( - as.list(pth[seq_len(pthlen - 2)]), + as.list(pth[seq_len(pthlen_new - 2)]), replicate(maxlen - pthlen, list(NA_character_)), as.list(tail(pth, 2)), list(row_num = rdfrow$abs_rownumber, content = FALSE, node_class = rdfrow$node_class) diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index aeb487ac0..7591a64ed 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -50,4 +50,20 @@ test_that("Result Data Frame generation works v0", { result_df3 <- as_result_df(tbl3, spec_version) expect_identical(nrow(result_df3), 1L) + + ## test labels when no row splits + lyt4 <- basic_table() %>% + split_cols_by("ARM") %>% + analyze(c("AGE", "SEX")) + + tbl4 <- build_table(lyt4, DM) + result_df4 <- as_result_df(tbl4) + + expect_identical( + names(result_df4), + c( + "avar_name", "row_name", "row_num", "is_group_summary", + "node_class", "A: Drug X", "B: Placebo", "C: Combination" + ) + ) }) From 478e637a7ca2912c57c3b8f2532375c906a90331 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 28 Nov 2023 10:08:06 +0000 Subject: [PATCH 17/27] [skip actions] Bump version to 0.6.5.9017 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3d5c2ea71..c67122221 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9016 -Date: 2023-11-27 +Version: 0.6.5.9017 +Date: 2023-11-28 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index a8741a6d1..009aafbe4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9016 +## rtables 0.6.5.9017 ### 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` From c4018e7724062038728c98a72571b42bd8220936 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Wed, 29 Nov 2023 09:55:08 +0100 Subject: [PATCH 18/27] Direct formatted output from `as_result_df` (#793) * better docs * order and addition of features on top of v0_experimental * expanded tests * fixes * news * styling * adding stringi * news * integer fix --- DESCRIPTION | 5 +- NEWS.md | 4 + R/tt_export.R | 508 +++++++++++++++--------- R/tt_from_df.R | 5 + R/utils.R | 18 +- man/as_result_df.Rd | 39 -- man/data.frame_export.Rd | 88 ++++ man/df_to_tt.Rd | 1 + man/path_enriched_df.Rd | 37 -- man/result_df_specs.Rd | 17 - man/tsv_io.Rd | 8 +- tests/testthat/test-result_data_frame.R | 58 ++- 12 files changed, 500 insertions(+), 288 deletions(-) delete mode 100644 man/as_result_df.Rd create mode 100644 man/data.frame_export.Rd delete mode 100644 man/path_enriched_df.Rd delete mode 100644 man/result_df_specs.Rd diff --git a/DESCRIPTION b/DESCRIPTION index c67122221..919a4fa9a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,13 +34,14 @@ Depends: methods, R (>= 2.10) Imports: + checkmate (>= 2.1.0), grid, htmltools (>= 0.5.4), - stats + stats, + stringi (>= 1.6) Suggests: broom (>= 0.7.10), car (>= 3.0-13), - checkmate (>= 2.1.0), dplyr (>= 1.0.5), flextable (>= 0.8.4), knitr (>= 1.42), diff --git a/NEWS.md b/NEWS.md index 009aafbe4..8c4e446a7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,8 @@ * Added `header_section_div` setters and getters for layout and table objects along with related `basic_table` parameter. * Added `na_str` argument to `analyze_colvars` to set custom string to print in place of missing values. + * Added flat `data.frame` outputs for `as_result_df()` via flag parameters `as_viewer`, `as_strings`, and + `expand_colnames`. ### Bug Fixes * Fixed a bug that was failing when wrapping and section dividers were used at the same time. @@ -22,6 +24,8 @@ * Started deprecation cycle for `col_fnotes_here` to be replaced with `col_footnotes`. * Exported `section_div` methods now have a dedicated documentation page that is visible to users. * When tables are exported as `txt`, they preserve the horizontal separator of the table. + * Added imports on `stringi` and `checkmate` as they are fundamental packages for string handling and + argument checking. ## rtables 0.6.5 ### New Features diff --git a/R/tt_export.R b/R/tt_export.R index 10fde5cd6..932b8bd6e 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -1,13 +1,11 @@ #' @importFrom tools file_ext NULL -### XXX is the stuff in this file correct or should we be exporting *formatted* values to -### meet the needs of consumers of this? Do we ened to support both? #' Create Enriched flat value table with paths #' -#' +#' @description #' This function creates a flat tabular file of cell values and -#' corresponding paths via \code{\link{path_enriched_df}}. I then +#' corresponding paths via [path_enriched_df()]. I then #' writes that data.frame out as a `tsv` file. #' #' By default (i.e. when \code{value_func} is not specified, @@ -20,25 +18,23 @@ NULL #' #' @inheritParams gen_args #' @param file character(1). The path of the file to written to or read from. -#' @inheritParams path_enriched_df +#' @inheritParams data.frame_export +#' #' @return \code{NULL} silently for \code{export_as_tsv}, a data.frame with #' re-constituted list values for \code{export_as_tsv}. -#' @export +#' +#' @seealso [path_enriched_df()] for the underlying function that does the work. +#' #' @rdname tsv_io #' @importFrom utils write.table read.table - +#' @export export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path, value_fun = collapse_values) { df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun) write.table(df, file, sep = "\t") } - - -.collapse_char <- "|" -.collapse_char_esc <- "\\|" - -##' @export -##' @rdname tsv_io +#' @rdname tsv_io +#' @export import_from_tsv <- function(file) { rawdf <- read.table(file, header = TRUE, sep = "\t") as.data.frame(lapply( @@ -53,52 +49,267 @@ import_from_tsv <- function(file) { )) } -collapse_path <- function(paths) { - if (is.list(paths)) { - return(vapply(paths, collapse_path, "")) - } - paste(paths, collapse = .collapse_char) -} +### Migrated to formatters. -collapse_values <- function(colvals) { - if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1)) - return(colvals) - } else if (all(vapply(colvals, length, 1L) == 1)) { - return(unlist(colvals)) - } - vapply(colvals, paste, "", collapse = .collapse_char) -} +#' @importFrom formatters export_as_txt +#' +#' @examples +#' lyt <- basic_table() %>% +#' split_cols_by("ARM") %>% +#' analyze(c("AGE", "BMRKR2", "COUNTRY")) +#' +#' tbl <- build_table(lyt, ex_adsl) +#' +#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8)) +#' +#' \dontrun{ +#' tf <- tempfile(fileext = ".txt") +#' export_as_txt(tbl, file = tf) +#' system2("cat", tf) +#' } +#' +#' @export +formatters::export_as_txt + +# data.frame output ------------------------------------------------------------ -#' Transform `TableTree` object to Path-Enriched data.frame +#' Generate a Result Data Frame +#' +#' @description +#' Collection of utilities to exctract `data.frame` from `TableTree` objects. #' #' @inheritParams gen_args -#' @param path_fun function. Function to transform paths into single-string -#' row/column names. -#' @param value_fun function. Function to transform cell values into cells of -#' the data.frame. Defaults to \code{collapse_values} which creates strings -#' where multi-valued cells are collapsed together, separated by \code{|}. -#' @export -#' @return A data frame of \code{tt}'s cell values (processed by -#' \code{value_fun}, with columns named by the full column paths (processed by -#' \code{path_fun} and an additional \code{row_path} column with the row paths -#' (processed by by \code{path_fun}). -#' @examples +#' @param spec character(1). The specification to use to +#' extract the result data frame. See details +#' @param simplify logical(1). If \code{TRUE}, the result data frame will have only visible +#' labels and result columns. +#' @param ... Passed to spec-specific result data frame conversion function. Currently it can be +#' one or more of the following parameters (valid only for `v0_experimental` spec for now): +#' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual +#' output. This is useful when the result data frame is used for further processing. +#' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns. +#' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear +#' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for +#' column counts if `expand_colnames = TRUE`. +#' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, +#' i.e. with the same precision and numbers, but in easy-to-use numeric form. +#' +#' @details `as_result_df()`: Result data frame specifications may differ in the exact information +#' they include and the form in which they represent it. Specifications whose names end in "_experimental" +#' are subject to change without notice, but specifications without the "_experimental" +#' suffix will remain available \emph{including any bugs in their construction} indefinitely. #' +#' @examples #' lyt <- basic_table() %>% #' split_cols_by("ARM") %>% +#' split_rows_by("STRATA1") %>% #' analyze(c("AGE", "BMRKR2")) #' #' tbl <- build_table(lyt, ex_adsl) -#' path_enriched_df(tbl) -path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) { +#' as_result_df(tbl) +#' +#' @name data.frame_export +#' @export +as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) { + checkmate::assert_class(tt, "VTableTree") + checkmate::assert_string(spec) + checkmate::assert_flag(simplify) + + if (nrow(tt) == 0) { + return(sanitize_table_struct(tt)) + } + + result_df_fun <- lookup_result_df_specfun(spec) + out <- result_df_fun(tt, ...) + + if (simplify) { + out <- .simplify_result_df(out) + } + + out +} + +# Function that selects specific outputs from the result data frame +.simplify_result_df <- function(df) { + col_df <- colnames(df) + row_names_col <- which(col_df == "row_name") + result_cols <- seq(which(col_df == "node_class") + 1, length(col_df)) + + df[, c(row_names_col, result_cols)] +} + +# Not used in rtables +# .split_colwidths <- function(ptabs, nctot, colwidths) { +# ret <- list() +# i <- 1L +# +# rlw <- colwidths[1] +# colwidths <- colwidths[-1] +# donenc <- 0 +# while (donenc < nctot) { +# curnc <- NCOL(ptabs[[i]]) +# ret[[i]] <- c(rlw, colwidths[seq_len(curnc)]) +# colwidths <- colwidths[-1 * seq_len(curnc)] +# donenc <- donenc + curnc +# i <- i + 1 +# } +# ret +# } + +#' @describeIn data.frame_export list of functions that extract result data frames from \code{TableTree}s. +#' +#' @return `result_df_specs()`: returns a named list of result data frame extraction functions by "specification". +#' +#' @examples +#' result_df_specs() +#' +#' @export +result_df_specs <- function() { + list(v0_experimental = result_df_v0_experimental) +} + +lookup_result_df_specfun <- function(spec) { + if (!(spec %in% names(result_df_specs()))) { + stop( + "unrecognized result data frame specification: ", + spec, + "If that specification is correct you may need to update your version of rtables" + ) + } + result_df_specs()[[spec]] +} + +result_df_v0_experimental <- function(tt, + as_viewer = FALSE, + as_strings = FALSE, + expand_colnames = FALSE) { + checkmate::assert_flag(as_viewer) + checkmate::assert_flag(as_strings) + checkmate::assert_flag(expand_colnames) + + raw_cvals <- cell_values(tt) + ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values + ## rather than a list of length 1 representing the single row. This is bad but may not be changeable + ## at this point. + if (nrow(tt) == 1 && length(raw_cvals) > 1) { + raw_cvals <- list(raw_cvals) + } + + cellvals <- as.data.frame(do.call(rbind, raw_cvals)) + row.names(cellvals) <- NULL + + if (nrow(tt) == 1 && ncol(tt) == 1) { + colnames(cellvals) <- names(raw_cvals) + } + + if (as_viewer || as_strings) { + # we keep previous calculations to check the format of the data + mf_tt <- matrix_form(tt) + mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1] + mf_result_chars <- .remove_empty_elements(mf_result_chars) + mf_result_numeric <- as.data.frame( + .make_numeric_char_mf(mf_result_chars) + ) + mf_result_chars <- as.data.frame(mf_result_chars) + if (!setequal(dim(mf_result_numeric), dim(cellvals)) || + !setequal(dim(mf_result_chars), dim(cellvals))) { + stop( + "The extracted numeric data.frame does not have the same dimension of the", + " cell values extracted with cell_values(). This is a bug. Please report it." + ) # nocov + } + if (as_strings) { + colnames(mf_result_chars) <- colnames(cellvals) + cellvals <- mf_result_chars + } else { + colnames(mf_result_numeric) <- colnames(cellvals) + cellvals <- mf_result_numeric + } + } + rdf <- make_row_df(tt) - cdf <- make_col_df(tt) - cvs <- as.data.frame(do.call(rbind, cell_values(tt))) - cvs <- as.data.frame(lapply(cvs, value_fun)) - row.names(cvs) <- NULL - colnames(cvs) <- path_fun(cdf$path) - preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) - cbind.data.frame(row_path = preppaths, cvs) + + df <- cbind( + rdf[ + rdf$node_class != "LabelRow", + c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class") + ], + cellvals + ) + + maxlen <- max(lengths(df$path)) + metadf <- do.call( + rbind.data.frame, + lapply( + seq_len(NROW(df)), + function(ii) { + handle_rdf_row(df[ii, ], maxlen = maxlen) + } + ) + ) + + ret <- cbind( + metadf[metadf$node_class != "LabelRow", ], + cellvals + ) + + # If we want to expand colnames + if (expand_colnames) { + col_name_structure <- .get_formatted_colnames(clayout(tt)) + number_of_non_data_cols <- which(colnames(ret) == "node_class") + if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) { + stop( + "When expanding colnames structure, we were not able to find the same", + " number of columns as in the result data frame. This is a bug. Please report it." + ) # nocov + } + + buffer_rows_for_colnames <- matrix( + rep("", number_of_non_data_cols * NROW(col_name_structure)), + nrow = NROW(col_name_structure) + ) + + header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure)) + colnames(header_colnames_matrix) <- colnames(ret) + + count_row <- NULL + if (disp_ccounts(tt)) { + ccounts <- col_counts(tt) + if (as_strings) { + ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ] + ccounts <- .remove_empty_elements(ccounts) + } + count_row <- c(rep("", number_of_non_data_cols), ccounts) + header_colnames_matrix <- rbind(header_colnames_matrix, count_row) + } + ret <- rbind(header_colnames_matrix, ret) + } + + ret +} + +.remove_empty_elements <- function(char_df) { + if (is.null(dim(char_df))) { + return(char_df[nzchar(char_df, keepNA = TRUE)]) + } + + apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)]) +} + +# Helper function to make the character matrix numeric +.make_numeric_char_mf <- function(char_df) { + if (is.null(dim(char_df))) { + return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+"))) + } + + ret <- apply(char_df, 2, function(col_i) { + lapply( + stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"), + as.numeric + ) + }) + + do.call(cbind, ret) } do_label_row <- function(rdfrow, maxlen) { @@ -109,7 +320,6 @@ do_label_row <- function(rdfrow, maxlen) { ) } - make_result_df_md_colnames <- function(maxlen) { spllen <- floor((maxlen - 2) / 2) ret <- character() @@ -119,7 +329,6 @@ make_result_df_md_colnames <- function(maxlen) { ret <- c(ret, c("avar_name", "row_name", "row_num", "is_group_summary", "node_class")) } - do_content_row <- function(rdfrow, maxlen) { pth <- rdfrow$path[[1]] @@ -150,7 +359,6 @@ do_data_row <- function(rdfrow, maxlen) { ) } - handle_rdf_row <- function(rdfrow, maxlen) { nclass <- rdfrow$node_class if (rdfrow$path[[1]][1] == "root") { @@ -166,126 +374,76 @@ handle_rdf_row <- function(rdfrow, maxlen) { setNames(ret, make_result_df_md_colnames(maxlen)) } - -#' Result Data Frame Specifications -#' -#' @return a named list of result data frame extraction functions by "specification" -#' @export -#' @examples -#' result_df_specs() -result_df_specs <- function() { - list(v0_experimental = result_df_v0_experimental) -} - -lookup_result_df_specfun <- function(spec) { - if (!(spec %in% names(result_df_specs()))) { - stop( - "unrecognized result data frame specification: ", - spec, - "If that specification is correct you may need to update your version of rtables" - ) +# Helper recurrent function to get the column names for the result data frame from the VTableTree +.get_formatted_colnames <- function(clyt) { + ret <- obj_label(clyt) + if (!nzchar(ret)) { + ret <- NULL } - result_df_specs()[[spec]] -} - -result_df_v0_experimental <- function(tt) { - raw_cvals <- cell_values(tt) - ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values - ## rather than a list of length 1 reprsenting the single row. This is bad but may not be changable - ## at this point. - if (nrow(tt) == 1 && length(raw_cvals) > 1) { - raw_cvals <- list(raw_cvals) + if (is.null(tree_children(clyt))) { + return(ret) + } else { + ret <- rbind(ret, lapply(tree_children(clyt), .get_formatted_colnames) %>% do.call(cbind, .)) + colnames(ret) <- NULL + rownames(ret) <- NULL + return(ret) } - cellvals <- as.data.frame(do.call(rbind, raw_cvals)) - row.names(cellvals) <- NULL - rdf <- make_row_df(tt) - df <- cbind( - rdf[ - rdf$node_class != "LabelRow", - c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class") - ], - cellvals - ) - maxlen <- max(lengths(df$path)) - metadf <- do.call(rbind.data.frame, lapply( - seq_len(NROW(df)), - function(ii) handle_rdf_row(df[ii, ], maxlen = maxlen) - )) - cbind( - metadf[metadf$node_class != "LabelRow", ], - cellvals - ) } -#' Generate a Result Data Frame +#' @describeIn data.frame_export transform `TableTree` object to Path-Enriched `data.frame`. #' -#' @param tt `VTableTree`. The table. -#' @param spec character(1). The specification to use to -#' extract the result data frame. See details -#' @param ... Passed to spec-specific result data frame conversion function. +#' @param path_fun function. Function to transform paths into single-string +#' row/column names. +#' @param value_fun function. Function to transform cell values into cells of +#' the data.frame. Defaults to \code{collapse_values} which creates strings +#' where multi-valued cells are collapsed together, separated by \code{|}. #' -#' @details Result data frame specifications may differ in the exact information they include and -#' the form in which they represent it. Specifications whose names end in "_experimental" -#' are subject to change without notice, but specifications without the "_experimental" -#' suffix will remain available \emph{including any bugs in their construction} indefinitely. +#' @return `path_enriched_df()`: returns a data frame of \code{tt}'s cell values (processed by +#' \code{value_fun}, with columns named by the full column paths (processed by +#' \code{path_fun} and an additional \code{row_path} column with the row paths +#' (processed by by \code{path_fun}). #' -#' @note This function may eventually be migrated to a separate package, and so should -#' not be called via `::` -#' @export #' @examples -#' #' lyt <- basic_table() %>% #' split_cols_by("ARM") %>% -#' split_rows_by("STRATA1") %>% #' analyze(c("AGE", "BMRKR2")) #' #' tbl <- build_table(lyt, ex_adsl) -#' as_result_df(tbl) -as_result_df <- function(tt, spec = "v0_experimental", ...) { - result_df_fun <- lookup_result_df_specfun(spec) - result_df_fun(tt, ...) +#' path_enriched_df(tbl) +#' +#' @export +path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) { + rdf <- make_row_df(tt) + cdf <- make_col_df(tt) + cvs <- as.data.frame(do.call(rbind, cell_values(tt))) + cvs <- as.data.frame(lapply(cvs, value_fun)) + row.names(cvs) <- NULL + colnames(cvs) <- path_fun(cdf$path) + preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) + cbind.data.frame(row_path = preppaths, cvs) } -.split_colwidths <- function(ptabs, nctot, colwidths) { - ret <- list() - i <- 1L - - rlw <- colwidths[1] - colwidths <- colwidths[-1] - donenc <- 0 - while (donenc < nctot) { - curnc <- NCOL(ptabs[[i]]) - ret[[i]] <- c(rlw, colwidths[seq_len(curnc)]) - colwidths <- colwidths[-1 * seq_len(curnc)] - donenc <- donenc + curnc - i <- i + 1 +.collapse_char <- "|" +.collapse_char_esc <- "\\|" + +collapse_path <- function(paths) { + if (is.list(paths)) { + return(vapply(paths, collapse_path, "")) } - ret + paste(paths, collapse = .collapse_char) } -### Migrated to formatters. - -#' @importFrom formatters export_as_txt -#' -#' @examples -#' lyt <- basic_table() %>% -#' split_cols_by("ARM") %>% -#' analyze(c("AGE", "BMRKR2", "COUNTRY")) -#' -#' tbl <- build_table(lyt, ex_adsl) -#' -#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8)) -#' -#' \dontrun{ -#' tf <- tempfile(fileext = ".txt") -#' export_as_txt(tbl, file = tf) -#' system2("cat", tf) -#' } -#' -#' @export -formatters::export_as_txt +collapse_values <- function(colvals) { + if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1)) + return(colvals) + } else if (all(vapply(colvals, length, 1L) == 1)) { + return(unlist(colvals)) + } + vapply(colvals, paste, "", collapse = .collapse_char) +} +# pdf output ------------------------------------------------------------------- #' Export as PDF #' #' The PDF output is based on the ASCII output created with `toString` @@ -462,6 +620,22 @@ export_as_pdf <- function(tt, lpp = lpp, cpp = cpp ) } + +# only used in pagination +.tab_to_colpath_set <- function(tt) { + vapply( + collect_leaves(coltree(tt)), + function(y) paste(pos_to_path(tree_pos(y)), collapse = " "), + "" + ) +} +.figure_out_colinds <- function(subtab, fulltab) { + match( + .tab_to_colpath_set(subtab), + .tab_to_colpath_set(fulltab) + ) +} + # Flextable and docx ----------------------------------------------------------- #' Export as word document #' @@ -707,7 +881,7 @@ tt_to_flextable <- function(tt, tf_wrap = !is.null(cpp), max_width = cpp, total_width = 10) { - check_required_packages(c("flextable", "checkmate")) + check_required_packages("flextable") if (!inherits(tt, "VTableTree")) { stop("Input table is not an rtables' object.") } @@ -912,7 +1086,7 @@ theme_docx_default <- function(tt = NULL, # Option for more complicated stuff bold_manual = NULL, border = flextable::fp_border_default(width = 0.5)) { function(flx) { - check_required_packages(c("flextable", "checkmate")) + check_required_packages("flextable") if (!inherits(flx, "flextable")) { stop(sprintf( "Function `%s` supports only flextable objects.", @@ -1074,29 +1248,3 @@ apply_alignments <- function(flx, aligns_df, part) { flx } - -# only used in pagination -.tab_to_colpath_set <- function(tt) { - vapply( - collect_leaves(coltree(tt)), - function(y) paste(pos_to_path(tree_pos(y)), collapse = " "), - "" - ) -} -.figure_out_colinds <- function(subtab, fulltab) { - match( - .tab_to_colpath_set(subtab), - .tab_to_colpath_set(fulltab) - ) -} - -check_required_packages <- function(pkgs) { - for (pkgi in pkgs) { - if (!requireNamespace(pkgi)) { - stop( - "This function requires the ", pkgi, " package. ", - "Please install it if you wish to use it" - ) - } - } -} diff --git a/R/tt_from_df.R b/R/tt_from_df.R index 3e2a0dfa3..111255c7a 100644 --- a/R/tt_from_df.R +++ b/R/tt_from_df.R @@ -1,9 +1,13 @@ #' Create `ElementaryTable` from data.frame +#' #' @param df data.frame. +#' #' @return an \code{ElementaryTable} object with unnested columns corresponding to #' \code{names(df)} and row labels corresponding to \code{row.names(df)} +#' #' @examples #' df_to_tt(mtcars) +#' #' @export df_to_tt <- function(df) { colnms <- colnames(df) @@ -14,5 +18,6 @@ df_to_tt <- function(df) { rni <- if (havern) rnames[i] else "" do.call(rrow, c(list(row.name = rni), unclass(df[i, ]))) }) + ElementaryTable(kids = kids, cinfo = cinfo) } diff --git a/R/utils.R b/R/utils.R index 0633cbecf..3b9cfc245 100644 --- a/R/utils.R +++ b/R/utils.R @@ -11,8 +11,6 @@ is_rtable <- function(x) { is(x, "VTableTree") } - - # nocov start ## is each object in a collection from a class are <- function(object_collection, class2) { @@ -51,7 +49,6 @@ is_logical_vector_modif <- function(x, min_length = 1) { } # nocov end - # Shorthand for functions that take df as first parameter .takes_df <- function(f) { func_takes(f, "df", is_first = TRUE) @@ -79,11 +76,11 @@ func_takes <- function(func, params, is_first = FALSE) { #' Translate spl_context to Path for display in error messages #' -#' #' @param ctx data.frame. The `spl_context` data.frame where the error occurred #' #' @return A character string containing a description of the row path corresponding #' to the `ctx` +#' #' @export spl_context_to_disp_path <- function(ctx) { ## this can happen in the first split in column space, but @@ -107,3 +104,16 @@ spl_context_to_disp_path <- function(ctx) { paste_vec <- function(vec) { paste0('c("', paste(vec, collapse = '", "'), '")') } + +# Utility for checking if a package is installed +check_required_packages <- function(pkgs) { + for (pkgi in pkgs) { + if (!requireNamespace(pkgi)) { + stop( + "This function requires the ", pkgi, " package. ", + "Please install it if you wish to use it" + ) + } + } +} + diff --git a/man/as_result_df.Rd b/man/as_result_df.Rd deleted file mode 100644 index 54768f5ec..000000000 --- a/man/as_result_df.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tt_export.R -\name{as_result_df} -\alias{as_result_df} -\title{Generate a Result Data Frame} -\usage{ -as_result_df(tt, spec = "v0_experimental", ...) -} -\arguments{ -\item{tt}{\code{VTableTree}. The table.} - -\item{spec}{character(1). The specification to use to -extract the result data frame. See details} - -\item{...}{Passed to spec-specific result data frame conversion function.} -} -\description{ -Generate a Result Data Frame -} -\details{ -Result data frame specifications may differ in the exact information they include and -the form in which they represent it. Specifications whose names end in "_experimental" -are subject to change without notice, but specifications without the "_experimental" -suffix will remain available \emph{including any bugs in their construction} indefinitely. -} -\note{ -This function may eventually be migrated to a separate package, and so should -not be called via \code{::} -} -\examples{ - -lyt <- basic_table() \%>\% - split_cols_by("ARM") \%>\% - split_rows_by("STRATA1") \%>\% - analyze(c("AGE", "BMRKR2")) - -tbl <- build_table(lyt, ex_adsl) -as_result_df(tbl) -} diff --git a/man/data.frame_export.Rd b/man/data.frame_export.Rd new file mode 100644 index 000000000..97d0011aa --- /dev/null +++ b/man/data.frame_export.Rd @@ -0,0 +1,88 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tt_export.R +\name{data.frame_export} +\alias{data.frame_export} +\alias{as_result_df} +\alias{result_df_specs} +\alias{path_enriched_df} +\title{Generate a Result Data Frame} +\usage{ +as_result_df(tt, spec = "v0_experimental", simplify = FALSE, ...) + +result_df_specs() + +path_enriched_df(tt, path_fun = collapse_path, value_fun = collapse_values) +} +\arguments{ +\item{tt}{\code{TableTree} (or related class). A \code{TableTree} object representing a +populated table.} + +\item{spec}{character(1). The specification to use to +extract the result data frame. See details} + +\item{simplify}{logical(1). If \code{TRUE}, the result data frame will have only visible +labels and result columns.} + +\item{...}{Passed to spec-specific result data frame conversion function. Currently it can be +one or more of the following parameters (valid only for \code{v0_experimental} spec for now): +\itemize{ +\item \code{expand_colnames}: when \code{TRUE}, the result data frame will have expanded column names above the usual +output. This is useful when the result data frame is used for further processing. +\item \code{simplify}: when \code{TRUE}, the result data frame will have only visible labels and result columns. +\item \code{as_strings}: when \code{TRUE}, the result data frame will have all values as strings, as they appear +in the final table (it can also be retrieved from \code{matrix_form(tt)$strings}). This is also true for +column counts if \code{expand_colnames = TRUE}. +\item \code{as_viewer}: when \code{TRUE}, the result data frame will have all values as they appear in the final table, +i.e. with the same precision and numbers, but in easy-to-use numeric form. +}} + +\item{path_fun}{function. Function to transform paths into single-string +row/column names.} + +\item{value_fun}{function. Function to transform cell values into cells of +the data.frame. Defaults to \code{collapse_values} which creates strings +where multi-valued cells are collapsed together, separated by \code{|}.} +} +\value{ +\code{result_df_specs()}: returns a named list of result data frame extraction functions by "specification". + +\code{path_enriched_df()}: returns a data frame of \code{tt}'s cell values (processed by +\code{value_fun}, with columns named by the full column paths (processed by +\code{path_fun} and an additional \code{row_path} column with the row paths +(processed by by \code{path_fun}). +} +\description{ +Collection of utilities to exctract \code{data.frame} from \code{TableTree} objects. +} +\details{ +\code{as_result_df()}: Result data frame specifications may differ in the exact information +they include and the form in which they represent it. Specifications whose names end in "_experimental" +are subject to change without notice, but specifications without the "_experimental" +suffix will remain available \emph{including any bugs in their construction} indefinitely. +} +\section{Functions}{ +\itemize{ +\item \code{result_df_specs()}: list of functions that extract result data frames from \code{TableTree}s. + +\item \code{path_enriched_df()}: transform \code{TableTree} object to Path-Enriched \code{data.frame}. + +}} +\examples{ +lyt <- basic_table() \%>\% + split_cols_by("ARM") \%>\% + split_rows_by("STRATA1") \%>\% + analyze(c("AGE", "BMRKR2")) + +tbl <- build_table(lyt, ex_adsl) +as_result_df(tbl) + +result_df_specs() + +lyt <- basic_table() \%>\% + split_cols_by("ARM") \%>\% + analyze(c("AGE", "BMRKR2")) + +tbl <- build_table(lyt, ex_adsl) +path_enriched_df(tbl) + +} diff --git a/man/df_to_tt.Rd b/man/df_to_tt.Rd index 51feb47fe..6911d128c 100644 --- a/man/df_to_tt.Rd +++ b/man/df_to_tt.Rd @@ -18,4 +18,5 @@ Create \code{ElementaryTable} from data.frame } \examples{ df_to_tt(mtcars) + } diff --git a/man/path_enriched_df.Rd b/man/path_enriched_df.Rd deleted file mode 100644 index d83da44cc..000000000 --- a/man/path_enriched_df.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tt_export.R -\name{path_enriched_df} -\alias{path_enriched_df} -\title{Transform \code{TableTree} object to Path-Enriched data.frame} -\usage{ -path_enriched_df(tt, path_fun = collapse_path, value_fun = collapse_values) -} -\arguments{ -\item{tt}{\code{TableTree} (or related class). A \code{TableTree} object representing a -populated table.} - -\item{path_fun}{function. Function to transform paths into single-string -row/column names.} - -\item{value_fun}{function. Function to transform cell values into cells of -the data.frame. Defaults to \code{collapse_values} which creates strings -where multi-valued cells are collapsed together, separated by \code{|}.} -} -\value{ -A data frame of \code{tt}'s cell values (processed by -\code{value_fun}, with columns named by the full column paths (processed by -\code{path_fun} and an additional \code{row_path} column with the row paths -(processed by by \code{path_fun}). -} -\description{ -Transform \code{TableTree} object to Path-Enriched data.frame -} -\examples{ - -lyt <- basic_table() \%>\% - split_cols_by("ARM") \%>\% - analyze(c("AGE", "BMRKR2")) - -tbl <- build_table(lyt, ex_adsl) -path_enriched_df(tbl) -} diff --git a/man/result_df_specs.Rd b/man/result_df_specs.Rd deleted file mode 100644 index 0715abdd3..000000000 --- a/man/result_df_specs.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tt_export.R -\name{result_df_specs} -\alias{result_df_specs} -\title{Result Data Frame Specifications} -\usage{ -result_df_specs() -} -\value{ -a named list of result data frame extraction functions by "specification" -} -\description{ -Result Data Frame Specifications -} -\examples{ -result_df_specs() -} diff --git a/man/tsv_io.Rd b/man/tsv_io.Rd index 50e58ec04..8149d469c 100644 --- a/man/tsv_io.Rd +++ b/man/tsv_io.Rd @@ -33,10 +33,9 @@ re-constituted list values for \code{export_as_tsv}. } \description{ This function creates a flat tabular file of cell values and -corresponding paths via \code{\link{path_enriched_df}}. I then +corresponding paths via \code{\link[=path_enriched_df]{path_enriched_df()}}. I then writes that data.frame out as a \code{tsv} file. -} -\details{ + By default (i.e. when \code{value_func} is not specified, List columns where at least one value has length > 1 are collapsed to character vectors by collapsing the list element with \code{"|"}. @@ -46,3 +45,6 @@ There is currently no round-trip capability for this type of export. You can read values exported this way back in via \code{import_from_tsv} but you will receive only the data.frame version back, NOT a \code{TableTree}. } +\seealso{ +\code{\link[=path_enriched_df]{path_enriched_df()}} for the underlying function that does the work. +} diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index 7591a64ed..6a40be997 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -1,6 +1,5 @@ context("Result Data Frames") - test_that("Result Data Frame generation works v0", { ## change here (only) when v0 is crystalized (no longer experimental) spec_version <- "v0_experimental" @@ -50,20 +49,67 @@ test_that("Result Data Frame generation works v0", { result_df3 <- as_result_df(tbl3, spec_version) expect_identical(nrow(result_df3), 1L) - + ## test labels when no row splits lyt4 <- basic_table() %>% split_cols_by("ARM") %>% analyze(c("AGE", "SEX")) - - tbl4 <- build_table(lyt4, DM) + + tbl4 <- build_table(lyt4, DM) result_df4 <- as_result_df(tbl4) - + expect_identical( names(result_df4), c( - "avar_name", "row_name", "row_num", "is_group_summary", + "avar_name", "row_name", "row_num", "is_group_summary", "node_class", "A: Drug X", "B: Placebo", "C: Combination" ) ) }) + +test_that("as_result_df works with visual output (as_viewer)", { + lyt <- make_big_lyt() + tbl <- build_table(lyt, rawdat) + + res <- expect_silent(as_result_df(tbl, simplify = TRUE, as_viewer = TRUE)) + expect_equal(res$ARM1.M[[1]], c(116.0, 45.3)) + + res <- expect_silent(as_result_df(tbl, simplify = TRUE, as_viewer = TRUE, as_strings = TRUE)) + expect_equal(res$ARM1.M[[1]], "116 (45.3%)") + + mf <- matrix_form(tbl) + string_tbl <- mf_strings(mf)[-seq_len(mf_nlheader(mf)), ] + string_tbl <- string_tbl[nzchar(string_tbl[, 2]), ] + colnames(string_tbl) <- colnames(res) + expect_equal(res, data.frame(string_tbl)) + + res <- expect_silent(as_result_df(tbl, simplify = TRUE, as_strings = TRUE, expand_colnames = TRUE)) + string_tbl <- mf_strings(mf) + string_tbl <- data.frame(string_tbl[nzchar(string_tbl[, 2]), ]) + colnames(string_tbl) <- colnames(res) + string_tbl$row_name[seq_len(mf_nlheader(mf))] <- res$row_name[seq_len(mf_nlheader(mf))] + expect_equal(res, string_tbl) + + expect_silent(basic_table() %>% build_table(DM) %>% as_result_df()) + + tbl <- basic_table(show_colcounts = TRUE) %>% + analyze("BMRKR1") %>% + build_table(DM) + expect_equal(as_result_df(tbl)$`all obs`, 5.851948, tolerance = 1e-6) + expect_equal( + as_result_df(tbl, as_viewer = TRUE)$`all obs`, + as.numeric(as_result_df(tbl, as_strings = TRUE)$`all obs`) + ) + expect_equal(as_result_df(tbl, expand_colnames = TRUE)$`all obs`[2], "356") + expect_equal(as_result_df(tbl, expand_colnames = TRUE, as_strings = TRUE)$`all obs`[2], "(N=356)") + + + # Test for integer extraction and ranges + lyt <- basic_table() %>% + split_cols_by("ARM") %>% + split_rows_by("STRATA1") %>% + analyze("AGE", afun = function(x) list(a = mean(x), b = range(x))) + + tbl <- build_table(lyt, ex_adsl) + expect_equal(as_result_df(tbl, simplify = TRUE, as_viewer = TRUE)[2, 2][[1]], c(24, 46)) +}) From 2fb0fd6eaab7c97d39902061e128559f5dbcfe48 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 29 Nov 2023 08:56:12 +0000 Subject: [PATCH 19/27] [skip actions] Bump version to 0.6.5.9018 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 919a4fa9a..fd246a932 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9017 -Date: 2023-11-28 +Version: 0.6.5.9018 +Date: 2023-11-29 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 8c4e446a7..78cb853e4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9017 +## rtables 0.6.5.9018 ### 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` From d861d76748ca6f10de18ebf28a3ce309284219d6 Mon Sep 17 00:00:00 2001 From: Liming <36079400+clarkliming@users.noreply.github.com> Date: Thu, 30 Nov 2023 03:16:12 +0800 Subject: [PATCH 20/27] Fix potential tt at path issue (#794) * fix issue related to path finding * use equal instead of identical * only remove first entry when table is not root * test + news + general fix * Update test, apply styler --------- Co-authored-by: Davide Garolini Co-authored-by: Emily de la Rua --- NEWS.md | 2 ++ R/tt_paginate.R | 2 +- R/tt_pos_and_access.R | 5 +++-- tests/testthat/test-subset-access.R | 23 +++++++++++++++++++++++ 4 files changed, 29 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 78cb853e4..e6372f3cd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -16,6 +16,8 @@ ### Bug Fixes * Fixed a bug that was failing when wrapping and section dividers were used at the same time. * Fixed a bug in `as_result_df` causing misalignment of column names. + * Fixed a bug that was not allowing path indexing as `row_paths()` was giving a different path due to it being made of + named values. ### Miscellaneous * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2. diff --git a/R/tt_paginate.R b/R/tt_paginate.R index 059c1bf07..ccb6e832d 100644 --- a/R/tt_paginate.R +++ b/R/tt_paginate.R @@ -342,7 +342,7 @@ setMethod( colwidths = colwidths, sibpos = sibpos, nsibs = nsibs, - pth = c(path, obj_name(tt)), + pth = c(path, unname(obj_name(tt))), repext = repr_ext, repind = repr_inds, indent = indent, diff --git a/R/tt_pos_and_access.R b/R/tt_pos_and_access.R index 5462efb02..a03bdf988 100644 --- a/R/tt_pos_and_access.R +++ b/R/tt_pos_and_access.R @@ -289,11 +289,12 @@ setMethod( length(path) > 0, !anyNA(path) ) - if (identical(path[1], "root")) { + + if (path[1] == "root" && obj_name(tt) != "root") { path <- path[-1] } ## handle pathing that hits the root split by name - if (identical(obj_name(tt), path[1])) { + if (obj_name(tt) == path[1]) { path <- path[-1] } cur <- tt diff --git a/tests/testthat/test-subset-access.R b/tests/testthat/test-subset-access.R index 223219845..c56f297eb 100644 --- a/tests/testthat/test-subset-access.R +++ b/tests/testthat/test-subset-access.R @@ -540,3 +540,26 @@ test_that("bracket methods all work", { tbl[, c(TRUE, FALSE, FALSE, TRUE, FALSE, TRUE)] ) }) + +test_that("tt_at_path and cell_values work with values even if they differ in naming", { + # see issue #794 + tbl <- basic_table() %>% + split_cols_by(var = "ARM", split_label = "asdar") %>% + # split_rows_by(var = "SEX") %>% + add_colcounts() %>% + analyze("AGE", + afun = function(x) { + out_list <- list(a = mean(x), b = 3) + labs <- c("argh", "argh2") + attr(out_list[[1]], "label") <- "aa" + attr(out_list[[2]], "label") <- "aa2" + in_rows(.list = out_list, .labels = labs, .names = labs) + }, + show_labels = "visible", table_names = "nope" + ) %>% + build_table(df = DM) + + rdf <- make_row_df(tbl) + names(rdf$path[[2]]) <- c("a", "b") + expect_silent(tt_at_path(tbl, rdf$path[[2]])) +}) From 59921c42e68ee3be262bc6199284016b430bb0f4 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 29 Nov 2023 19:17:21 +0000 Subject: [PATCH 21/27] [skip actions] Bump version to 0.6.5.9019 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index fd246a932..a47e89d08 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9018 +Version: 0.6.5.9019 Date: 2023-11-29 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", diff --git a/NEWS.md b/NEWS.md index e6372f3cd..4f99a09a1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9018 +## rtables 0.6.5.9019 ### 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` From 91cae35fd1c6fa9e82142bf17d4492f4600516b9 Mon Sep 17 00:00:00 2001 From: Pawel Rucki <12943682+pawelru@users.noreply.github.com> Date: Fri, 1 Dec 2023 17:21:33 +0100 Subject: [PATCH 22/27] avoid pipe and dot; add note blocklist (#797) * avoid pipe and dot; add note blocklist * further standarisation; add skip for missing r2rtf * Fix tt_export --------- Co-authored-by: Emily de la Rua --- .github/workflows/check.yaml | 17 ++++++++++++++--- R/tt_export.R | 2 +- _pkgdown.yml | 7 +++++++ tests/testthat/test-exporters.R | 1 + 4 files changed, 23 insertions(+), 4 deletions(-) diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 8b9625f43..fb51cb290 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -17,9 +17,20 @@ jobs: secrets: REPO_GITHUB_TOKEN: ${{ secrets.REPO_GITHUB_TOKEN }} with: - enable-staged-dependencies-check: false - junit-xml-comparison: false - sd-direction: upstream + additional-env-vars: | + _R_CHECK_CRAN_INCOMING_REMOTE_=false + additional-r-cmd-check-params: --as-cran + enforce-note-blocklist: true + note-blocklist: | + checking dependencies in R code .* NOTE + checking R code for possible problems .* NOTE + checking examples .* NOTE + checking Rd line widths .* NOTE + checking S3 generic/method consistency .* NOTE + checking Rd .usage sections .* NOTE + checking for unstated dependencies in vignettes .* NOTE + unit-test-report-brand: >- + https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/thumbs/rtables.png coverage: if: github.event_name == 'pull_request' name: Coverage 📔 diff --git a/R/tt_export.R b/R/tt_export.R index 932b8bd6e..709c520f4 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -383,7 +383,7 @@ handle_rdf_row <- function(rdfrow, maxlen) { if (is.null(tree_children(clyt))) { return(ret) } else { - ret <- rbind(ret, lapply(tree_children(clyt), .get_formatted_colnames) %>% do.call(cbind, .)) + ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames))) colnames(ret) <- NULL rownames(ret) <- NULL return(ret) diff --git a/_pkgdown.yml b/_pkgdown.yml index 37f8ee873..41db5436e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -25,6 +25,13 @@ navbar: href: articles/dev-guide/dg_debug_rtables.html - text: Sparse notes on {rtables} internals href: articles/dev-guide/dg_notes.html + reports: + text: Reports + menu: + - text: Coverage report + href: coverage-report/ + - text: Unit test report + href: unit-test-report/ repo: url: diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index f01f1bf22..ec10f6793 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -296,6 +296,7 @@ test_that("path_enriched_df works for tables with a column that has all length 1 }) test_that("export_as_rtf works", { + testthat::skip_if_not_installed("r2rtf") tbl <- tt_to_export() tmpf <- tempfile(fileext = ".rtf") From 0c39cc7f36a1286f55b2bb83b9b0a80f12efe946 Mon Sep 17 00:00:00 2001 From: pawelru Date: Fri, 1 Dec 2023 16:22:41 +0000 Subject: [PATCH 23/27] [skip actions] Bump version to 0.6.5.9020 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a47e89d08..78b53b71a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9019 -Date: 2023-11-29 +Version: 0.6.5.9020 +Date: 2023-12-01 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 4f99a09a1..6f4c6e4d9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9019 +## rtables 0.6.5.9020 ### 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` From 1f0c83ac8a8b3501842b30920ea7525ba230486d Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Tue, 5 Dec 2023 12:59:40 -0500 Subject: [PATCH 24/27] Add `CONTRIBUTING.md` file (#799) --- .github/CODE_OF_CONDUCT.md | 76 +++++++++++++++++++++++++++++++++++++ .github/CONTRIBUTING.md | 77 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 153 insertions(+) create mode 100644 .github/CODE_OF_CONDUCT.md create mode 100644 .github/CONTRIBUTING.md diff --git a/.github/CODE_OF_CONDUCT.md b/.github/CODE_OF_CONDUCT.md new file mode 100644 index 000000000..aa765080b --- /dev/null +++ b/.github/CODE_OF_CONDUCT.md @@ -0,0 +1,76 @@ +# Contributor Covenant Code of Conduct + +## Our Pledge + +In the interest of fostering an open and welcoming environment, we as +contributors and maintainers pledge to making participation in our project and +our community a harassment-free experience for everyone, regardless of age, body +size, disability, ethnicity, sex characteristics, gender identity and expression, +level of experience, education, socio-economic status, nationality, personal +appearance, race, religion, or sexual identity and orientation. + +## Our Standards + +Examples of behavior that contributes to creating a positive environment +include: + +* Using welcoming and inclusive language +* Being respectful of differing viewpoints and experiences +* Gracefully accepting constructive criticism +* Focusing on what is best for the community +* Showing empathy towards other community members + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery and unwelcome sexual attention or + advances +* Trolling, insulting/derogatory comments, and personal or political attacks +* Public or private harassment +* Publishing others' private information, such as a physical or electronic + address, without explicit permission +* Other conduct which could reasonably be considered inappropriate in a + professional setting + +## Our Responsibilities + +Project maintainers are responsible for clarifying the standards of acceptable +behavior and are expected to take appropriate and fair corrective action in +response to any instances of unacceptable behavior. + +Project maintainers have the right and responsibility to remove, edit, or +reject comments, commits, code, wiki edits, issues, and other contributions +that are not aligned to this Code of Conduct, or to ban temporarily or +permanently any contributor for other behaviors that they deem inappropriate, +threatening, offensive, or harmful. + +## Scope + +This Code of Conduct applies both within project spaces and in public spaces +when an individual is representing the project or its community. Examples of +representing a project or community include using an official project e-mail +address, posting via an official social media account, or acting as an appointed +representative at an online or offline event. Representation of a project may be +further defined and clarified by project maintainers. + +## Enforcement + +Instances of abusive, harassing, or otherwise unacceptable behavior may be +reported by contacting the project team at support@github.com. All +complaints will be reviewed and investigated and will result in a response that +is deemed necessary and appropriate to the circumstances. The project team is +obligated to maintain confidentiality with regard to the reporter of an incident. +Further details of specific enforcement policies may be posted separately. + +Project maintainers who do not follow or enforce the Code of Conduct in good +faith may face temporary or permanent repercussions as determined by other +members of the project's leadership. + +## Attribution + +This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, +available at + +[homepage]: https://www.contributor-covenant.org + +For answers to common questions about this code of conduct, see + diff --git a/.github/CONTRIBUTING.md b/.github/CONTRIBUTING.md new file mode 100644 index 000000000..82fa3c78f --- /dev/null +++ b/.github/CONTRIBUTING.md @@ -0,0 +1,77 @@ +# Contributing to {rtables} + +We welcome contributions big and small to the ongoing development of the {rtables} package. For most, the best way to contribute to the package is by filing issues for feature requests or bugs that you have encountered. For those who are interested in contributing code to the package, contributions can be made by working on current issues and opening pull requests with code changes. Any help that you are able to provide is greatly appreciated! + +Contributions to this project are [released](https://docs.github.com/en/site-policy/github-terms/github-terms-of-service#6-contributions-under-repository-license) to the public under the project's open source license. + +--- + +## Filing Issues + +Issues are used to establish a prioritized timeline and track development progress within the package. If there is a new feature that you feel would be enhance the experience of package users, please open a [Feature Request issue](https://github.com/insightsengineering/rtables/issues/new?labels=enhancement&template=feature.yml&title=%5BFeature+Request%5D%3A+%3Ctitle%3E). If you notice a bug in the existing code, please file a [Bug Fix issue](https://github.com/insightsengineering/rtables/issues/new?&labels=bug&template=bug.yml&title=%5BBug%5D%3A+%3Ctitle%3E) with a description of the bug and a [reprex](https://reprex.tidyverse.org/) (reproducible example). Other types of issues (questions, typos you've noticed, improvements to documentation, etc.) can be filed as well. Click [here](https://github.com/insightsengineering/rtables/issues/new/choose) to file a new issue, and [here](https://github.com/insightsengineering/rtables/issues) to see the list of current issues. Please utilize labels wherever possible when creating issues for organization purposes and to narrow down the scope of the work required. + +--- + +## Creating Pull Requests + +Development of the {rtables} package relies on an _Issue → Branch → PR → Code Review → Merge_ pipeline facilitated through GitHub. If you are a more experienced programmer interested in contributing to the package code, please begin by filing an issue describing the changes you would like to make. It may be the case that your idea has already been implemented in some way, and the package maintainers can help to determine whether the feature is necessary before you begin development. Whether you are opening an issue or a pull request, the more detailed your description, the easier it will be for package maintainers to help you! To make code changes in the package, please follow the following process. + +### Pull Request Process + +The {rtables} package is part of the NEST project and utilizes [staged.dependencies](https://github.com/openpharma/staged.dependencies) to ensure to simplify the development process and track upstream and downstream package dependencies. We highly recommend installing and using this package when developing within {rtables}. + +#### 1. Create a branch + +In order to work on a new pull request, please first create a branch off of `main` upon which you can work and commit changes. To comply with [`staged.dependencies`](https://github.com/openpharma/staged.dependencies) standards, {rtables} uses the following branch naming convention: + +`issue#_description_of_issue@target_merge_branch` + +For example, `443_refactor_splits@main`. In most cases, the target merge branch is the base (`main`) branch. + +In some cases, a change in {rtables} may first require upstream changes in the {formatters} package. Suppose we have branch `100_update_fmts@main` in {formatters} containing the required upstream changes. Then the branch created in {rtables} would be named as follows for this example: `443_refactor_splits@100_update_fmts@main`. This ensures that the correct branches are checked out when running tests, etc. + +For more details on `staged.dependencies` branch naming conventions, [click here](https://github.com/openpharma/staged.dependencies#branch-naming-convention). + +#### 2. Code + +Work within the {rtables} package to apply your code changes. Avoid combining issues on a single branch - ideally, each branch should be associated with a single issue and be prefixed by the issue number. + +For information on the basics of the {rtables} package, please read the package vignettes, which are available [here](https://insightsengineering.github.io/rtables/latest-tag/articles/index.html). + +For advanced development work within {rtables}, consider reading through the {rtables} Developer Guide. The Developer Guide can be accessed from the {rtables} site navigation bar, and is listed here for your convenience: + +- [Developer Guide: Split Machinery](https://insightsengineering.github.io/rtables/latest-tag/articles/dev-guide/dg_split_machinery.html) +- [Developer Guide: Tabulation](https://insightsengineering.github.io/rtables/latest-tag/articles/dev-guide/dg_tabulation.html) +- [Developer Guide: Debugging in {rtables} and Beyond](https://insightsengineering.github.io/rtables/latest-tag/articles/dev-guide/dg_debug_rtables.html) +- [Developer Guide: Sparse Notes on {rtables} Internals](https://insightsengineering.github.io/rtables/latest-tag/articles/dev-guide/dg_notes.html) + +##### Code style + +The {rtables} package follows the tidyverse [style guide](https://style.tidyverse.org/index.html) so please adhere to these guidelines in your submitted code. After making changes to a file within the package, you can apply the package styler automatically and check for lint by running the following two lines of code while within the file: + +``` +styler:::style_active_file() +lintr:::addin_lint() +``` + +##### Documentation + +Package documentation uses [`roxygen2`](https://roxygen2.r-lib.org/index.html). If your contribution requires updates to documentation, ensure that the roxygen comments are updated within the source code file. After updating roxygen documentation, run `devtools::document()` to update the accompanying `.Rd` files (do not update these files by hand!). + +##### Tests + +To ensure high code coverage, we create tests using the [`testthat`](https://testthat.r-lib.org/) package. In most cases, changes to package code necessitate the addition of one or more tests to ensure that any added features are working as expected and no existing features were broken. + +##### NEWS + +After making updates to the package, please add a descriptive entry to the NEWS file that reflects your changes. See the [tidyverse style guide](https://style.tidyverse.org/news.html) for guidelines on creating a NEWS entry. + +#### 3. Make a Pull Request + +Once the previous two steps are complete, you can create a pull request. Indicate in the description which issue is addressed in the pull request, and again utilize labels to help reviewers identify the category of the changes contained within the pull request. + +Once your pull request has been created, a series of checks will be automatically triggered, including `R CMD check`, tests/code coverage, auto-documentation, and more. All checks must be passing in order to eventually merge your pull request, and further changes may be required in order to resolve the status of these checks. All pull requests must also be reviewed and approved by at least one of the package maintainers before they can be merged. A review will be automatically requested from several {rtables} maintainers upon creating your pull request. When a maintainer reviews your pull request, please try to address the comments in short order - the {rtables} package is updated on a regular basis and leaving a pull request open too long is likely to result in merge conflicts which create more work for the developer. + +## Code of Conduct + +Please note that this project is released with a [Contributor Code of Conduct](CODE_OF_CONDUCT.html). By participating in this project you agree to abide by its terms. From b53574aafb16055579b65e643cc2ac831373f107 Mon Sep 17 00:00:00 2001 From: edelarua Date: Tue, 5 Dec 2023 18:00:57 +0000 Subject: [PATCH 25/27] [skip actions] Bump version to 0.6.5.9021 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 78b53b71a..f66e427b4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9020 -Date: 2023-12-01 +Version: 0.6.5.9021 +Date: 2023-12-05 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 6f4c6e4d9..a45f650a3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9020 +## rtables 0.6.5.9021 ### 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` From 278f0bb727fc89ecb579e88d3d390a55e2d4d78e Mon Sep 17 00:00:00 2001 From: Abinaya Yogasekaram <73252787+ayogasekaram@users.noreply.github.com> Date: Tue, 5 Dec 2023 13:31:12 -0500 Subject: [PATCH 26/27] migrate export_as_pdf (#798) * move remaining powerpoints inside the repo * migrate export_as_pdf * remove grid from imports * Update news file * update formatters version --- DESCRIPTION | 3 +- NAMESPACE | 15 +--- NEWS.md | 1 + R/tt_export.R | 167 ++----------------------------------------- man/export_as_pdf.Rd | 134 ---------------------------------- man/reexports.Rd | 16 ++++- 6 files changed, 24 insertions(+), 312 deletions(-) delete mode 100644 man/export_as_pdf.Rd diff --git a/DESCRIPTION b/DESCRIPTION index f66e427b4..200ddf3f9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,13 +29,12 @@ URL: https://github.com/insightsengineering/rtables, https://insightsengineering.github.io/rtables/ BugReports: https://github.com/insightsengineering/rtables/issues Depends: - formatters (>= 0.5.4.9003), + formatters (>= 0.5.4.9008), magrittr (>= 1.5), methods, R (>= 2.10) Imports: checkmate (>= 2.1.0), - grid, htmltools (>= 0.5.4), stats, stringi (>= 1.6) diff --git a/NAMESPACE b/NAMESPACE index b0ccfe48d..4e35c5200 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -284,21 +284,8 @@ exportMethods(value_at) import(formatters) import(methods) importFrom(formatters,do_forced_paginate) +importFrom(formatters,export_as_pdf) importFrom(formatters,export_as_txt) -importFrom(grDevices,dev.off) -importFrom(grDevices,pdf) -importFrom(grid,convertHeight) -importFrom(grid,convertWidth) -importFrom(grid,get.gpar) -importFrom(grid,gpar) -importFrom(grid,grid.draw) -importFrom(grid,grid.newpage) -importFrom(grid,grobHeight) -importFrom(grid,grobWidth) -importFrom(grid,plotViewport) -importFrom(grid,pushViewport) -importFrom(grid,textGrob) -importFrom(grid,unit) importFrom(htmltools,tagList) importFrom(htmltools,tags) importFrom(magrittr,"%>%") diff --git a/NEWS.md b/NEWS.md index a45f650a3..20c67c3fe 100644 --- a/NEWS.md +++ b/NEWS.md @@ -12,6 +12,7 @@ * Added `na_str` argument to `analyze_colvars` to set custom string to print in place of missing values. * Added flat `data.frame` outputs for `as_result_df()` via flag parameters `as_viewer`, `as_strings`, and `expand_colnames`. + * Migrated `export_as_pdf` function to `formatters`. ### Bug Fixes * Fixed a bug that was failing when wrapping and section dividers were used at the same time. diff --git a/R/tt_export.R b/R/tt_export.R index 709c520f4..f149d3122 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -445,44 +445,10 @@ collapse_values <- function(colvals) { # pdf output ------------------------------------------------------------------- #' Export as PDF -#' -#' The PDF output is based on the ASCII output created with `toString` -#' -#' @inheritParams formatters::export_as_txt -#' @inheritParams tostring -#' @inheritParams grid::plotViewport -#' @inheritParams paginate_table -#' @param file file to write, must have `.pdf` extension -#' @param width Deprecated, please use `pg_width` or specify -#' `page_type`. The width of the graphics region in inches -#' @param height Deprecated, please use `pg_height` or specify -#' `page_type`. The height of the graphics region in -#' inches -#' @param fontsize Deprecated, please use `font_size`. the size of -#' text (in points) -#' @param margins numeric(4). The number of lines/characters of margin on the -#' bottom, left, top, and right sides of the page. -#' @param ... arguments passed on to `paginate_table` -#' -#' @importFrom grDevices pdf -#' @importFrom grid textGrob grid.newpage gpar pushViewport plotViewport unit grid.draw -#' convertWidth convertHeight grobHeight grobWidth -#' -#' @details By default, pagination is performed, with default -#' `cpp` and `lpp` defined by specified page dimensions and margins. -#' User-specified `lpp` and `cpp` values override this, and should -#' be used with caution. -#' -#' Title and footer materials are also word-wrapped by default -#' (unlike when printed to the terminal), with `cpp`, as -#' defined above, as the default `max_width`. -#' -#' @seealso [formatters::export_as_txt()] -#' -#' -#' @importFrom grid textGrob get.gpar -#' @importFrom grDevices dev.off -#' @export + +### Migrated to formatters. + +#' @importFrom formatters export_as_pdf #' #' @examples #' lyt <- basic_table() %>% @@ -498,128 +464,8 @@ collapse_values <- function(colvals) { #' export_as_pdf(tbl, file = tf, lpp = 8) #' } #' -export_as_pdf <- function(tt, - file, - page_type = "letter", - landscape = FALSE, - pg_width = page_dim(page_type)[if (landscape) 2 else 1], - pg_height = page_dim(page_type)[if (landscape) 1 else 2], - width = NULL, - height = NULL, # passed to pdf() - margins = c(4, 4, 4, 4), - font_family = "Courier", - fontsize = 8, # grid parameters - font_size = fontsize, - paginate = TRUE, - lpp = NULL, - cpp = NULL, - hsep = "-", - indent_size = 2, - tf_wrap = TRUE, - max_width = NULL, - colwidths = propose_column_widths(matrix_form(tt, TRUE)), - ...) { # passed to paginate_table - stopifnot(file_ext(file) != ".pdf") - if (!is.null(colwidths) && length(colwidths) != ncol(tt) + 1) { - stop( - "non-null colwidths argument must have length ncol(tt) + 1 [", - ncol(tt) + 1, "], got length ", length(colwidths) - ) - } - - gp_plot <- gpar(fontsize = font_size, fontfamily = font_family) - - ## soft deprecation. To become hard deprecation. - if (!is.null(height)) { - pg_height <- height - } - - if (!is.null(width)) { - pg_width <- width - } - - if (missing(font_size) && !missing(fontsize)) { - font_size <- fontsize - } - - pdf(file = file, width = pg_width, height = pg_height) - on.exit(dev.off()) - grid.newpage() - pushViewport(plotViewport(margins = margins, gp = gp_plot)) - - cur_gpar <- get.gpar() - if (is.null(lpp)) { - lpp <- floor( - convertHeight(unit(1, "npc"), "lines", valueOnly = TRUE) / (cur_gpar$cex * cur_gpar$lineheight) - ) - sum(margins[c(1, 3)]) # bottom, top - } - if (is.null(cpp)) { - cpp <- floor( - convertWidth(unit(1, "npc"), "inches", valueOnly = TRUE) * - font_lcpi(font_family, font_size, cur_gpar$lineheight)$cpi - ) - sum(margins[c(2, 4)]) # left, right - } - if (tf_wrap && is.null(max_width)) { - max_width <- cpp - } - - tbls <- if (paginate) { - paginate_table(tt, - lpp = lpp, cpp = cpp, tf_wrap = tf_wrap, max_width = max_width, - colwidths = colwidths, ... - ) - } else { - list(tt) - } - stbls <- lapply(lapply( - tbls, - function(tbl_i) { - cinds <- c(1, .figure_out_colinds(tbl_i, tt) + 1L) - toString(tbl_i, - widths = colwidths[cinds], hsep = hsep, - indent_size = indent_size, tf_wrap = tf_wrap, - max_width = max_width - ) - } - ), function(xi) substr(xi, 1, nchar(xi) - nchar("\n"))) - gtbls <- lapply(stbls, function(txt) { - textGrob( - label = txt, - x = unit(0, "npc"), y = unit(1, "npc"), - just = c("left", "top") - ) - }) - - npages <- length(gtbls) - exceeds_width <- rep(FALSE, npages) - exceeds_height <- rep(FALSE, npages) - - for (i in seq_along(gtbls)) { - g <- gtbls[[i]] - - if (i > 1) { - grid.newpage() - pushViewport(plotViewport(margins = margins, gp = gp_plot)) - } - - if (convertHeight(grobHeight(g), "inches", valueOnly = TRUE) > - convertHeight(unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint - exceeds_height[i] <- TRUE - warning("height of page ", i, " exceeds the available space") - } - if (convertWidth(grobWidth(g), "inches", valueOnly = TRUE) > - convertWidth(unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint - exceeds_width[i] <- TRUE - warning("width of page ", i, " exceeds the available space") - } - - grid.draw(g) - } - list( - file = file, npages = npages, exceeds_width = exceeds_width, exceeds_height = exceeds_height, - lpp = lpp, cpp = cpp - ) -} +#' @export +formatters::export_as_pdf # only used in pagination .tab_to_colpath_set <- function(tt) { @@ -635,7 +481,6 @@ export_as_pdf <- function(tt, .tab_to_colpath_set(fulltab) ) } - # Flextable and docx ----------------------------------------------------------- #' Export as word document #' diff --git a/man/export_as_pdf.Rd b/man/export_as_pdf.Rd deleted file mode 100644 index df34fc3c8..000000000 --- a/man/export_as_pdf.Rd +++ /dev/null @@ -1,134 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tt_export.R -\name{export_as_pdf} -\alias{export_as_pdf} -\title{Export as PDF} -\usage{ -export_as_pdf( - tt, - file, - page_type = "letter", - landscape = FALSE, - pg_width = page_dim(page_type)[if (landscape) 2 else 1], - pg_height = page_dim(page_type)[if (landscape) 1 else 2], - width = NULL, - height = NULL, - margins = c(4, 4, 4, 4), - font_family = "Courier", - fontsize = 8, - font_size = fontsize, - paginate = TRUE, - lpp = NULL, - cpp = NULL, - hsep = "-", - indent_size = 2, - tf_wrap = TRUE, - max_width = NULL, - colwidths = propose_column_widths(matrix_form(tt, TRUE)), - ... -) -} -\arguments{ -\item{tt}{\code{TableTree} (or related class). A \code{TableTree} object representing a -populated table.} - -\item{file}{file to write, must have \code{.pdf} extension} - -\item{page_type}{character(1). Name of a page type. See -\code{page_types}. Ignored when \code{pg_width} and \code{pg_height} -are set directly.} - -\item{landscape}{logical(1). Should the dimensions of \code{page_type} -be inverted for landscape? Defaults to \code{FALSE}, ignored when -\code{pg_width} and \code{pg_height} are set directly.} - -\item{pg_width}{numeric(1). Page width in inches.} - -\item{pg_height}{numeric(1). Page height in inches.} - -\item{width}{Deprecated, please use \code{pg_width} or specify -\code{page_type}. The width of the graphics region in inches} - -\item{height}{Deprecated, please use \code{pg_height} or specify -\code{page_type}. The height of the graphics region in -inches} - -\item{margins}{numeric(4). The number of lines/characters of margin on the -bottom, left, top, and right sides of the page.} - -\item{font_family}{character(1). Name of a font family. An error -will be thrown if the family named is not monospaced. Defaults -to Courier.} - -\item{fontsize}{Deprecated, please use \code{font_size}. the size of -text (in points)} - -\item{font_size}{numeric(1). Font size, defaults to 12.} - -\item{paginate}{logical(1). Whether pagination should be performed, -defaults to \code{TRUE} if page size is specified (including -the default).} - -\item{lpp}{numeric(1) or NULL. Lines per page. if NA (the default, -this is calculated automatically based on the specified page -size). \code{NULL} indicates no vertical pagination should occur.} - -\item{cpp}{numeric(1) or NULL. Width in characters per page. if NA (the default, -this is calculated automatically based on the specified page -size). \code{NULL} indicates no horizontal pagination should occur.} - -\item{hsep}{character(1). Characters to repeat to create -header/body separator line. If \code{NULL}, the object value will be -used. If \code{" "}, an empty separator will be printed. Check \code{\link[formatters:default_hsep]{default_hsep()}} -for more information.} - -\item{indent_size}{numeric(1). Indent size in characters. Ignored -when \code{x} is already a \code{MatrixPrintForm} object in favor of information -there.} - -\item{tf_wrap}{logical(1). Should the texts for title, subtitle, -and footnotes be wrapped?} - -\item{max_width}{integer(1), character(1) or \code{NULL}. Width that title -and footer (including footnotes) materials should be -word-wrapped to. If \code{NULL}, it is set to the current print width -of the session (\code{getOption("width")}). If set to \code{"auto"}, -the width of the table (plus any table inset) is used. Ignored -completely if \code{tf_wrap} is \code{FALSE}.} - -\item{colwidths}{numeric vector. Column widths (in characters) for -use with vertical pagination.} - -\item{...}{arguments passed on to \code{paginate_table}} -} -\description{ -The PDF output is based on the ASCII output created with \code{toString} -} -\details{ -By default, pagination is performed, with default -\code{cpp} and \code{lpp} defined by specified page dimensions and margins. -User-specified \code{lpp} and \code{cpp} values override this, and should -be used with caution. - -Title and footer materials are also word-wrapped by default -(unlike when printed to the terminal), with \code{cpp}, as -defined above, as the default \code{max_width}. -} -\examples{ -lyt <- basic_table() \%>\% - split_cols_by("ARM") \%>\% - analyze(c("AGE", "BMRKR2", "COUNTRY")) - -tbl <- build_table(lyt, ex_adsl) - -\dontrun{ -tf <- tempfile(fileext = ".pdf") -export_as_pdf(tbl, file = tf, pg_height = 4) -tf <- tempfile(fileext = ".pdf") -export_as_pdf(tbl, file = tf, lpp = 8) -} - -} -\seealso{ -\code{\link[formatters:export_as_txt]{formatters::export_as_txt()}} -} diff --git a/man/reexports.Rd b/man/reexports.Rd index b48caffb5..e9b22573e 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -4,6 +4,7 @@ \name{reexports} \alias{reexports} \alias{export_as_txt} +\alias{export_as_pdf} \title{Objects exported from other packages} \examples{ lyt <- basic_table() \%>\% @@ -20,6 +21,19 @@ export_as_txt(tbl, file = tf) system2("cat", tf) } +lyt <- basic_table() \%>\% + split_cols_by("ARM") \%>\% + analyze(c("AGE", "BMRKR2", "COUNTRY")) + +tbl <- build_table(lyt, ex_adsl) + +\dontrun{ +tf <- tempfile(fileext = ".pdf") +export_as_pdf(tbl, file = tf, pg_height = 4) +tf <- tempfile(fileext = ".pdf") +export_as_pdf(tbl, file = tf, lpp = 8) +} + } \keyword{internal} \description{ @@ -27,6 +41,6 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{formatters}{\code{\link[formatters]{export_as_txt}}} + \item{formatters}{\code{\link[formatters]{export_as_pdf}}, \code{\link[formatters]{export_as_txt}}} }} From 82d78c15a9bd506a2515e87917d9cf1b07c1421b Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Tue, 5 Dec 2023 18:32:21 +0000 Subject: [PATCH 27/27] [skip actions] Bump version to 0.6.5.9022 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 200ddf3f9..15e51edb7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rtables Title: Reporting Tables -Version: 0.6.5.9021 +Version: 0.6.5.9022 Date: 2023-12-05 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", diff --git a/NEWS.md b/NEWS.md index 20c67c3fe..eb47fb389 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.5.9021 +## rtables 0.6.5.9022 ### 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`