From 09019489357aaa14f9dd66f2e62c16608944761a Mon Sep 17 00:00:00 2001 From: mrcaseb Date: Sat, 9 Mar 2024 23:27:31 +0100 Subject: [PATCH 1/2] Two column layout with high level header --- DESCRIPTION | 4 +- R/two-column-layouts.R | 77 ++++++++++++++++++++++++++++++++++--- man/gt_two_column_layout.Rd | 7 +++- 3 files changed, 78 insertions(+), 10 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9f19598..fe41e60 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: gtExtras Title: Extending 'gt' for Beautiful HTML Tables -Version: 0.5.0.9004 +Version: 0.5.0.9005 Authors@R: c( person("Thomas", "Mock", , "j.thomasmock@gmail.com", role = c("aut", "cre", "cph")), person("Daniel D.", "Sjoberg", , "danield.sjoberg@gmail.com", role = "ctb", @@ -48,6 +48,6 @@ Suggests: xml2 (>= 1.3.3) Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Config/testthat/edition: 3 Config/testthat/parallel: true diff --git a/R/two-column-layouts.R b/R/two-column-layouts.R index 4afdc74..11eea08 100644 --- a/R/two-column-layouts.R +++ b/R/two-column-layouts.R @@ -96,6 +96,7 @@ gt_double_table <- function(data, gt_fn, nrows = NULL, noisy = TRUE) { #' @param ... Additional arguments passed to `webshot2::webshot()`, only to be used if `output = "save"`, saving the two-column layout tables to disk as a `.png`. #' @param zoom Argument to `webshot2::webshot()`. A number specifying the zoom factor. A zoom factor of 2 will result in twice as many pixels vertically and horizontally. Note that using 2 is not exactly the same as taking a screenshot on a HiDPI (Retina) device: it is like increasing the zoom to 200 doubling the height and width of the browser window. This differs from using a HiDPI device because some web pages load different, higher-resolution images when they know they will be displayed on a HiDPI device (but using zoom will not report that there is a HiDPI device). #' @param expand Argument to `webshot2::webshot()`. A numeric vector specifying how many pixels to expand the clipping rectangle by. If one number, the rectangle will be expanded by that many pixels on all sides. If four numbers, they specify the top, right, bottom, and left, in that order. When taking screenshots of multiple URLs, this parameter can also be a list with same length as url with each element of the list containing a single number or four numbers to use for the corresponding URL. +#' @param tab_header_from If `NULL` (the default) renders tab headers of each table individually. If one of "table1" or "table2", the function extracts tab header information (including styling) from table 1 or table 2 respectively and renders it as high level header for the combined view (individual headers will be removed). #' @return Saves a `.png` to disk if `output = "save"`, returns HTML to the viewer via `htmltools::browsable()` when `output = "viewer"`, or returns raw HTML if `output = "html"`. #' @export #' @family Utilities @@ -157,7 +158,8 @@ gt_double_table <- function(data, gt_fn, nrows = NULL, noisy = TRUE) { gt_two_column_layout <- function(tables = NULL, output = "viewer", filename = NULL, path = NULL, vwidth = 992, vheight = 600, ..., - zoom = 2, expand = 5) { + zoom = 2, expand = 5, + tab_header_from = NULL) { if (length(tables) != 2) { stop("Two 'gt' tables must be provided like `list(table1, table2)` and be of length == 2", call. = FALSE) } @@ -171,11 +173,36 @@ gt_two_column_layout <- function(tables = NULL, output = "viewer", stopifnot("Two 'gt' tables must be provided like `list(table1, table2)`" = !is.null(tables)) stopifnot("Two 'gt' tables must be provided like `list(table1, table2)`" = is.list(tables)) stopifnot("Both tables in the list must be a 'gt_tbl' object" = all(c(class(tables[[1]])[1], class(tables[[2]])[1]) == "gt_tbl")) - - double_tables <- htmltools::div( - htmltools::div(tables[1], style = "display: inline-block;float:left;"), - htmltools::div(tables[2], style = "display: inline-block;float:right;") - ) + + if (!is.null(tab_header_from)){ + stopifnot("The `tab_header_from` argument must be one of 'table1', or 'table2'" = tab_header_from %in% c("table1", "table2")) + extract_from <- switch (tab_header_from, + "table1" = tables[[1]], + "table2" = tables[[2]] + ) + header_data <- extract_tab_header_and_style(extract_from) + double_tables <- htmltools::div( + id = "mycombinedtable", + htmltools::tag("style", header_data[["style"]]), + htmltools::div( + header_data[["title"]], + class = header_data[["title_class"]], + style = header_data[["title_style"]] + ), + htmltools::div( + header_data[["subtitle"]], + class = header_data[["subtitle_class"]], + style = header_data[["subtitle_style"]] + ), + htmltools::div(tables[[1]] %>% gt::tab_header(NULL, NULL), style = "display: inline-block;float:left;"), + htmltools::div(tables[[2]] %>% gt::tab_header(NULL, NULL), style = "display: inline-block;float:right;") + ) + } else { + double_tables <- htmltools::div( + htmltools::div(tables[1], style = "display: inline-block;float:left;"), + htmltools::div(tables[2], style = "display: inline-block;float:right;") + ) + } if (output == "viewer") { htmltools::browsable(double_tables) @@ -214,3 +241,41 @@ gt_two_column_layout <- function(tables = NULL, output = "viewer", double_tables } } + +extract_tab_header_and_style <- function(table) { + raw_html <- gt::as_raw_html(table, inline_css = FALSE) %>% + xml2::read_html() + + gt_title <- raw_html %>% + xml2::xml_find_first("//*[contains(concat(' ',normalize-space(@class),' '),' gt_title ')]") + + gt_subtitle <- raw_html %>% + xml2::xml_find_first("//*[contains(concat(' ',normalize-space(@class),' '),' gt_subtitle ')]") + + gt_table_id <- raw_html %>% + xml2::xml_find_all("//body/div") %>% + xml2::xml_attr("id") + + s <- raw_html %>% + xml2::xml_find_first("//style") %>% + xml2::xml_contents() %>% + xml2::xml_text() %>% + gsub(gt_table_id, "mycombinedtable", x = .) %>% + gsub("mycombinedtable table", "mycombinedtable div", x = .) + + list( + title = xml_missing(gt_title), + title_class = paste("gt_table", xml2::xml_attr(gt_title, "class")), + title_style = xml2::xml_attr(gt_title, "style"), + subtitle = xml_missing(gt_subtitle), + subtitle_class = paste("gt_table", xml2::xml_attr(gt_subtitle, "class")), + subtitle_style = xml2::xml_attr(gt_subtitle, "style"), + style = s + ) +} + +xml_missing <- function(xml){ + xml_txt <- xml2::xml_text(xml) + if (is.na(xml_txt)) return(NULL) + xml_txt +} \ No newline at end of file diff --git a/man/gt_two_column_layout.Rd b/man/gt_two_column_layout.Rd index 19bb917..032244b 100644 --- a/man/gt_two_column_layout.Rd +++ b/man/gt_two_column_layout.Rd @@ -13,7 +13,8 @@ gt_two_column_layout( vheight = 600, ..., zoom = 2, - expand = 5 + expand = 5, + tab_header_from = NULL ) } \arguments{ @@ -34,6 +35,8 @@ gt_two_column_layout( \item{zoom}{Argument to \code{webshot2::webshot()}. A number specifying the zoom factor. A zoom factor of 2 will result in twice as many pixels vertically and horizontally. Note that using 2 is not exactly the same as taking a screenshot on a HiDPI (Retina) device: it is like increasing the zoom to 200 doubling the height and width of the browser window. This differs from using a HiDPI device because some web pages load different, higher-resolution images when they know they will be displayed on a HiDPI device (but using zoom will not report that there is a HiDPI device).} \item{expand}{Argument to \code{webshot2::webshot()}. A numeric vector specifying how many pixels to expand the clipping rectangle by. If one number, the rectangle will be expanded by that many pixels on all sides. If four numbers, they specify the top, right, bottom, and left, in that order. When taking screenshots of multiple URLs, this parameter can also be a list with same length as url with each element of the list containing a single number or four numbers to use for the corresponding URL.} + +\item{tab_header_from}{If \code{NULL} (the default) renders tab headers of each table individually. If one of "table1" or "table2", the function extracts tab header information (including styling) from table 1 or table 2 respectively and renders it as high level header for the combined view (individual headers will be removed).} } \value{ Saves a \code{.png} to disk if \code{output = "save"}, returns HTML to the viewer via \code{htmltools::browsable()} when \code{output = "viewer"}, or returns raw HTML if \code{output = "html"}. @@ -133,8 +136,8 @@ Other Utilities: \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, -\code{\link{gt_merge_stack_color}()}, \code{\link{gt_merge_stack}()}, +\code{\link{gt_merge_stack_color}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, From eec933b9654dd272b609e6d90a7357980e575aad Mon Sep 17 00:00:00 2001 From: Joe Roberts Date: Mon, 1 Apr 2024 20:41:39 -0700 Subject: [PATCH 2/2] Fix missing theme column styling for stubhead. --- R/gt_theme_538.R | 5 +++-- R/gt_theme_dark.R | 5 ++++- R/gt_theme_nytimes.R | 5 ++++- R/gt_theme_pff.R | 5 ++++- 4 files changed, 15 insertions(+), 5 deletions(-) diff --git a/R/gt_theme_538.R b/R/gt_theme_538.R index fa4a83a..b3b616e 100644 --- a/R/gt_theme_538.R +++ b/R/gt_theme_538.R @@ -73,8 +73,9 @@ gt_theme_538 <- function(gt_object, ..., quiet = FALSE) { weight = 200 ) ), - locations = gt::cells_column_labels( - columns = gt::everything() + locations = list( + gt::cells_column_labels(), + gt::cells_stubhead() ) ) %>% tab_style( diff --git a/R/gt_theme_dark.R b/R/gt_theme_dark.R index 0cc78e9..688f48f 100644 --- a/R/gt_theme_dark.R +++ b/R/gt_theme_dark.R @@ -47,7 +47,10 @@ gt_theme_dark <- function(gt_object, ...) { font = google_font("Source Sans Pro"), transform = "uppercase" ), - locations = cells_column_labels(everything()) + locations = list( + cells_column_labels(), + cells_stubhead() + ) ) %>% tab_style( style = cell_text( diff --git a/R/gt_theme_nytimes.R b/R/gt_theme_nytimes.R index 0b86bef..c266f37 100644 --- a/R/gt_theme_nytimes.R +++ b/R/gt_theme_nytimes.R @@ -43,7 +43,10 @@ gt_theme_nytimes <- function(gt_object, ...) { font = google_font("Source Sans Pro"), transform = "uppercase" ), - locations = cells_column_labels(everything()) + locations = list( + gt::cells_column_labels(), + gt::cells_stubhead() + ) ) %>% tab_style( style = cell_text( diff --git a/R/gt_theme_pff.R b/R/gt_theme_pff.R index 637697c..f0902a5 100644 --- a/R/gt_theme_pff.R +++ b/R/gt_theme_pff.R @@ -157,6 +157,9 @@ gt_theme_pff <- function(gt_object, ..., divider, spanners, rank_col) { weight = px(2.5) ) ), - locations = gt::cells_column_labels() + locations = list( + gt::cells_column_labels(), + gt::cells_stubhead() + ) ) }