From 3f1da9f0e5f6c5f5011380ea6c43357f2aeccdee Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Tue, 28 May 2024 20:23:31 +0000 Subject: [PATCH 01/19] use string matrix for initialization. --- R/as_html.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/as_html.R b/R/as_html.R index ffb9705d2..b45345ded 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -82,7 +82,7 @@ as_html <- function(x, 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()), (nlh + nrow(x)) * (nc)), ncol = nc) + cells <- matrix(rep(list(list()), (nlh + nrow(mat$strings)) * (nc)), ncol = nc) for (i in seq_len(nrow(mat$strings))) { for (j in seq_len(ncol(mat$strings))) { From 2d743ef506d2e3969c81303dbfa577055a5db515 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 28 May 2024 18:00:05 -0400 Subject: [PATCH 02/19] Clean up as_html - implement mf_* getters throughout func --- R/as_html.R | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index b45345ded..96e222d69 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -80,15 +80,16 @@ as_html <- function(x, nlh <- mf_nlheader(mat) nc <- ncol(x) + 1 + nr <- length(mf_lgrouping(mat)) # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions - cells <- matrix(rep(list(list()), (nlh + nrow(mat$strings)) * (nc)), ncol = nc) + cells <- matrix(rep(list(list()), (nlh + nr) * nc), ncol = nc) - for (i in seq_len(nrow(mat$strings))) { - for (j in seq_len(ncol(mat$strings))) { - curstrs <- mat$strings[i, j] - curspn <- mat$spans[i, j] - algn <- mat$aligns[i, j] + for (i in seq_len(nr)) { + for (j in seq_len(ncol(mf_strings(mat)))) { + curstrs <- mf_strings(mat)[i, j] + curspn <- mf_spans(mat)[i, j] + algn <- mf_aligns(mat)[i, j] inhdr <- i <= nlh tagfun <- if (inhdr) tags$th else tags$td @@ -112,7 +113,7 @@ as_html <- function(x, # row labels style for (i in seq_len(nrow(x))) { - indent <- mat$row_info$indent[i] + indent <- mf_rinfo(mat)$indent[i] if (indent > 0) { # indentation cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes(cells[i + nlh, 1][[1]], style = paste0("padding-left: ", indent * 3, "ch;") @@ -128,7 +129,7 @@ as_html <- function(x, # label rows style if ("label_rows" %in% bold) { - which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") + which_lbl_rows <- which(mf_rinfo(mat)$node_class == "LabelRow") cells[which_lbl_rows + nlh, ] <- lapply( cells[which_lbl_rows + nlh, ], htmltools::tagAppendAttributes, @@ -138,7 +139,7 @@ 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")) + which_cntnt_rows <- which(mf_rinfo(mat)$node_class %in% c("ContentRow", "DataRow")) cells[which_cntnt_rows + nlh, ] <- lapply( cells[which_cntnt_rows + nlh, ], htmltools::tagAppendAttributes, @@ -146,14 +147,14 @@ as_html <- function(x, ) } - if (any(!mat$display)) { + if (any(!mf_display(mat))) { # Check that expansion kept the same display info check_expansion <- c() - for (ii in unique(mat$line_grouping)) { - rows <- which(mat$line_grouping == ii) + for (ii in unique(mf_lgrouping(mat))) { + rows <- which(mf_lgrouping(mat) == ii) check_expansion <- c( check_expansion, - apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) + apply(mf_display(mat)[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) ) } @@ -165,9 +166,9 @@ as_html <- function(x, ) # nocov } - for (ii in unique(mat$line_grouping)) { - rows <- which(mat$line_grouping == ii) - should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any) + for (ii in unique(mf_lgrouping(mat))) { + rows <- which(mf_lgrouping(mat) == ii) + should_display_col <- apply(mf_display(mat)[rows, , drop = FALSE], 2, any) cells[ii, !should_display_col] <- NA_integer_ } } @@ -220,7 +221,7 @@ as_html <- function(x, rfnotes <- div_helper( class = "rtables-ref-footnotes-block", - lapply(mat$ref_footnotes, tags$p, + lapply(mf_rfnotes(mat), tags$p, class = "rtables-referential-footnote" ) ) @@ -242,8 +243,8 @@ as_html <- function(x, ## XXX this omits the divs entirely if they are empty. Do we want that or do ## 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(mf_rfnotes(mat)) > 0) rfnotes, + if (length(mf_rfnotes(mat)) > 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 From e2beff23f8e6adc501783fd6c733685256613f4c Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Wed, 29 May 2024 00:20:47 +0000 Subject: [PATCH 03/19] update wordlist --- inst/WORDLIST | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/inst/WORDLIST b/inst/WORDLIST index 85eef8d0e..0274737d2 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,3 +1,4 @@ +Bové CRAN's Carreras Cheatsheet @@ -21,6 +22,7 @@ RStudio Resync Rua STUDYID +Sabanés Saibah Stoilova Subtable @@ -42,6 +44,7 @@ facetting flextable formatter funder +funs getter getters ing @@ -52,12 +55,14 @@ layouting mandatorily multivariable orderable +params pathing postfix postprocessing pre priori programmatically +quartiles reindexed repo repped From eabaeffca964b112dcbc9d91abeaf8df708e44e1 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 30 May 2024 17:39:43 -0400 Subject: [PATCH 04/19] Fix random URL --- vignettes/introduction.Rmd | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 681ce562d..e85986c1b 100644 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -28,10 +28,9 @@ tabulating a table. The content in this vignette is based on the following two resources: -* The [`rtables` useR 2020 presentation](https://www.youtube.com/watch?v=CBQzZ8ZhXLA) -by Gabriel Becker -* [`rtables` - A Framework For Creating Complex Structured Reporting Tables Via -Multi-Level Faceted Computations](https://arxiv.org/pdf/2306.16610.pdf). +* [rtables useR 2020 presentation](https://www.youtube.com/watch?v=CBQzZ8ZhXLA) by Gabriel Becker +* [rtables - A Framework For Creating Complex Structured Reporting Tables Via +Multi-Level Faceted Computations](http://arxiv.org/pdf/2306.16610) by Gabriel Becker and Adrian Waddell The packages used in this vignette are `rtables` and `dplyr`: From 67086571c112c85e92c913994237d43a2ca6f312 Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Thu, 6 Jun 2024 21:27:07 +0000 Subject: [PATCH 05/19] add indentation logic to allow newline characters. --- R/as_html.R | 80 ++++++++++++++++++++++++++++------------------------- 1 file changed, 42 insertions(+), 38 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index 96e222d69..e6ec847b5 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -73,24 +73,24 @@ as_html <- function(x, if (is.null(x)) { return(tags$p("Empty Table")) } - + stopifnot(is(x, "VTableTree")) - + mat <- matrix_form(x, indent_rownames = TRUE) - + nlh <- mf_nlheader(mat) nc <- ncol(x) + 1 nr <- length(mf_lgrouping(mat)) - + # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions cells <- matrix(rep(list(list()), (nlh + nr) * nc), ncol = nc) - + for (i in seq_len(nr)) { for (j in seq_len(ncol(mf_strings(mat)))) { curstrs <- mf_strings(mat)[i, j] curspn <- mf_spans(mat)[i, j] algn <- mf_aligns(mat)[i, j] - + inhdr <- i <= nlh tagfun <- if (inhdr) tags$th else tags$td cells[i, j][[1]] <- tagfun( @@ -103,21 +103,25 @@ as_html <- function(x, ) } } - + if (header_sep_line) { cells[nlh][[1]] <- htmltools::tagAppendAttributes( cells[nlh, 1][[1]], style = "border-bottom: 1px solid black;" ) } - + # row labels style - for (i in seq_len(nrow(x))) { - indent <- mf_rinfo(mat)$indent[i] - if (indent > 0) { # indentation - cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes(cells[i + nlh, 1][[1]], - style = paste0("padding-left: ", indent * 3, "ch;") - ) + for (i in 1:nr) { + if (i > nlh) { + # Adjust the index for accessing the indent matrix to account for the header values + indentIndex <- i - nlh + indent <- mat$row_info[mat$line_grouping[indentIndex], "indent"] + if (!is.na(indent) && indent > 0) { # Check for NA and indentation + 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 + nlh, 1][[1]] <- htmltools::tagAppendAttributes( @@ -126,7 +130,7 @@ as_html <- function(x, ) } } - + # label rows style if ("label_rows" %in% bold) { which_lbl_rows <- which(mf_rinfo(mat)$node_class == "LabelRow") @@ -136,7 +140,7 @@ as_html <- function(x, style = "font-weight: bold;" ) } - + # content rows style if ("content_rows" %in% bold) { which_cntnt_rows <- which(mf_rinfo(mat)$node_class %in% c("ContentRow", "DataRow")) @@ -146,7 +150,7 @@ as_html <- function(x, style = "font-weight: bold;" ) } - + if (any(!mf_display(mat))) { # Check that expansion kept the same display info check_expansion <- c() @@ -157,7 +161,7 @@ as_html <- function(x, apply(mf_display(mat)[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) ) } - + if (!all(check_expansion)) { stop( "Found that a group of rows have different display options even if ", @@ -165,14 +169,14 @@ as_html <- function(x, "file an issue or report to the maintainers." ) # nocov } - + for (ii in unique(mf_lgrouping(mat))) { rows <- which(mf_lgrouping(mat) == ii) should_display_col <- apply(mf_display(mat)[rows, , drop = FALSE], 2, any) cells[ii, !should_display_col] <- NA_integer_ } } - + rows <- apply(cells, 1, function(row) { tags$tr( class = class_tr, @@ -180,27 +184,27 @@ as_html <- function(x, 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), if ("main_title" %in% bold) tags$b else tags$p, - class = "rtables-main-title" + class = "rtables-main-title" ) ), div_helper( class = "rtables-subtitles-block", lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p, - class = "rtables-subtitle" + class = "rtables-subtitle" ) ) ) ) - + tabletag <- do.call( tags$table, c( @@ -212,34 +216,34 @@ as_html <- function(x, if (!is.null(width)) paste("width:", width) ), tags$caption(sprintf("(\\#tag:%s)", link_label), - style = "caption-side: top;", - .noWS = "after-begin" + style = "caption-side: top;", + .noWS = "after-begin" ) ) ) ) - + rfnotes <- div_helper( class = "rtables-ref-footnotes-block", lapply(mf_rfnotes(mat), tags$p, - class = "rtables-referential-footnote" + class = "rtables-referential-footnote" ) ) - + mftr <- div_helper( class = "rtables-main-footers-block", lapply(main_footer(x), tags$p, - class = "rtables-main-footer" + class = "rtables-main-footer" ) ) - + pftr <- div_helper( class = "rtables-prov-footers-block", lapply(prov_footer(x), tags$p, - class = "rtables-prov-footer" + class = "rtables-prov-footer" ) ) - + ## XXX this omits the divs entirely if they are empty. Do we want that or do ## we want them to be there but empty?? ftrlst <- list( @@ -249,15 +253,15 @@ as_html <- function(x, 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( class = "rtables-footers-block", ftrlst ) - + div_helper( class = "rtables-all-parts-block", list( @@ -266,4 +270,4 @@ as_html <- function(x, ftrtag ) ) -} +} \ No newline at end of file From ccae0fdb127238209c1a13bcc9298ff4544bbd32 Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Fri, 7 Jun 2024 18:48:01 +0000 Subject: [PATCH 06/19] remove indentation logic --- R/as_html.R | 48 ++++++++++++++---------------------------------- 1 file changed, 14 insertions(+), 34 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index e6ec847b5..3d2f3bec4 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -83,10 +83,10 @@ as_html <- function(x, nr <- length(mf_lgrouping(mat)) # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions - cells <- matrix(rep(list(list()), (nlh + nr) * nc), ncol = nc) + cells <- matrix(rep(list(list()), (nr) * (nc)), ncol = nc) for (i in seq_len(nr)) { - for (j in seq_len(ncol(mf_strings(mat)))) { + for (j in seq_len(nc)) { curstrs <- mf_strings(mat)[i, j] curspn <- mf_spans(mat)[i, j] algn <- mf_aligns(mat)[i, j] @@ -111,29 +111,9 @@ as_html <- function(x, ) } - # row labels style - for (i in 1:nr) { - if (i > nlh) { - # Adjust the index for accessing the indent matrix to account for the header values - indentIndex <- i - nlh - indent <- mat$row_info[mat$line_grouping[indentIndex], "indent"] - if (!is.na(indent) && indent > 0) { # Check for NA and indentation - 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 + nlh, 1][[1]] <- htmltools::tagAppendAttributes( - cells[i + nlh, 1][[1]], - style = paste0("font-weight: bold;") - ) - } - } - # label rows style if ("label_rows" %in% bold) { - which_lbl_rows <- which(mf_rinfo(mat)$node_class == "LabelRow") + which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") cells[which_lbl_rows + nlh, ] <- lapply( cells[which_lbl_rows + nlh, ], htmltools::tagAppendAttributes, @@ -143,7 +123,7 @@ as_html <- function(x, # content rows style if ("content_rows" %in% bold) { - which_cntnt_rows <- which(mf_rinfo(mat)$node_class %in% c("ContentRow", "DataRow")) + which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow")) cells[which_cntnt_rows + nlh, ] <- lapply( cells[which_cntnt_rows + nlh, ], htmltools::tagAppendAttributes, @@ -151,14 +131,14 @@ as_html <- function(x, ) } - if (any(!mf_display(mat))) { + if (any(!mat$display)) { # Check that expansion kept the same display info check_expansion <- c() - for (ii in unique(mf_lgrouping(mat))) { - rows <- which(mf_lgrouping(mat) == ii) + for (ii in unique(mat$line_grouping)) { + rows <- which(mat$line_grouping == ii) check_expansion <- c( check_expansion, - apply(mf_display(mat)[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) + apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) ) } @@ -170,9 +150,9 @@ as_html <- function(x, ) # nocov } - for (ii in unique(mf_lgrouping(mat))) { - rows <- which(mf_lgrouping(mat) == ii) - should_display_col <- apply(mf_display(mat)[rows, , drop = FALSE], 2, any) + for (ii in unique(mat$line_grouping)) { + rows <- which(mat$line_grouping == ii) + should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any) cells[ii, !should_display_col] <- NA_integer_ } } @@ -225,7 +205,7 @@ as_html <- function(x, rfnotes <- div_helper( class = "rtables-ref-footnotes-block", - lapply(mf_rfnotes(mat), tags$p, + lapply(mat$ref_footnotes, tags$p, class = "rtables-referential-footnote" ) ) @@ -247,8 +227,8 @@ as_html <- function(x, ## XXX this omits the divs entirely if they are empty. Do we want that or do ## we want them to be there but empty?? ftrlst <- list( - if (length(mf_rfnotes(mat)) > 0) rfnotes, - if (length(mf_rfnotes(mat)) > 0) hsep_line, + 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 From 8c7db101bcd2cf36cc8f7288e21a157edd9d3a78 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 7 Jun 2024 18:50:14 +0000 Subject: [PATCH 07/19] [skip style] [skip vbump] Restyle files --- R/as_html.R | 62 ++++++++++++++++++++++++++--------------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index 3d2f3bec4..1d930703e 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -73,24 +73,24 @@ as_html <- function(x, if (is.null(x)) { return(tags$p("Empty Table")) } - + stopifnot(is(x, "VTableTree")) - + mat <- matrix_form(x, indent_rownames = TRUE) - + nlh <- mf_nlheader(mat) nc <- ncol(x) + 1 nr <- length(mf_lgrouping(mat)) - + # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions cells <- matrix(rep(list(list()), (nr) * (nc)), ncol = nc) - + for (i in seq_len(nr)) { for (j in seq_len(nc)) { curstrs <- mf_strings(mat)[i, j] curspn <- mf_spans(mat)[i, j] algn <- mf_aligns(mat)[i, j] - + inhdr <- i <= nlh tagfun <- if (inhdr) tags$th else tags$td cells[i, j][[1]] <- tagfun( @@ -103,14 +103,14 @@ as_html <- function(x, ) } } - + if (header_sep_line) { cells[nlh][[1]] <- htmltools::tagAppendAttributes( cells[nlh, 1][[1]], style = "border-bottom: 1px solid black;" ) } - + # label rows style if ("label_rows" %in% bold) { which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") @@ -120,7 +120,7 @@ as_html <- function(x, 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")) @@ -130,7 +130,7 @@ as_html <- function(x, style = "font-weight: bold;" ) } - + if (any(!mat$display)) { # Check that expansion kept the same display info check_expansion <- c() @@ -141,7 +141,7 @@ as_html <- function(x, apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) ) } - + if (!all(check_expansion)) { stop( "Found that a group of rows have different display options even if ", @@ -149,14 +149,14 @@ as_html <- function(x, "file an issue or report to the maintainers." ) # nocov } - + for (ii in unique(mat$line_grouping)) { rows <- which(mat$line_grouping == ii) should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any) cells[ii, !should_display_col] <- NA_integer_ } } - + rows <- apply(cells, 1, function(row) { tags$tr( class = class_tr, @@ -164,27 +164,27 @@ as_html <- function(x, 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), if ("main_title" %in% bold) tags$b else tags$p, - class = "rtables-main-title" + class = "rtables-main-title" ) ), div_helper( class = "rtables-subtitles-block", lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p, - class = "rtables-subtitle" + class = "rtables-subtitle" ) ) ) ) - + tabletag <- do.call( tags$table, c( @@ -196,34 +196,34 @@ as_html <- function(x, if (!is.null(width)) paste("width:", width) ), tags$caption(sprintf("(\\#tag:%s)", link_label), - style = "caption-side: top;", - .noWS = "after-begin" + style = "caption-side: top;", + .noWS = "after-begin" ) ) ) ) - + rfnotes <- div_helper( class = "rtables-ref-footnotes-block", lapply(mat$ref_footnotes, tags$p, - class = "rtables-referential-footnote" + class = "rtables-referential-footnote" ) ) - + mftr <- div_helper( class = "rtables-main-footers-block", lapply(main_footer(x), tags$p, - class = "rtables-main-footer" + class = "rtables-main-footer" ) ) - + pftr <- div_helper( class = "rtables-prov-footers-block", lapply(prov_footer(x), tags$p, - class = "rtables-prov-footer" + class = "rtables-prov-footer" ) ) - + ## XXX this omits the divs entirely if they are empty. Do we want that or do ## we want them to be there but empty?? ftrlst <- list( @@ -233,15 +233,15 @@ as_html <- function(x, 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( class = "rtables-footers-block", ftrlst ) - + div_helper( class = "rtables-all-parts-block", list( @@ -250,4 +250,4 @@ as_html <- function(x, ftrtag ) ) -} \ No newline at end of file +} From cdd3274a1cb3e009b3fd282732d112d0de12bd53 Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Fri, 7 Jun 2024 19:07:29 +0000 Subject: [PATCH 08/19] add styler --- R/as_html.R | 61 ++++++++++++++++++++++++++--------------------------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index 3d2f3bec4..b09827e0a 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -73,24 +73,23 @@ as_html <- function(x, if (is.null(x)) { return(tags$p("Empty Table")) } - stopifnot(is(x, "VTableTree")) - + mat <- matrix_form(x, indent_rownames = TRUE) - + nlh <- mf_nlheader(mat) nc <- ncol(x) + 1 nr <- length(mf_lgrouping(mat)) - + # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions cells <- matrix(rep(list(list()), (nr) * (nc)), ncol = nc) - + for (i in seq_len(nr)) { for (j in seq_len(nc)) { curstrs <- mf_strings(mat)[i, j] curspn <- mf_spans(mat)[i, j] algn <- mf_aligns(mat)[i, j] - + inhdr <- i <= nlh tagfun <- if (inhdr) tags$th else tags$td cells[i, j][[1]] <- tagfun( @@ -103,14 +102,14 @@ as_html <- function(x, ) } } - + if (header_sep_line) { cells[nlh][[1]] <- htmltools::tagAppendAttributes( cells[nlh, 1][[1]], style = "border-bottom: 1px solid black;" ) } - + # label rows style if ("label_rows" %in% bold) { which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") @@ -120,7 +119,7 @@ as_html <- function(x, 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")) @@ -130,7 +129,7 @@ as_html <- function(x, style = "font-weight: bold;" ) } - + if (any(!mat$display)) { # Check that expansion kept the same display info check_expansion <- c() @@ -141,7 +140,7 @@ as_html <- function(x, apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) ) } - + if (!all(check_expansion)) { stop( "Found that a group of rows have different display options even if ", @@ -149,14 +148,14 @@ as_html <- function(x, "file an issue or report to the maintainers." ) # nocov } - + for (ii in unique(mat$line_grouping)) { rows <- which(mat$line_grouping == ii) should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any) cells[ii, !should_display_col] <- NA_integer_ } } - + rows <- apply(cells, 1, function(row) { tags$tr( class = class_tr, @@ -164,27 +163,27 @@ as_html <- function(x, 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), if ("main_title" %in% bold) tags$b else tags$p, - class = "rtables-main-title" + class = "rtables-main-title" ) ), div_helper( class = "rtables-subtitles-block", lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p, - class = "rtables-subtitle" + class = "rtables-subtitle" ) ) ) ) - + tabletag <- do.call( tags$table, c( @@ -196,34 +195,34 @@ as_html <- function(x, if (!is.null(width)) paste("width:", width) ), tags$caption(sprintf("(\\#tag:%s)", link_label), - style = "caption-side: top;", - .noWS = "after-begin" + style = "caption-side: top;", + .noWS = "after-begin" ) ) ) ) - + rfnotes <- div_helper( class = "rtables-ref-footnotes-block", lapply(mat$ref_footnotes, tags$p, - class = "rtables-referential-footnote" + class = "rtables-referential-footnote" ) ) - + mftr <- div_helper( class = "rtables-main-footers-block", lapply(main_footer(x), tags$p, - class = "rtables-main-footer" + class = "rtables-main-footer" ) ) - + pftr <- div_helper( class = "rtables-prov-footers-block", lapply(prov_footer(x), tags$p, - class = "rtables-prov-footer" + class = "rtables-prov-footer" ) ) - + ## XXX this omits the divs entirely if they are empty. Do we want that or do ## we want them to be there but empty?? ftrlst <- list( @@ -233,15 +232,15 @@ as_html <- function(x, 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( class = "rtables-footers-block", ftrlst ) - + div_helper( class = "rtables-all-parts-block", list( @@ -250,4 +249,4 @@ as_html <- function(x, ftrtag ) ) -} \ No newline at end of file +} From 5be801c378ada4eacde0142dcbb479c5efb3a8c2 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 7 Jun 2024 16:16:54 -0400 Subject: [PATCH 09/19] Resolve partial argument match warning in tests - unrelated to as_html --- R/make_split_fun.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/make_split_fun.R b/R/make_split_fun.R index aff197de1..acceb40e0 100644 --- a/R/make_split_fun.R +++ b/R/make_split_fun.R @@ -348,7 +348,7 @@ add_combo_facet <- function(name, label = name, levels, extra = list()) { subexpr <- expression(TRUE) datpart <- list(fulldf) } else { - subexpr <- .combine_value_exprs(ret$value[levels]) + subexpr <- .combine_value_exprs(ret$values[levels]) datpart <- list(do.call(rbind, ret$datasplit[levels])) } From 6e592247e9c8ef0b962074275d1e6d78348b1469 Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Fri, 7 Jun 2024 20:46:59 +0000 Subject: [PATCH 10/19] remove just indenting code. --- R/as_html.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/R/as_html.R b/R/as_html.R index 1d930703e..d7a9a7e7d 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -111,6 +111,16 @@ as_html <- function(x, ) } + # row labels style + for (i in seq_len((nr - nlh))) { + if ("row_names" %in% bold) { # font weight + cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes( + cells[i + nlh, 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") From 4512fce7b8b3eb0a669aa797ddce53a436c523a4 Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Mon, 10 Jun 2024 22:17:13 +0000 Subject: [PATCH 11/19] reintroduce indentation code. Add mapping b/w linegrouping and indenting values --- R/as_html.R | 40 +++++++++++++++++++++++++--------------- 1 file changed, 25 insertions(+), 15 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index d7a9a7e7d..9444875af 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -111,24 +111,34 @@ as_html <- function(x, ) } - # row labels style - for (i in seq_len((nr - nlh))) { - if ("row_names" %in% bold) { # font weight - cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes( - cells[i + nlh, 1][[1]], - style = paste0("font-weight: bold;") + # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh + map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping) + row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh) + map <- merge(map, row_info_df, by = "abs_rownumber") + + # add indent values for headerlines + map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map) + + + # Row labels style + for (i in seq_len(nr)) { + indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1) + + # Apply indentation + if (indent > 0) { + cells[i, 1][[1]] <- htmltools::tagAppendAttributes( + cells[i, 1][[1]], + style = paste0("padding-left: ", indent * 3, "ch;") ) } - } - # label rows style - if ("label_rows" %in% bold) { - which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") - cells[which_lbl_rows + nlh, ] <- lapply( - cells[which_lbl_rows + nlh, ], - htmltools::tagAppendAttributes, - style = "font-weight: bold;" - ) + # Apply bold font weight if "row_names" is in 'bold' + if ("row_names" %in% bold) { + cells[i, 1][[1]] <- htmltools::tagAppendAttributes( + cells[i, 1][[1]], + style = "font-weight: bold;" + ) + } } # content rows style From c0a241cfa487d08f1f6ee95c0f73f1d5da3737b1 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Tue, 11 Jun 2024 09:21:57 +0000 Subject: [PATCH 12/19] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/formatters_methods.Rd | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/man/formatters_methods.Rd b/man/formatters_methods.Rd index d01128163..6a7767a00 100644 --- a/man/formatters_methods.Rd +++ b/man/formatters_methods.Rd @@ -119,7 +119,7 @@ \S4method{table_inset}{InstantiatedColumnInfo}(obj) <- value -\S4method{nlines}{TableRow}(x, colwidths = NULL, max_width = NULL, fontspec = NULL, col_gap = 3) +\S4method{nlines}{TableRow}(x, colwidths = NULL, max_width = NULL, fontspec, col_gap = 3) \S4method{nlines}{LabelRow}( x, @@ -129,9 +129,9 @@ col_gap = NULL ) -\S4method{nlines}{RefFootnote}(x, colwidths = NULL, max_width = NULL, fontspec = NULL, col_gap = NULL) +\S4method{nlines}{RefFootnote}(x, colwidths = NULL, max_width = NULL, fontspec, col_gap = NULL) -\S4method{nlines}{InstantiatedColumnInfo}(x, colwidths = NULL, max_width = NULL, fontspec = NULL, col_gap = 3) +\S4method{nlines}{InstantiatedColumnInfo}(x, colwidths = NULL, max_width = NULL, fontspec, col_gap = 3) \S4method{make_row_df}{VTableTree}( tt, From dc52a5786287eefe29cd2d4949a8e084fb8e1e7b Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Tue, 11 Jun 2024 11:12:59 +0000 Subject: [PATCH 13/19] update news --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 0acaf7bf5..8cd9e0701 100644 --- a/NEWS.md +++ b/NEWS.md @@ -21,6 +21,7 @@ * Fixed bug in `as_html` preventing indentation from being applied in `Viewer` output. * `col_counts<-` and `col_total<-` methods now explicitly convert `value` to integer, by @gmbecker. * `col_gap` is now respected in `nlines` row methods, and thus by `make_row_df`, by @gmbecker. + * update `as_html` to accommodate `\n` characters. ### Miscellaneous From 30cd0db4c9dad0960900662a805fc0dcb0c1aea0 Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Tue, 11 Jun 2024 12:18:35 +0000 Subject: [PATCH 14/19] apply comments from review --- NEWS.md | 2 +- R/as_html.R | 14 ++++++++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8cd9e0701..42d11e93e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -21,7 +21,7 @@ * Fixed bug in `as_html` preventing indentation from being applied in `Viewer` output. * `col_counts<-` and `col_total<-` methods now explicitly convert `value` to integer, by @gmbecker. * `col_gap` is now respected in `nlines` row methods, and thus by `make_row_df`, by @gmbecker. - * update `as_html` to accommodate `\n` characters. + * Updated `as_html` to accommodate `\n` characters. ### Miscellaneous diff --git a/R/as_html.R b/R/as_html.R index 9444875af..caf7feb58 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -83,7 +83,7 @@ as_html <- function(x, nr <- length(mf_lgrouping(mat)) # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions - cells <- matrix(rep(list(list()), (nr) * (nc)), ncol = nc) + cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc) for (i in seq_len(nr)) { for (j in seq_len(nc)) { @@ -140,7 +140,17 @@ 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 + nlh, ] <- lapply( + cells[which_lbl_rows + nlh, ], + 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")) From 63c80a6de7cc89c6619611857b1f7970aa9d257a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 11 Jun 2024 14:46:53 +0000 Subject: [PATCH 15/19] [skip style] [skip vbump] Restyle files --- R/as_html.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/as_html.R b/R/as_html.R index caf7feb58..889c06d5c 100644 --- a/R/as_html.R +++ b/R/as_html.R @@ -140,7 +140,7 @@ as_html <- function(x, ) } } - + # label rows style if ("label_rows" %in% bold) { which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") @@ -150,7 +150,7 @@ as_html <- function(x, 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")) From 42bbc0a7a5a835bdb53ce6b9ba8e9dd0053cc4fd Mon Sep 17 00:00:00 2001 From: ayogasekaram Date: Wed, 12 Jun 2024 13:37:18 +0000 Subject: [PATCH 16/19] add regression test --- tests/testthat/test-exporters.R | 35 +++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index c11103921..e9ba8b56a 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -293,6 +293,41 @@ test_that("as_html header line works", { expect_true(all(sapply(1:4, function(x) "border-bottom: 1px solid black;" %in% html_parts[[x]]$attribs))) }) +# https://github.com/insightsengineering/rtables/issues/872 +test_that("as_html indentation is translated to rows with linebreaks", { + lyt <- basic_table() %>% + split_cols_by("ARM") %>% + split_rows_by("SEX") %>% + analyze("AGE", afun = function(x) { + mn <- round(mean(x), 2) + if (!is.nan(mn) && mn > mean(DM$AGE)) { + val <- paste(mn, " ^ ", sep = "\n") + } else { + val <- paste(mn) + } + in_rows(my_row_label = rcell(val, + format = "xx" + )) + }) + tbl <- build_table(lyt, DM) + + mat <- matrix_form(tbl, indent_rownames = TRUE) + nr <- length(mf_lgrouping(mat)) + nlh <- mf_nlheader(mat) + + # as_html mapping internals + map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping) + row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh) + map <- merge(map, row_info_df, by = "abs_rownumber") + + # add indent values for headerlines + map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map) + + expect_equal(length(map$indent), length(map$lines)) + suppressWarnings(expect_true(all(map$indent[map$abs_rownumber == "3"], 1))) + + }) + ## https://github.com/insightsengineering/rtables/issues/308 test_that("path_enriched_df works for tables with a column that has all length 1 elements", { my_table <- basic_table() %>% From 355708b1102c26cb2a66a55fe7e5d83abd567a95 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 12 Jun 2024 13:39:32 +0000 Subject: [PATCH 17/19] [skip style] [skip vbump] Restyle files --- tests/testthat/test-exporters.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index e9ba8b56a..ca5592962 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -306,27 +306,26 @@ test_that("as_html indentation is translated to rows with linebreaks", { val <- paste(mn) } in_rows(my_row_label = rcell(val, - format = "xx" + format = "xx" )) }) tbl <- build_table(lyt, DM) - + mat <- matrix_form(tbl, indent_rownames = TRUE) nr <- length(mf_lgrouping(mat)) nlh <- mf_nlheader(mat) - + # as_html mapping internals map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping) row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh) map <- merge(map, row_info_df, by = "abs_rownumber") - + # add indent values for headerlines map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map) - + expect_equal(length(map$indent), length(map$lines)) suppressWarnings(expect_true(all(map$indent[map$abs_rownumber == "3"], 1))) - - }) +}) ## 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 cec443ba9349b6610a90bc923451d975540856aa Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 12 Jun 2024 17:28:44 +0200 Subject: [PATCH 18/19] change in testing policy --- tests/testthat/test-exporters.R | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index ca5592962..c256d730c 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -310,21 +310,17 @@ test_that("as_html indentation is translated to rows with linebreaks", { )) }) tbl <- build_table(lyt, DM) - - mat <- matrix_form(tbl, indent_rownames = TRUE) - nr <- length(mf_lgrouping(mat)) - nlh <- mf_nlheader(mat) - - # as_html mapping internals - map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping) - row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh) - map <- merge(map, row_info_df, by = "abs_rownumber") - - # add indent values for headerlines - map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map) - - expect_equal(length(map$indent), length(map$lines)) - suppressWarnings(expect_true(all(map$indent[map$abs_rownumber == "3"], 1))) + + # Resolves correctly \n + expect_silent(res <- as_html(tbl)) + expect_equal( + as.character(res$children[[1]][[2]]$children[[7]]$children[[1]][[1]]), + '' + ) + expect_equal( + as.character(res$children[[1]][[2]]$children[[7]]$children[[1]][[2]]), + ' ^ ' + ) }) ## https://github.com/insightsengineering/rtables/issues/308 From 4b8e11390023f6b99c6186b6c2d3e07f1398bf7f Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 12 Jun 2024 15:31:00 +0000 Subject: [PATCH 19/19] [skip style] [skip vbump] Restyle files --- tests/testthat/test-exporters.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index c256d730c..b5bcc7941 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -310,7 +310,7 @@ test_that("as_html indentation is translated to rows with linebreaks", { )) }) tbl <- build_table(lyt, DM) - + # Resolves correctly \n expect_silent(res <- as_html(tbl)) expect_equal(