From f7eb5c3547e786ba1bb2b7df12ce14e573d19cbd Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:53:31 -0500 Subject: [PATCH 01/92] Add comments --- R/summary_rows.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/R/summary_rows.R b/R/summary_rows.R index 5f7b84c7d4..3b31a89a09 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -82,10 +82,19 @@ summary_rows <- function(data, # Collect all provided formatter options in a list formatter_options <- list(...) + # If `groups` is NULL, take that to mean the + # same as TRUE + # TODO: this will change later when (1) NULL is + # taken to mean grand total, and (2) TRUE indicates + # all groups if (is.null(groups)) { groups <- TRUE } + # Get a character vector of column names to + # which `fns` applies + # TODO: replace with improved resolver functions + # once that is merged to master if (is.null(columns)) { columns <- TRUE } else if (!is.null(columns) && inherits(columns, "quosures")) { From ccc51c7fd6a334d0c9d73523554b491c04f5adbf Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:53:48 -0500 Subject: [PATCH 02/92] Simplify assignment --- R/summary_rows.R | 28 +++++++++------------------- 1 file changed, 9 insertions(+), 19 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 3b31a89a09..6f7f4d6529 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -101,23 +101,11 @@ summary_rows <- function(data, columns <- columns %>% lapply(`[[`, 2) %>% as.character() } - if ("summary" %in% names(attributes(data))) { - - attr(data, "summary") <- - c( - attr(data, "summary"), - list( - list( - groups = groups, - columns = columns, - fns = fns, - missing_text = missing_text, - formatter = formatter, - formatter_options = formatter_options))) - - } else { - - attr(data, "summary") <- + # Append list of summary inputs to the + # `summary` attribute + attr(data, "summary") <- + c( + attr(data, "summary"), list( list( groups = groups, @@ -125,8 +113,10 @@ summary_rows <- function(data, fns = fns, missing_text = missing_text, formatter = formatter, - formatter_options = formatter_options)) - } + formatter_options = formatter_options + ) + ) + ) data } From 07e1d15606cd6723125d3fdbd6323c039b0dfb24 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:54:17 -0500 Subject: [PATCH 03/92] Modify comments --- R/utils_render_common.R | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 43a91353b4..6a3f89c3f3 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -310,10 +310,15 @@ create_summary_dfs <- function(summary_list, stub_df, output_df) { + # If the `summary_list` object is an empty list, + # return an empty list as the `list_of_summaries` if (length(summary_list) == 0) { return(list()) } + # Create empty lists that are to contain summary + # data frames for display and for data collection + # purposes summary_df_display_list <- list() summary_df_data_list <- list() @@ -328,7 +333,9 @@ create_summary_dfs <- function(summary_list, summary_attrs$missing_text <- "\u2013" } - # Resolve the groups to consider + # Resolve the groups to consider; if + # `groups` is TRUE then we are to obtain + # summary row data for all groups if (isTRUE(summary_attrs$groups)) { groups <- unique(stub_df$groupname) } else { @@ -398,8 +405,8 @@ create_summary_dfs <- function(summary_list, dplyr::select(groupname, rowname, dplyr::everything())) } - # Exclude columns that are not requested by - # filling those with NA values + # Add those columns that were not part of + # the aggregation, filling those with NA values summary_dfs_data <- summary_dfs %>% dplyr::mutate_at(.vars = columns, .funs = function(x) {NA_real_}) @@ -455,7 +462,7 @@ create_summary_dfs <- function(summary_list, } } - # Condense data in summary_df_display_list in a + # Condense data in `summary_df_display_list` in a # groupwise manner summary_df_display_list <- tapply( @@ -483,6 +490,9 @@ create_summary_dfs <- function(summary_list, replace(is.na(.), summary_attrs$missing_text) } + # Return a list of lists, each of which have + # summary data frames for display and for data + # collection purposes list( summary_df_data_list = summary_df_data_list, summary_df_display_list = summary_df_display_list) From c5dc52e0f61ff57c1d9e6724b9ad1cdfb059b523 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:54:34 -0500 Subject: [PATCH 04/92] Simplify assignment --- R/utils_render_common.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 6a3f89c3f3..1c139ea305 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -343,11 +343,7 @@ create_summary_dfs <- function(summary_list, } # Resolve the columns to exclude - if (isTRUE(summary_attrs$columns)) { - columns <- character(0) - } else { - columns <- base::setdiff(colnames(output_df), summary_attrs$columns) - } + columns_excl <- base::setdiff(colnames(output_df), summary_attrs$columns) # Combine `groupname` with the field data in order to # process data by groups From 6ea0cfebf3a29b6233ec2dcf48327f12dc474ab0 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:54:50 -0500 Subject: [PATCH 05/92] Add `select()` statement --- R/utils_render_common.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 1c139ea305..a622df942b 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -352,7 +352,8 @@ create_summary_dfs <- function(summary_list, stub_df[ seq(nrow(stub_df)), c("groupname", "rowname")], - data_df)[, -2] + data_df)[, -2] %>% + dplyr::select(groupname, summary_attrs$columns) # Get the registered function calls agg_funs <- summary_attrs$fns %>% lapply(rlang::as_function) From 1ca22f4984b5044a7e5d123854feb242240d22ae Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:55:09 -0500 Subject: [PATCH 06/92] Modify object names --- R/utils_render_common.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index a622df942b..529d958e6c 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -384,14 +384,14 @@ create_summary_dfs <- function(summary_list, labels[is.na(labels)] <- derived_labels[is.na(labels)] # Initialize an empty tibble to bind to - summary_dfs <- dplyr::tibble() + summary_dfs_data <- dplyr::tibble() for (j in seq(agg_funs)) { # Get aggregation rows for each of the `agg_funs` - summary_dfs <- + summary_dfs_data <- dplyr::bind_rows( - summary_dfs, + summary_dfs_data, groups_data_df %>% dplyr::select(c("groupname", colnames(output_df))) %>% dplyr::filter(groupname %in% groups) %>% From 08e00b0c1c10ab7ada20fc9f7747d2fa1ec61383 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:55:20 -0500 Subject: [PATCH 07/92] Remove `select()` statement --- R/utils_render_common.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 529d958e6c..1eda8ee1fc 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -393,7 +393,6 @@ create_summary_dfs <- function(summary_list, dplyr::bind_rows( summary_dfs_data, groups_data_df %>% - dplyr::select(c("groupname", colnames(output_df))) %>% dplyr::filter(groupname %in% groups) %>% dplyr::group_by(groupname) %>% dplyr::summarize_all(.funs = agg_funs[[j]]) %>% From 21f94164377d40ad889488d4798cc3b29120c831 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 11 Feb 2019 23:55:41 -0500 Subject: [PATCH 08/92] Refactor function --- R/utils_render_common.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 1eda8ee1fc..fcab1384fd 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -398,18 +398,21 @@ create_summary_dfs <- function(summary_list, dplyr::summarize_all(.funs = agg_funs[[j]]) %>% dplyr::ungroup() %>% dplyr::mutate(rowname = labels[j]) %>% - dplyr::select(groupname, rowname, dplyr::everything())) + dplyr::select(groupname, rowname, dplyr::everything()) + ) } # Add those columns that were not part of # the aggregation, filling those with NA values + summary_dfs_data[, columns_excl] <- NA_real_ + summary_dfs_data <- - summary_dfs %>% - dplyr::mutate_at(.vars = columns, .funs = function(x) {NA_real_}) + summary_dfs_data %>% + dplyr::select(groupname, rowname, colnames(output_df)) # Format the displayed summary lines summary_dfs_display <- - summary_dfs %>% + summary_dfs_data %>% dplyr::mutate_at( .vars = summary_attrs$columns, .funs = function(x) { @@ -432,7 +435,7 @@ create_summary_dfs <- function(summary_list, } ) %>% dplyr::mutate_at( - .vars = columns, + .vars = columns_excl, .funs = function(x) {NA_character_}) for (group in groups) { @@ -491,7 +494,8 @@ create_summary_dfs <- function(summary_list, # collection purposes list( summary_df_data_list = summary_df_data_list, - summary_df_display_list = summary_df_display_list) + summary_df_display_list = summary_df_display_list + ) } migrate_labels <- function(row_val) { From cf38abdb1bfde5be5a1f570b9b17eaf85bb4bf59 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 01:21:19 -0500 Subject: [PATCH 09/92] Make correction to conditional stmt --- R/utils_render_common.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index fcab1384fd..12bbf7834c 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -329,7 +329,7 @@ create_summary_dfs <- function(summary_list, # Resolve the `missing_text` if (summary_attrs$missing_text == "---") { summary_attrs$missing_text <- "\u2014" - } else if (missing_text == "--") { + } else if (summary_attrs$missing_text == "--") { summary_attrs$missing_text <- "\u2013" } From 003c8e6810970d95bda2fe8d390d2f9053f20144 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 03:16:03 -0500 Subject: [PATCH 10/92] Equate `groups == FALSE` to NULL --- R/summary_rows.R | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 6f7f4d6529..4b21d1b061 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -82,13 +82,11 @@ summary_rows <- function(data, # Collect all provided formatter options in a list formatter_options <- list(...) - # If `groups` is NULL, take that to mean the - # same as TRUE - # TODO: this will change later when (1) NULL is - # taken to mean grand total, and (2) TRUE indicates - # all groups - if (is.null(groups)) { - groups <- TRUE + # If `groups` is FALSE, take that to mean the + # same as NULL, which in turn results in the + # calculations of a grand summary + if (is_false(groups)) { + groups <- NULL } # Get a character vector of column names to From aefd2855bd3abf436da845d517a8462b4ec417cb Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 03:16:46 -0500 Subject: [PATCH 11/92] Refactor and allow for specialized grand summary grp --- R/utils_render_common.R | 77 ++++++++++++++++++++++++++--------------- 1 file changed, 49 insertions(+), 28 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 12bbf7834c..8a972a83ff 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -326,50 +326,71 @@ create_summary_dfs <- function(summary_list, summary_attrs <- summary_list[[i]] + groups <- summary_attrs$groups + columns <- summary_attrs$columns + fns <- summary_attrs$fns + missing_text <- summary_attrs$missing_text + formatter <- summary_attrs$formatter + formatter_options <- summary_attrs$formatter_options + # Resolve the `missing_text` - if (summary_attrs$missing_text == "---") { - summary_attrs$missing_text <- "\u2014" - } else if (summary_attrs$missing_text == "--") { - summary_attrs$missing_text <- "\u2013" + if (missing_text == "---") { + missing_text <- "\u2014" + } else if (missing_text == "--") { + missing_text <- "\u2013" } # Resolve the groups to consider; if # `groups` is TRUE then we are to obtain # summary row data for all groups - if (isTRUE(summary_attrs$groups)) { + if (isTRUE(groups)) { groups <- unique(stub_df$groupname) - } else { - groups <- summary_attrs$groups + } else if (is.null(groups)) { + groups <- ":grand_summary:" } # Resolve the columns to exclude - columns_excl <- base::setdiff(colnames(output_df), summary_attrs$columns) + columns_excl <- base::setdiff(colnames(output_df), columns) # Combine `groupname` with the field data in order to # process data by groups - groups_data_df <- - cbind( - stub_df[ - seq(nrow(stub_df)), - c("groupname", "rowname")], - data_df)[, -2] %>% - dplyr::select(groupname, summary_attrs$columns) + if (groups[1] != ":grand_summary:") { + + select_data_df <- + cbind( + stub_df[ + seq(nrow(stub_df)), + c("groupname", "rowname")], + data_df)[, -2] %>% + dplyr::select(groupname, columns) + + } else if (groups == ":grand_summary:") { + + select_data_df <- + cbind( + stub_df[ + seq(nrow(stub_df)), + c("groupname", "rowname")], + data_df)[, -2] %>% + dplyr::mutate(groupname = ":grand_summary:") %>% + dplyr::select(groupname, columns) + } # Get the registered function calls - agg_funs <- summary_attrs$fns %>% lapply(rlang::as_function) + agg_funs <- fns %>% lapply(rlang::as_function) # Get the names if any were provided - labels <- names(summary_attrs$fns) %>% process_text() + labels <- names(fns) %>% process_text() - # If names weren't provided at all, handle this case by - # creating a vector of NAs that will be replaced later with - # derived names + # If names weren't provided at all, handle + # this case by creating a vector of NAs that + # will be replaced later with derived names if (length(labels) < 1) { - labels <- rep(NA_character_, length(summary_attrs$fns)) + labels <- rep(NA_character_, length(fns)) } - # If one or more names not provided then replace the empty - # string with NA + # If one or more names not provided then + # replace the empty string with NAs labels[labels == ""] <- NA_character_ # Get the labels for each of the function calls @@ -392,7 +413,7 @@ create_summary_dfs <- function(summary_list, summary_dfs_data <- dplyr::bind_rows( summary_dfs_data, - groups_data_df %>% + select_data_df %>% dplyr::filter(groupname %in% groups) %>% dplyr::group_by(groupname) %>% dplyr::summarize_all(.funs = agg_funs[[j]]) %>% @@ -414,7 +435,7 @@ create_summary_dfs <- function(summary_list, summary_dfs_display <- summary_dfs_data %>% dplyr::mutate_at( - .vars = summary_attrs$columns, + .vars = columns, .funs = function(x) { format_data <- @@ -467,8 +488,8 @@ create_summary_dfs <- function(summary_list, tapply( summary_df_display_list, names(summary_df_display_list), - dplyr::bind_rows) - + dplyr::bind_rows + ) for (i in seq(summary_df_display_list)) { @@ -486,7 +507,7 @@ create_summary_dfs <- function(summary_list, summary_df_display_list[[i]] <- summary_df_display_list[[i]][ match(arrangement, summary_df_display_list[[i]]$rowname), ] %>% - replace(is.na(.), summary_attrs$missing_text) + replace(is.na(.), missing_text) } # Return a list of lists, each of which have From 9576790ae65e729a33001a5a038745966d540a3e Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 03:17:15 -0500 Subject: [PATCH 12/92] Append grand summary rows to bottom of body --- R/utils_render_html.R | 53 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/R/utils_render_html.R b/R/utils_render_html.R index 56ddfe2124..046a4c26f6 100644 --- a/R/utils_render_html.R +++ b/R/utils_render_html.R @@ -732,6 +732,59 @@ create_body_component_h <- function(row_splits_body, } } + # If there is a grand summary, include that at the end + if (summaries_present && + ":grand_summary:" %in% names(list_of_summaries$summary_df_display_list)) { + + grand_summary_df <- + list_of_summaries$summary_df_display_list$`:grand_summary:` %>% + as.data.frame(stringsAsFactors = FALSE) + + row_splits_summary_styles <- + apply_styles_to_summary_output( + grand_summary_df, styles_resolved, + group = ":grand_summary:", n_cols = n_cols) + + grand_summary <- as.vector(t(grand_summary_df)) + + row_splits_grand_summary <- + split_body_content( + body_content = grand_summary, + n_cols = n_cols) + + # Provide CSS classes for leading and non-leading summary rows + summary_row_classes_first <- "gt_summary_row gt_first_grand_summary_row " + summary_row_classes <- "gt_summary_row " + + grand_summary_row_lines <- c() + + for (j in seq(length(row_splits_grand_summary))) { + + grand_summary_row_lines <- + c(grand_summary_row_lines, + paste0( + "\n", + paste0( + "", + row_splits_grand_summary[[j]][1], + ""), "\n", + paste0( + "", + row_splits_grand_summary[[j]][-1], + "", collapse = "\n"), + "\n\n") + ) + } + + body_rows <- c(body_rows, grand_summary_row_lines) + } + # Create a single-length vector by collapsing all vector components body_rows <- body_rows %>% paste(collapse = "") From d68cad082bb8a541b4d09b4fbffe55d916c326d6 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 03:17:37 -0500 Subject: [PATCH 13/92] Add CSS class for the first grand summary row --- inst/css/gt_styles_default.scss | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/inst/css/gt_styles_default.scss b/inst/css/gt_styles_default.scss index 3f126d3bee..7258e2c918 100644 --- a/inst/css/gt_styles_default.scss +++ b/inst/css/gt_styles_default.scss @@ -127,6 +127,12 @@ border-top-color: #A8A8A8; } + .gt_first_grand_summary_row { + border-top-style: double; + border-top-width: 6px; + border-top-color: #A8A8A8; + } + .gt_table_body { border-top-style: $field_border_top_style; /* field.border.top.style */ border-top-width: $field_border_top_width; /* field.border.top.width */ From 0fc623dac0f78a9766533909a62cf45db307b7a6 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 03:17:55 -0500 Subject: [PATCH 14/92] Update tests to reflect new behavior --- tests/testthat/test-summary_rows.R | 11 +++++++++-- tests/testthat/test-util_functions.R | 2 +- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-summary_rows.R b/tests/testthat/test-summary_rows.R index 4a6a66d2f9..da35f5c339 100644 --- a/tests/testthat/test-summary_rows.R +++ b/tests/testthat/test-summary_rows.R @@ -81,6 +81,7 @@ test_that("the `summary_rows()` function works correctly", { gt_tbl <- gt(tbl) %>% summary_rows( + groups = TRUE, columns = vars(value_1), fns = list( average = ~mean(., na.rm = TRUE), @@ -137,15 +138,21 @@ test_that("the `summary_rows()` function works correctly", { gt_tbl <- gt(tbl) %>% summary_rows( + groups = TRUE, columns = vars(value_1, value_2), fns = list( average = ~mean(., na.rm = TRUE), total = ~sum(., na.rm = TRUE), - `std dev` = ~sd(., na.rm = TRUE))) %>% + `std dev` = ~sd(., na.rm = TRUE) + ) + ) %>% summary_rows( + groups = TRUE, columns = vars(value_1, value_2), fns = list( - max = ~max(., na.rm = TRUE))) + max = ~max(., na.rm = TRUE) + ) + ) # Extract the internal `summary` object summary <- attr(gt_tbl, "summary", exact = TRUE) diff --git a/tests/testthat/test-util_functions.R b/tests/testthat/test-util_functions.R index dbb582c3aa..7ff74f161c 100644 --- a/tests/testthat/test-util_functions.R +++ b/tests/testthat/test-util_functions.R @@ -380,7 +380,7 @@ test_that("the `get_css_tbl()` function works correctly", { css_tbl %>% expect_is(c("tbl_df", "tbl", "data.frame")) - css_tbl %>% dim() %>% expect_equal(c(101, 4)) + css_tbl %>% dim() %>% expect_equal(c(104, 4)) css_tbl %>% colnames() %>% From d019ae7629ae0697633bfe8f25dbc498dee00c17 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:05:28 -0500 Subject: [PATCH 15/92] Include a `context` argument --- R/utils_render_common.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 8a972a83ff..e1da39c271 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -308,7 +308,8 @@ perform_col_merge <- function(col_merge, create_summary_dfs <- function(summary_list, data_df, stub_df, - output_df) { + output_df, + context) { # If the `summary_list` object is an empty list, # return an empty list as the `list_of_summaries` From b413c638b44dbe09e3992ba3c2e1d4c15f9236f5 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:06:50 -0500 Subject: [PATCH 16/92] Normalize `groups` and stop early if necessary --- R/utils_render_common.R | 42 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index e1da39c271..c352a86742 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -345,9 +345,49 @@ create_summary_dfs <- function(summary_list, # `groups` is TRUE then we are to obtain # summary row data for all groups if (isTRUE(groups)) { + + if (all(is.na(stub_df$groupname))) { + stop("There are no row groups in the gt object:\n", + " * Use `groups = NULL` to create a grand summary\n", + " * Define row groups using `gt()` or `tab_row_group()`", + call. = FALSE) + } + groups <- unique(stub_df$groupname) + + } else if (!is.null(groups) && is.character(groups)) { + + # TODO: this is repeated from above, make + # this a utility function + if (all(is.na(stub_df$groupname))) { + stop("There are no row groups in the gt object:\n", + " * Use `groups = NULL` to create a grand summary\n", + " * Define row groups using `gt()` or `tab_row_group()`", + call. = FALSE) + } + + # Get the names of row groups available + # in the gt object + groups_available <- unique(stub_df$groupname) + + if (any(!(groups %in% groups_available))) { + + # Stop function if one or more `groups` + # are not present in the gt table + stop("All `groups` should be available in the gt object:\n", + " * The following groups aren't present: ", + paste0( + base::setdiff(groups, groups_available), + collapse = ", " + ), "\n", + call. = FALSE) + } + } else if (is.null(groups)) { - groups <- ":grand_summary:" + + # If groups is given as NULL (the default) + # then use a special group (`::GRAND_SUMMARY`) + groups <- "::GRAND_SUMMARY" } # Resolve the columns to exclude From cc13f69174518d1af54ef4e3ca008775ac1a66ef Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:07:23 -0500 Subject: [PATCH 17/92] Modify special label used for grand summary --- R/utils_render_common.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index c352a86742..b47645756d 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -395,7 +395,7 @@ create_summary_dfs <- function(summary_list, # Combine `groupname` with the field data in order to # process data by groups - if (groups[1] != ":grand_summary:") { + if (groups[1] != "::GRAND_SUMMARY") { select_data_df <- cbind( @@ -405,7 +405,7 @@ create_summary_dfs <- function(summary_list, data_df)[, -2] %>% dplyr::select(groupname, columns) - } else if (groups == ":grand_summary:") { + } else if (groups == "::GRAND_SUMMARY") { select_data_df <- cbind( @@ -413,7 +413,7 @@ create_summary_dfs <- function(summary_list, seq(nrow(stub_df)), c("groupname", "rowname")], data_df)[, -2] %>% - dplyr::mutate(groupname = ":grand_summary:") %>% + dplyr::mutate(groupname = "::GRAND_SUMMARY") %>% dplyr::select(groupname, columns) } From c90387f39b44e99e2a5e91bbbde632bb72ec7efb Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:07:53 -0500 Subject: [PATCH 18/92] Use `rlang::as_closure()` instead of `rlang::as_function()` --- R/utils_render_common.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index b47645756d..2a637b89fb 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -418,7 +418,8 @@ create_summary_dfs <- function(summary_list, } # Get the registered function calls - agg_funs <- fns %>% lapply(rlang::as_function) + #agg_funs <- fns %>% lapply(rlang::as_function) + agg_funs <- fns %>% lapply(rlang::as_closure) # Get the names if any were provided labels <- names(fns) %>% process_text() From e49daca47e1506a9d2e8da7236a68bddd2068d0e Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:08:29 -0500 Subject: [PATCH 19/92] Refactor statements that produce summary labels --- R/utils_render_common.R | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 2a637b89fb..58f9b6355b 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -422,26 +422,27 @@ create_summary_dfs <- function(summary_list, agg_funs <- fns %>% lapply(rlang::as_closure) # Get the names if any were provided - labels <- names(fns) %>% process_text() - - # If names weren't provided at all, handle - # this case by creating a vector of NAs that - # will be replaced later with derived names - if (length(labels) < 1) { - labels <- rep(NA_character_, length(fns)) - } - - # If one or more names not provided then - # replace the empty string with NAs - labels[labels == ""] <- NA_character_ - - # Get the labels for each of the function calls - derived_labels <- - summary_attrs$fns %>% - lapply(derive_summary_label) %>% + labels <- + names(fns) %>% + { + labels <- . + if (length(labels) < 1) { + rep(NA_character_, length(fns)) + } else { + labels + } + } %>% + mapply(., fns, SIMPLIFY = FALSE, FUN = function(label, fn) { + if (is.na(label)) { + derive_summary_label(fn) + } else if(label == "") { + derive_summary_label(fn) + } else { + process_text(label, context = context) + } + }) %>% unlist() %>% - unname() %>% - make.names(unique = TRUE) + unname() # Replace missing labels with derived labels labels[is.na(labels)] <- derived_labels[is.na(labels)] From cf9f1722c34ab054a4a942231e730be635c84d1e Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:08:48 -0500 Subject: [PATCH 20/92] Stop function if summary labels are not unique --- R/utils_render_common.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 58f9b6355b..82b0cf23d6 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -444,8 +444,14 @@ create_summary_dfs <- function(summary_list, unlist() %>% unname() - # Replace missing labels with derived labels - labels[is.na(labels)] <- derived_labels[is.na(labels)] + if (length(labels) != length(unique(labels))) { + + stop("All summary labels must be unique:\n", + " * Review the names provided in `fns`\n", + " * These labels are in conflict: ", + paste0(labels, collapse = ", "), ".", + call. = FALSE) + } # Initialize an empty tibble to bind to summary_dfs_data <- dplyr::tibble() From 65d8d5210a18e9835febbd479c2fceae10276d0e Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:09:13 -0500 Subject: [PATCH 21/92] Modify call to `create_summary_dfs()` --- R/build_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/build_data.R b/R/build_data.R index f9eac167d5..81b8ff4da9 100644 --- a/R/build_data.R +++ b/R/build_data.R @@ -165,7 +165,7 @@ build_data <- function(data, context) { # Create the `list_of_summaries` list of lists list_of_summaries <- - create_summary_dfs(summary_list, data_df, stub_df, output_df) + create_summary_dfs(summary_list, data_df, stub_df, output_df, context) # Determine if there is a populated stub stub_available <- is_stub_available(stub_df) From bea1c954c89d34b02f58cd74fc120fe70ba69a7b Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:09:37 -0500 Subject: [PATCH 22/92] Modify call to `create_summary_dfs()` --- R/as_rtf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/as_rtf.R b/R/as_rtf.R index 5d818dfc20..dfcbe0f6dd 100644 --- a/R/as_rtf.R +++ b/R/as_rtf.R @@ -188,7 +188,7 @@ as_rtf <- function(data) { # Create the `list_of_summaries` list of lists list_of_summaries <- - create_summary_dfs(summary_list, data_df, stub_df, output_df) + create_summary_dfs(summary_list, data_df, stub_df, output_df, context) # Determine if there is a populated stub stub_available <- is_stub_available(stub_df) From 09ad1f051edb235cbd39a2a7a0658865bc27103c Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:10:09 -0500 Subject: [PATCH 23/92] Refactor the `extract_summary()` function --- R/extract_summary.R | 89 +++++++-------------------------------------- 1 file changed, 13 insertions(+), 76 deletions(-) diff --git a/R/extract_summary.R b/R/extract_summary.R index 9265bc4172..53af783603 100644 --- a/R/extract_summary.R +++ b/R/extract_summary.R @@ -59,86 +59,23 @@ #' @export extract_summary <- function(data) { - # Extract all attributes from the data object into `data_attr` + # Extract all attributes from the `data` + # object into `data_attr` data_attr <- attributes(data) + # Stop function if there are no + # directives to create summary rows if (is.null(data_attr$summary)) { - stop("There is no summary data frame to extract.", call. = FALSE) + stop("There is no summary list to extract.\n", + "Use the `summary_rows()` function to generate summaries.", + call. = FALSE) } - # Move original data frame to `data_df` - data_df <- as.data.frame(data) + # Build the `data` using the standard + # pipeline with the `html` context + built_data <- build_data(data = data, context = "html") - # Get the `boxh_df` data frame - boxh_df <- data_attr$boxh_df - - # Get the `stub_df` data frame - stub_df <- data_attr$stub_df - - # Get the `rows_df` data frame - rows_df <- data_attr$rows_df - - # Get the `cols_df` data frame - cols_df <- data_attr$cols_df - - # Get the `formats` list - formats <- data_attr$formats - - # Get the `arrange_groups` vector - arrange_groups <- data_attr$arrange_groups - - # Get the `others_group` vector - others_group <- data_attr$others_group[[1]] %||% NA_character_ - - # Get the `col_merge` object - col_merge <- data_attr$col_merge - - # Get the `summary_list` object - summary_list <- data_attr$summary - - # Initialize `output_df` - output_df <- initialize_output_df(data_df) - - # Create `output_df` with rendered values - output_df <- render_formats(output_df, data_df, formats, context = "html") - - # Move input data cells to `output_df` that didn't have - # any rendering applied during `render_formats()` - output_df <- migrate_unformatted_to_output(data_df, output_df, context = "html") - - # Get the reordering df (`rows_df`) for the data rows - rows_df <- get_row_reorder_df(arrange_groups, stub_df) - - # Get the `columns_df` data frame for the data columns - columns_df <- get_column_reorder_df(cols_df, boxh_df) - - # Reassemble the rows and columns of `data_df` in the correct order - output_df <- reassemble_output_df(output_df, rows_df, columns_df) - - # Get the `groups_df` data frame, which is a rearranged representation - # of the stub `groupname` and `rowname` columns - groups_df <- get_groupnames_rownames_df(stub_df, rows_df) - - # Replace NA values in the `groupname` column if there is a reserved - # label for the unlabeled group - groups_df[is.na(groups_df[, "groupname"]), "groupname"] <- others_group - - # Create the `groups_rows_df` data frame, which provides information - # on which rows the group rows should appear above - groups_rows_df <- get_groups_rows_df(arrange_groups, groups_df) - - # Perform any necessary column merge operations - col_merge_output <- - perform_col_merge(col_merge, data_df, output_df, boxh_df, columns_df) - - # Rewrite `output_df`, `boxh_df`, and `columns_df` as a result of merging - output_df <- col_merge_output$output_df - boxh_df <- col_merge_output$boxh_df - columns_df <- col_merge_output$columns_df - - # Create the `list_of_summaries` list of lists - list_of_summaries <- - create_summary_dfs(summary_list, data_df, stub_df, output_df) - - list_of_summaries$summary_df_data_list + # Extract the list of summary data frames + # that contains tidy, unformatted data + built_data$list_of_summaries$summary_df_data_list } From 9ad9df8c444cedc8e7e63050b3fd8faf5d8b133a Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:24:54 -0500 Subject: [PATCH 24/92] Modify roxygen documentation --- R/summary_rows.R | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 4b21d1b061..6e7609a4cb 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -6,21 +6,26 @@ #' purposes, the \code{\link{extract_summary}()} can be used with a #' \code{gt_tbl} object where summary rows were added via \code{summary_rows()}. #' @param data a table object that is created using the \code{gt()} function. -#' @param groups the row groups labels that identify which summary rows will be -#' added. -#' @param columns the columns for which the summaries should be calculated. If -#' nothing is provided, then the supplied aggregation functions will be -#' applied to all columns. +#' @param groups the groups to consider for generation of groupwise summary rows +#' or a logical value. Providing the names of row groups in \code{c()} will +#' limit summary rows to those groups. Setting this to \code{TRUE} indicates +#' that all available groups will receive summary rows. Setting to either +#' \code{FALSE} or \code{NULL} will result in the addition of grand summary +#' rows, a summary of which operates on all table data. By default, this is +#' set to \code{TRUE} which means that all row groups will receive their own +#' sets of summary rows. +#' @param columns the columns for which the summaries should be calculated. #' @param fns functions used for aggregations. This can include base functions #' like \code{mean}, \code{min}, \code{max}, \code{median}, \code{sd}, or #' \code{sum} or any other user-defined aggregation function. The function(s) #' should be supplied within a \code{list()}. Within that list, we can specify -#' the functions by use of function names (e.g., \code{"sum"}), the functions -#' themselves (e.g., \code{sum}), or one-sided R formulas by prefacing with a -#' \code{~} where \code{.} serves as the data to be summarized (e.g., -#' \code{sum(., na.rm = TRUE)}). By using named arguments, the names will -#' serve as row labels for the corresponding summary rows (otherwise the -#' labels will be derived from the function names). +#' the functions by use of function names in quotes (e.g., \code{"sum"}), as +#' bare functions (e.g., \code{sum}), or one-sided R formulas using a leading +#' \code{~} and a \code{.} that serves as the data to be summarized (e.g., +#' \code{sum(., na.rm = TRUE)}). The use of named arguments is recommended as +#' the names will serve as summary row labels for the corresponding summary +#' rows data (the labels can derived from the function names but only when not +#' providing bare function names). #' @param missing_text the text to be used in place of \code{NA} values in #' summary cells with no data outputs. #' @param formatter a formatter function name. These can be any of the From 2e3fd788927d769ceb82df0d953dd5d29060d574 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:25:51 -0500 Subject: [PATCH 25/92] Modify default value of `groups` arg --- R/summary_rows.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 6e7609a4cb..838ae022fe 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -77,7 +77,7 @@ #' @family row addition functions #' @export summary_rows <- function(data, - groups = NULL, + groups = TRUE, columns = NULL, fns, missing_text = "---", From 003f662a8fe5d435847ee20ee8685c1c4f464636 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:26:00 -0500 Subject: [PATCH 26/92] Update help file using roxygen --- man/summary_rows.Rd | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/man/summary_rows.Rd b/man/summary_rows.Rd index 61d9b09870..dc78930b82 100644 --- a/man/summary_rows.Rd +++ b/man/summary_rows.Rd @@ -4,29 +4,34 @@ \alias{summary_rows} \title{Add summary rows using aggregation functions} \usage{ -summary_rows(data, groups = NULL, columns = NULL, fns, +summary_rows(data, groups = TRUE, columns = NULL, fns, missing_text = "---", formatter = fmt_number, ...) } \arguments{ \item{data}{a table object that is created using the \code{gt()} function.} -\item{groups}{the row groups labels that identify which summary rows will be -added.} +\item{groups}{the groups to consider for generation of groupwise summary rows +or a logical value. Providing the names of row groups in \code{c()} will +limit summary rows to those groups. Setting this to \code{TRUE} indicates +that all available groups will receive summary rows. Setting to either +\code{FALSE} or \code{NULL} will result in the addition of grand summary +rows, a summary of which operates on all table data. By default, this is +set to \code{TRUE} which means that all row groups will receive their own +sets of summary rows.} -\item{columns}{the columns for which the summaries should be calculated. If -nothing is provided, then the supplied aggregation functions will be -applied to all columns.} +\item{columns}{the columns for which the summaries should be calculated.} \item{fns}{functions used for aggregations. This can include base functions like \code{mean}, \code{min}, \code{max}, \code{median}, \code{sd}, or \code{sum} or any other user-defined aggregation function. The function(s) should be supplied within a \code{list()}. Within that list, we can specify -the functions by use of function names (e.g., \code{"sum"}), the functions -themselves (e.g., \code{sum}), or one-sided R formulas by prefacing with a -\code{~} where \code{.} serves as the data to be summarized (e.g., -\code{sum(., na.rm = TRUE)}). By using named arguments, the names will -serve as row labels for the corresponding summary rows (otherwise the -labels will be derived from the function names).} +the functions by use of function names in quotes (e.g., \code{"sum"}), as +bare functions (e.g., \code{sum}), or one-sided R formulas using a leading +\code{~} and a \code{.} that serves as the data to be summarized (e.g., +\code{sum(., na.rm = TRUE)}). The use of named arguments is recommended as +the names will serve as summary row labels for the corresponding summary +rows data (the labels can derived from the function names but only when not +providing bare function names).} \item{missing_text}{the text to be used in place of \code{NA} values in summary cells with no data outputs.} From 5c290ef9a9645679710ebdcc0b4fa84721082e5e Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:26:52 -0500 Subject: [PATCH 27/92] Stop function if names are not given for bare fcns --- R/utils.R | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 38fcd63728..73b96cef86 100644 --- a/R/utils.R +++ b/R/utils.R @@ -575,7 +575,15 @@ normalize_suffixing_inputs <- function(suffixing) { #' @noRd derive_summary_label <- function(fn) { - if (inherits(fn, "formula")) { + if (is.function(fn)) { + + # Stop the function if any functions provided + # as bare names (e.g., `mean`) don't have + # names provided + stop("All functions provided as bare names in `fns` need a label.", + call. = FALSE) + + } else if (inherits(fn, "formula")) { (fn %>% rlang::f_rhs())[[1]] %>% as.character() From cd855126b46a9ef35eb906e337626ec87e38f9e9 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 12 Feb 2019 16:27:11 -0500 Subject: [PATCH 28/92] Modify label used --- R/utils_render_html.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils_render_html.R b/R/utils_render_html.R index 046a4c26f6..d2ca904d51 100644 --- a/R/utils_render_html.R +++ b/R/utils_render_html.R @@ -734,16 +734,16 @@ create_body_component_h <- function(row_splits_body, # If there is a grand summary, include that at the end if (summaries_present && - ":grand_summary:" %in% names(list_of_summaries$summary_df_display_list)) { + "::GRAND_SUMMARY" %in% names(list_of_summaries$summary_df_display_list)) { grand_summary_df <- - list_of_summaries$summary_df_display_list$`:grand_summary:` %>% + list_of_summaries$summary_df_display_list$`::GRAND_SUMMARY` %>% as.data.frame(stringsAsFactors = FALSE) row_splits_summary_styles <- apply_styles_to_summary_output( grand_summary_df, styles_resolved, - group = ":grand_summary:", n_cols = n_cols) + group = "::GRAND_SUMMARY", n_cols = n_cols) grand_summary <- as.vector(t(grand_summary_df)) From d4a8f25728856c783d7e5385e1d4a3776cba17b3 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:27:09 -0500 Subject: [PATCH 29/92] Remove background color for stub --- inst/css/gt_styles_default.scss | 3 --- 1 file changed, 3 deletions(-) diff --git a/inst/css/gt_styles_default.scss b/inst/css/gt_styles_default.scss index 7258e2c918..23dd0baf6a 100644 --- a/inst/css/gt_styles_default.scss +++ b/inst/css/gt_styles_default.scss @@ -110,9 +110,6 @@ border-right-width: 2px; border-right-color: #A8A8A8; padding-left: 12px; - &.gt_row { - background-color: $table_background_color; - } } .gt_summary_row { From 7c798604a3e788fc078e296ddc9f53a2d2efa37a Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:27:37 -0500 Subject: [PATCH 30/92] Add CSS rule for grand summary rows --- inst/css/gt_styles_default.scss | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/inst/css/gt_styles_default.scss b/inst/css/gt_styles_default.scss index 23dd0baf6a..e27c8ab84f 100644 --- a/inst/css/gt_styles_default.scss +++ b/inst/css/gt_styles_default.scss @@ -118,6 +118,13 @@ text-transform: $summary_row_text_transform; /* summary_row.text_transform */ } + .gt_grand_summary_row { + color: font-color($grand_summary_row_background_color); + background-color: $grand_summary_row_background_color; /* grand_summary_row.background.color */ + padding: $grand_summary_row_padding; /* grand_summary_row.padding */ + text-transform: $grand_summary_row_text_transform; /* grand_summary_row.text_transform */ + } + .gt_first_summary_row { border-top-style: solid; border-top-width: 2px; From c28b1a9c354a9455305bf21c401f6d8d751745cc Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:28:15 -0500 Subject: [PATCH 31/92] Apply Sass `font-color` function to summary rows --- inst/css/gt_styles_default.scss | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/css/gt_styles_default.scss b/inst/css/gt_styles_default.scss index e27c8ab84f..381a0f0eb5 100644 --- a/inst/css/gt_styles_default.scss +++ b/inst/css/gt_styles_default.scss @@ -113,6 +113,7 @@ } .gt_summary_row { + color: font-color($summary_row_background_color); background-color: $summary_row_background_color; /* summary_row.background.color */ padding: $summary_row_padding; /* summary_row.padding */ text-transform: $summary_row_text_transform; /* summary_row.text_transform */ From f63d2643fe564aeec6ff2152921685ed9922ccb8 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:28:46 -0500 Subject: [PATCH 32/92] Add Sass rule for grand summary row color --- inst/css/gt_colors.scss | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/css/gt_colors.scss b/inst/css/gt_colors.scss index fbc38840fe..8233ab6780 100644 --- a/inst/css/gt_colors.scss +++ b/inst/css/gt_colors.scss @@ -3,6 +3,7 @@ $heading_background_color: $table_background_color !default; $column_labels_background_color: $table_background_color !default; $stub_group_background_color: $table_background_color !default; $summary_row_background_color: $table_background_color !default; +$grand_summary_row_background_color: $table_background_color !default; @function font-color($color) { @return if( From 8eb27710e63cecdbbb7ad7fde504349b5f4437ae Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:29:13 -0500 Subject: [PATCH 33/92] Add options and defaults for grand summary rows --- R/gt_options_default.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/gt_options_default.R b/R/gt_options_default.R index 472163dd80..511267ecfc 100644 --- a/R/gt_options_default.R +++ b/R/gt_options_default.R @@ -32,12 +32,15 @@ gt_options_default <- function() { "field_border_bottom_style", TRUE, "field", "solid", "field_border_bottom_width", TRUE, "field", "2px", "field_border_bottom_color", TRUE, "field", "#A8A8A8", - "row_padding", TRUE, "row", "10px", + "row_padding", TRUE, "row", "8px", "row_striping_include_stub", TRUE, "row", "TRUE", "row_striping_include_field", TRUE, "row", "TRUE", "summary_row_background_color", TRUE, "summary_row", NA_character_, - "summary_row_padding", TRUE, "summary_row", "6px", + "summary_row_padding", TRUE, "summary_row", "8px", "summary_row_text_transform", TRUE, "summary_row", "inherit", + "grand_summary_row_background_color", TRUE, "grand_summary_row", NA_character_, + "grand_summary_row_padding", TRUE, "grand_summary_row", "8px", + "grand_summary_row_text_transform", TRUE, "grand_summary_row", "inherit", "footnote_sep", FALSE, "footnote", "
", "footnote_glyph", FALSE, "footnote", "numbers", "footnote_font_size", TRUE, "footnote", "90%", From f2f8da05ad8f85977a6e8fcc27eb3aa34b0188b5 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:29:31 -0500 Subject: [PATCH 34/92] Add the `cells_grand_summary()` function --- R/helpers.R | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/R/helpers.R b/R/helpers.R index 98ccdab36d..d39bd6c3a8 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -364,6 +364,30 @@ cells_summary <- function(groups = NULL, cells } +#' @rdname location_cells +#' @import rlang +#' @export +cells_grand_summary <- function(columns = NULL, + rows = NULL) { + + # Capture expressions for the `columns` + # and `rows` arguments + col_expr <- rlang::enquo(columns) + row_expr <- rlang::enquo(rows) + + # Create the `cells_grand_summary` object + cells <- + list( + columns = col_expr, + rows = row_expr) + + # Apply the `cells_grand_summary` and + # `location_cells` classes + class(cells) <- c("cells_grand_summary", "location_cells") + + cells +} + #' Interpret input text as Markdown-formatted text #' @param text the text that is understood to contain Markdown formatting. #' @return a character object that is tagged for a Markdown-to-HTML From f34c0647c5a496995497b3a534378b8d3b878a15 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:29:54 -0500 Subject: [PATCH 35/92] Modify default options for `summary_rows()` --- R/summary_rows.R | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 838ae022fe..9caab3a1af 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -77,8 +77,8 @@ #' @family row addition functions #' @export summary_rows <- function(data, - groups = TRUE, - columns = NULL, + groups = NULL, + columns = TRUE, fns, missing_text = "---", formatter = fmt_number, @@ -87,11 +87,13 @@ summary_rows <- function(data, # Collect all provided formatter options in a list formatter_options <- list(...) - # If `groups` is FALSE, take that to mean the - # same as NULL, which in turn results in the - # calculations of a grand summary - if (is_false(groups)) { - groups <- NULL + # If `groups` is FALSE, then do nothing; just + # return the `data` unchanged; having `groups` + # as `NULL` signifies a grand summary, `TRUE` + # is used for groupwise summaries across all + # groups + if (!is.null(groups) && is.logical(groups) && groups == FALSE) { + return(data) } # Get a character vector of column names to From aca9c237d6b2b92ffefb6de2c671412ea62fd5e1 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:30:15 -0500 Subject: [PATCH 36/92] Modify the `tab_options()` function --- R/tab_options.R | 41 ++++++++++++++++++++++++++++++++++------- 1 file changed, 34 insertions(+), 7 deletions(-) diff --git a/R/tab_options.R b/R/tab_options.R index ea406a70ac..4e82501849 100644 --- a/R/tab_options.R +++ b/R/tab_options.R @@ -19,11 +19,11 @@ #' units of pixels. The \code{\link{px}()} and \code{\link{pct}()} helper #' functions can also be used to pass in numeric values and obtain values as #' pixel or percent units. -#' @param column_labels.font.weight,stub_group.font.weight the font weight of the -#' \code{columns} and \code{stub_group} text element. -#' @param summary_row.text_transform an option to apply text transformations to -#' the label text in each summary row. -#' @param table.background.color,heading.background.color,column_labels.background.color,stub_group.background.color,summary_row.background.color +#' @param column_labels.font.weight,stub_group.font.weight the font weight of +#' the \code{columns} and \code{stub_group} text element. +#' @param summary_row.text_transform,grand_summary_row.text_transform an option +#' to apply text transformations to the label text in each summary row. +#' @param table.background.color,heading.background.color,column_labels.background.color,stub_group.background.color,summary_row.background.color,grand_summary_row.background.color #' background colors for the parent element \code{table} and the following #' child elements: \code{heading}, \code{columns}, \code{stub_group}, #' \code{summary_row}, and \code{field}. A color name or a hexadecimal color @@ -40,8 +40,8 @@ #' the style, width, and color of the field's top border. #' @param field.border.bottom.style,field.border.bottom.width,field.border.bottom.color #' the style, width, and color of the field's bottom border. -#' @param row.padding,summary_row.padding the amount of padding in each row and -#' in each summary row. +#' @param row.padding,summary_row.padding,grand_summary_row.padding the amount +#' of padding in each row and in each type of summary row. #' @param footnote.sep the separating characters between adjacent footnotes in #' the footnotes section. The default value produces a linebreak. #' @param footnote.glyph the set of sequential figures or characters used to @@ -188,6 +188,9 @@ tab_options <- function(data, summary_row.background.color = NULL, summary_row.padding = NULL, summary_row.text_transform = NULL, + grand_summary_row.background.color = NULL, + grand_summary_row.padding = NULL, + grand_summary_row.text_transform = NULL, footnote.sep = NULL, footnote.glyph = NULL, footnote.font.size = NULL, @@ -488,6 +491,30 @@ tab_options <- function(data, opts_df, "summary_row_text_transform", summary_row.text_transform) } + # grand_summary_row.background.color + if (!is.null(grand_summary_row.background.color)) { + + opts_df <- opts_df_set( + opts_df, "grand_summary_row_background_color", grand_summary_row.background.color) + } + + # grand_summary_row.padding + if (!is.null(grand_summary_row.padding)) { + + if (is.numeric(grand_summary_row.padding)) { + grand_summary_row.padding <- paste0(grand_summary_row.padding, "px") + } + + opts_df <- opts_df_set(opts_df, "grand_summary_row_padding", grand_summary_row.padding) + } + + # grand_summary_row.text_transform + if (!is.null(grand_summary_row.text_transform)) { + + opts_df <- opts_df_set( + opts_df, "grand_summary_row_text_transform", grand_summary_row.text_transform) + } + # footnote.sep if (!is.null(footnote.sep)) { From 836aeb676d670c48dc1a012534b4f7669c3c187a Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:31:13 -0500 Subject: [PATCH 37/92] Add util functions to support grand summaries --- R/tab_footnote.R | 20 ++++++++ R/tab_style.R | 20 ++++++++ R/utils_render_footnotes.R | 102 +++++++++++++++++++++++++++++-------- R/utils_render_html.R | 63 +++++++++++++++++++---- 4 files changed, 174 insertions(+), 31 deletions(-) diff --git a/R/tab_footnote.R b/R/tab_footnote.R index 937d93beb4..32d882cda3 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -219,6 +219,26 @@ set_footnote.cells_summary <- function(loc, data, footnote) { data } +set_footnote.cells_grand_summary <- function(loc, data, footnote) { + + rows <- (loc$rows %>% as.character())[-1] %>% as.integer() + + resolved <- resolve_cells_column_labels(data = data, object = loc) + + cols <- resolved$columns + + colnames <- colnames(as.data.frame(data))[cols] + + attr(data, "footnotes_df") <- + add_location_row( + data, df_type = "footnotes_df", + locname = "grand_summary_cells", locnum = 6, + grpname = NA_character_, colname = colnames, + rownum = rows, text = footnote) + + data +} + #' @importFrom dplyr bind_rows tibble distinct #' @noRd add_location_row <- function(data, diff --git a/R/tab_style.R b/R/tab_style.R index 8105147a8e..d19b3e56e3 100644 --- a/R/tab_style.R +++ b/R/tab_style.R @@ -252,3 +252,23 @@ set_style.cells_summary <- function(loc, data, style) { data } + +set_style.cells_grand_summary <- function(loc, data, style) { + + rows <- (loc$rows %>% as.character())[-1] %>% as.integer() + + resolved <- resolve_cells_column_labels(data = data, object = loc) + + cols <- resolved$columns + + colnames <- colnames(as.data.frame(data))[cols] + + attr(data, "styles_df") <- + add_location_row( + data, df_type = "styles_df", + locname = "grand_summary_cells", locnum = 6, + grpname = NA_character_, colname = colnames, + rownum = rows, text = style) + + data +} diff --git a/R/utils_render_footnotes.R b/R/utils_render_footnotes.R index b47c37f956..8e8690ea39 100644 --- a/R/utils_render_footnotes.R +++ b/R/utils_render_footnotes.R @@ -169,6 +169,31 @@ resolve_footnotes_styles <- function(output_df, ) } + # For the grand summary cells, insert a `colnum` based + # on `groups_rows_df` + if (6 %in% tbl[["locnum"]]) { + + tbl_not_g_summary_cells <- + tbl %>% + dplyr::filter(locnum != 6) + + tbl_g_summary_cells <- + tbl %>% + dplyr::filter(locnum == 6) %>% + dplyr::mutate( + colnum = colname_to_colnum( + boxh_df = boxh_df, colname = colname + ) + ) + + # Re-combine `tbl_not_g_summary_cells` + # with `tbl_g_summary_cells` + tbl <- + dplyr::bind_rows( + tbl_not_g_summary_cells, tbl_g_summary_cells + ) + } + # For the column label cells, insert a `colnum` # based on `boxh_df` if ("columns_columns" %in% tbl[["locname"]]) { @@ -535,37 +560,72 @@ apply_footnotes_to_summary <- function(list_of_summaries, summary_df_list <- list_of_summaries$summary_df_display_list - if (!("summary_cells" %in% footnotes_resolved$locname)) { + if (!("summary_cells" %in% footnotes_resolved$locname | + "grand_summary_cells" %in% footnotes_resolved$locname)) { return(list_of_summaries) } - footnotes_tbl_data <- - footnotes_resolved %>% - dplyr::filter(locname == "summary_cells") + if ("summary_cells" %in% footnotes_resolved$locname) { + + footnotes_tbl_data <- + footnotes_resolved %>% + dplyr::filter(locname == "summary_cells") - footnotes_data_glpyhs <- - footnotes_tbl_data %>% - dplyr::mutate(row = as.integer(round((rownum - floor(rownum)) * 100, 0))) %>% - dplyr::group_by(grpname, row, colnum) %>% - dplyr::mutate(fs_id_coalesced = paste(fs_id, collapse = ",")) %>% - dplyr::ungroup() %>% - dplyr::select(grpname, colname, row, fs_id_coalesced) %>% - dplyr::distinct() + footnotes_data_glpyhs <- + footnotes_tbl_data %>% + dplyr::mutate(row = as.integer(round((rownum - floor(rownum)) * 100, 0))) %>% + dplyr::group_by(grpname, row, colnum) %>% + dplyr::mutate(fs_id_coalesced = paste(fs_id, collapse = ",")) %>% + dplyr::ungroup() %>% + dplyr::select(grpname, colname, row, fs_id_coalesced) %>% + dplyr::distinct() - for (i in seq(nrow(footnotes_data_glpyhs))) { + for (i in seq(nrow(footnotes_data_glpyhs))) { - text <- - summary_df_list[[footnotes_data_glpyhs[i, ][["grpname"]]]][[ - footnotes_data_glpyhs$row[i], footnotes_data_glpyhs$colname[i]]] + text <- + summary_df_list[[footnotes_data_glpyhs[i, ][["grpname"]]]][[ + footnotes_data_glpyhs$row[i], footnotes_data_glpyhs$colname[i]]] + + text <- + paste0(text, footnote_glyph_to_html(footnotes_data_glpyhs$fs_id_coalesced[i])) - text <- - paste0(text, footnote_glyph_to_html(footnotes_data_glpyhs$fs_id_coalesced[i])) + summary_df_list[[footnotes_data_glpyhs[i, ][["grpname"]]]][[ + footnotes_data_glpyhs$row[i], footnotes_data_glpyhs$colname[i]]] <- text + } - summary_df_list[[footnotes_data_glpyhs[i, ][["grpname"]]]][[ - footnotes_data_glpyhs$row[i], footnotes_data_glpyhs$colname[i]]] <- text + list_of_summaries$summary_df_display_list <- summary_df_list } - list_of_summaries$summary_df_display_list <- summary_df_list + if ("grand_summary_cells" %in% footnotes_resolved$locname) { + + footnotes_tbl_data <- + footnotes_resolved %>% + dplyr::filter(locname == "grand_summary_cells") + + footnotes_data_glpyhs <- + footnotes_tbl_data %>% + dplyr::group_by(rownum, colnum) %>% + dplyr::mutate(fs_id_coalesced = paste(fs_id, collapse = ",")) %>% + dplyr::ungroup() %>% + dplyr::select(colname, rownum, fs_id_coalesced) %>% + dplyr::distinct() + + for (i in seq(nrow(footnotes_data_glpyhs))) { + + text <- + summary_df_list$`::GRAND_SUMMARY`[[ + footnotes_data_glpyhs$rownum[i], footnotes_data_glpyhs$colname[i]]] + + text <- + paste0(text, footnote_glyph_to_html(footnotes_data_glpyhs$fs_id_coalesced[i])) + + summary_df_list$`::GRAND_SUMMARY`[[ + footnotes_data_glpyhs$rownum[i], footnotes_data_glpyhs$colname[i]]] <- text + } + + list_of_summaries$summary_df_display_list$`::GRAND_SUMMARY` <- + summary_df_list$`::GRAND_SUMMARY` + } list_of_summaries } diff --git a/R/utils_render_html.R b/R/utils_render_html.R index d2ca904d51..fb41e61fb0 100644 --- a/R/utils_render_html.R +++ b/R/utils_render_html.R @@ -113,7 +113,7 @@ apply_styles_to_output <- function(output_df, split_body_content(body_content = body_styles, n_cols) } -# Apply footnotes to the data rows +#' Apply styles to summary rows #' @importFrom dplyr filter group_by mutate ungroup select distinct #' @noRd apply_styles_to_summary_output <- function(summary_df, @@ -127,7 +127,7 @@ apply_styles_to_summary_output <- function(summary_df, styles_tbl_summary <- styles_resolved %>% - dplyr::filter(locname == "summary_cells") %>% + dplyr::filter(locname %in% "summary_cells") %>% dplyr::filter(grpname == group) if (nrow(styles_tbl_summary) > 0) { @@ -158,6 +158,46 @@ apply_styles_to_summary_output <- function(summary_df, split_body_content(body_content = summary_styles, n_cols) } +#' Apply styles to summary rows +#' @importFrom dplyr filter group_by mutate ungroup select distinct +#' @noRd +apply_styles_to_grand_summary_output <- function(summary_df, + styles_resolved, + n_cols) { + + styles_summary_df <- summary_df + styles_summary_df[] <- NA_character_ + + styles_tbl_summary <- + styles_resolved %>% + dplyr::filter(locname %in% "grand_summary_cells") + + if (nrow(styles_tbl_summary) > 0) { + + styles_summary <- + styles_tbl_summary %>% + dplyr::group_by(colname, rownum) %>% + dplyr::mutate(styles_appended = paste(text, collapse = "")) %>% + dplyr::ungroup() %>% + dplyr::select(colname, rownum, styles_appended) %>% + dplyr::distinct() + + + for (i in seq(nrow(styles_summary))) { + + styles_summary_df[ + styles_summary$rownum[i], styles_summary$colname[i]] <- + styles_summary$styles_appended[i] + } + } + + # Extract `summary_styles` as a vector + summary_styles <- as.vector(t(styles_summary_df)) + + # Split `summary_styles` by slices of rows + split_body_content(body_content = summary_styles, n_cols) +} + # Create the opening HTML element of a table create_table_start_h <- function(groups_rows_df) { @@ -741,9 +781,11 @@ create_body_component_h <- function(row_splits_body, as.data.frame(stringsAsFactors = FALSE) row_splits_summary_styles <- - apply_styles_to_summary_output( - grand_summary_df, styles_resolved, - group = "::GRAND_SUMMARY", n_cols = n_cols) + apply_styles_to_grand_summary_output( + summary_df = grand_summary_df, + styles_resolved = styles_resolved, + n_cols = n_cols + ) grand_summary <- as.vector(t(grand_summary_df)) @@ -752,9 +794,10 @@ create_body_component_h <- function(row_splits_body, body_content = grand_summary, n_cols = n_cols) - # Provide CSS classes for leading and non-leading summary rows - summary_row_classes_first <- "gt_summary_row gt_first_grand_summary_row " - summary_row_classes <- "gt_summary_row " + # Provide CSS classes for leading and + # non-leading grand summary rows + gs_row_classes_first <- "gt_grand_summary_row gt_first_grand_summary_row " + gs_row_classes <- "gt_grand_summary_row " grand_summary_row_lines <- c() @@ -766,14 +809,14 @@ create_body_component_h <- function(row_splits_body, "\n", paste0( "", row_splits_grand_summary[[j]][1], ""), "\n", paste0( "", row_splits_grand_summary[[j]][-1], From 3369409927d54263a027d3603a591babde9081b8 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:31:28 -0500 Subject: [PATCH 38/92] Update help files using roxygen --- man/location_cells.Rd | 3 +++ man/summary_rows.Rd | 2 +- man/tab_options.Rd | 19 +++++++++++-------- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/man/location_cells.Rd b/man/location_cells.Rd index f6f2aba172..47134431f9 100644 --- a/man/location_cells.Rd +++ b/man/location_cells.Rd @@ -8,6 +8,7 @@ \alias{cells_stub} \alias{cells_data} \alias{cells_summary} +\alias{cells_grand_summary} \title{Helpers for targeting multiple cells in different locations} \usage{ cells_title(groups = c("title", "subtitle")) @@ -21,6 +22,8 @@ cells_stub(rows = NULL) cells_data(columns = NULL, rows = NULL) cells_summary(groups = NULL, columns = NULL, rows = NULL) + +cells_grand_summary(columns = NULL, rows = NULL) } \arguments{ \item{columns, rows, groups}{either a vector of names, a vector of diff --git a/man/summary_rows.Rd b/man/summary_rows.Rd index dc78930b82..951a85a961 100644 --- a/man/summary_rows.Rd +++ b/man/summary_rows.Rd @@ -4,7 +4,7 @@ \alias{summary_rows} \title{Add summary rows using aggregation functions} \usage{ -summary_rows(data, groups = TRUE, columns = NULL, fns, +summary_rows(data, groups = NULL, columns = TRUE, fns, missing_text = "---", formatter = fmt_number, ...) } \arguments{ diff --git a/man/tab_options.Rd b/man/tab_options.Rd index 03987ff0f0..92ce616e9b 100644 --- a/man/tab_options.Rd +++ b/man/tab_options.Rd @@ -25,7 +25,10 @@ tab_options(data, table.width = NULL, table.font.size = NULL, field.border.bottom.style = NULL, field.border.bottom.width = NULL, field.border.bottom.color = NULL, row.padding = NULL, summary_row.background.color = NULL, summary_row.padding = NULL, - summary_row.text_transform = NULL, footnote.sep = NULL, + summary_row.text_transform = NULL, + grand_summary_row.background.color = NULL, + grand_summary_row.padding = NULL, + grand_summary_row.text_transform = NULL, footnote.sep = NULL, footnote.glyph = NULL, footnote.font.size = NULL, footnote.padding = NULL, sourcenote.font.size = NULL, sourcenote.padding = NULL, row.striping.include_stub = NULL, @@ -52,7 +55,7 @@ units of pixels. The \code{\link{px}()} and \code{\link{pct}()} helper functions can also be used to pass in numeric values and obtain values as pixel or percent units.} -\item{table.background.color, heading.background.color, column_labels.background.color, stub_group.background.color, summary_row.background.color}{background colors for the parent element \code{table} and the following +\item{table.background.color, heading.background.color, column_labels.background.color, stub_group.background.color, summary_row.background.color, grand_summary_row.background.color}{background colors for the parent element \code{table} and the following child elements: \code{heading}, \code{columns}, \code{stub_group}, \code{summary_row}, and \code{field}. A color name or a hexadecimal color code should be provided.} @@ -61,8 +64,8 @@ code should be provided.} \item{heading.border.bottom.style, heading.border.bottom.width, heading.border.bottom.color}{the style, width, and color of the heading's bottom border.} -\item{column_labels.font.weight, stub_group.font.weight}{the font weight of the -\code{columns} and \code{stub_group} text element.} +\item{column_labels.font.weight, stub_group.font.weight}{the font weight of +the \code{columns} and \code{stub_group} text element.} \item{stub_group.border.top.style, stub_group.border.top.width, stub_group.border.top.color}{the style, width, and color of the stub heading's top border.} @@ -72,11 +75,11 @@ code should be provided.} \item{field.border.bottom.style, field.border.bottom.width, field.border.bottom.color}{the style, width, and color of the field's bottom border.} -\item{row.padding, summary_row.padding}{the amount of padding in each row and -in each summary row.} +\item{row.padding, summary_row.padding, grand_summary_row.padding}{the amount +of padding in each row and in each type of summary row.} -\item{summary_row.text_transform}{an option to apply text transformations to -the label text in each summary row.} +\item{summary_row.text_transform, grand_summary_row.text_transform}{an option +to apply text transformations to the label text in each summary row.} \item{footnote.sep}{the separating characters between adjacent footnotes in the footnotes section. The default value produces a linebreak.} From 3de1291a409987df88f5ea53fbd15309276a758c Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:31:37 -0500 Subject: [PATCH 39/92] Add to NAMESPACE --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index 5d3aa082b4..904831354a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ export(as_raw_html) export(as_rtf) export(cells_column_labels) export(cells_data) +export(cells_grand_summary) export(cells_group) export(cells_stub) export(cells_styles) From 3c9f73ce23fd2cba8cfe898ecb1ca0bd547171f0 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 02:31:52 -0500 Subject: [PATCH 40/92] Modify tests to reflect new behavior --- tests/testthat/test-tab_options.R | 10 +++++----- tests/testthat/test-util_functions.R | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-tab_options.R b/tests/testthat/test-tab_options.R index b53d2ab183..6cbe2189f2 100644 --- a/tests/testthat/test-tab_options.R +++ b/tests/testthat/test-tab_options.R @@ -517,17 +517,17 @@ test_that("the internal `opts_df` table can be correctly modified", { dplyr::filter(parameter == "row_padding") %>% dplyr::pull(value), attr(tbl_html, "opts_df", exact = TRUE) %>% dplyr::filter(parameter == "row_padding") %>% dplyr::pull(value)) %>% - expect_equal(c("10px", "8px")) + expect_equal(c("8px", "8px")) # Modify the `row.padding` option using just a numeric value - tbl_html <- data %>% tab_options(row.padding = 8) + tbl_html <- data %>% tab_options(row.padding = 6) # Compare before and after values c(opts_df_1 %>% dplyr::filter(parameter == "row_padding") %>% dplyr::pull(value), attr(tbl_html, "opts_df", exact = TRUE) %>% dplyr::filter(parameter == "row_padding") %>% dplyr::pull(value)) %>% - expect_equal(c("10px", "8px")) + expect_equal(c("8px", "6px")) # Modify the `summary_row.background.color` tbl_html <- data %>% tab_options(summary_row.background.color = "pink") @@ -547,7 +547,7 @@ test_that("the internal `opts_df` table can be correctly modified", { dplyr::filter(parameter == "summary_row_padding") %>% dplyr::pull(value), attr(tbl_html, "opts_df", exact = TRUE) %>% dplyr::filter(parameter == "summary_row_padding") %>% dplyr::pull(value)) %>% - expect_equal(c("6px", "4px")) + expect_equal(c("8px", "4px")) # Modify the `summary_row.padding` option using just a numeric value tbl_html <- data %>% tab_options(summary_row.padding = 4) @@ -557,7 +557,7 @@ test_that("the internal `opts_df` table can be correctly modified", { dplyr::filter(parameter == "summary_row_padding") %>% dplyr::pull(value), attr(tbl_html, "opts_df", exact = TRUE) %>% dplyr::filter(parameter == "summary_row_padding") %>% dplyr::pull(value)) %>% - expect_equal(c("6px", "4px")) + expect_equal(c("8px", "4px")) # Modify the `summary_row.text_transform` tbl_html <- data %>% tab_options(summary_row.text_transform = "lowercase") diff --git a/tests/testthat/test-util_functions.R b/tests/testthat/test-util_functions.R index 7ff74f161c..d1a8fdffa8 100644 --- a/tests/testthat/test-util_functions.R +++ b/tests/testthat/test-util_functions.R @@ -380,7 +380,7 @@ test_that("the `get_css_tbl()` function works correctly", { css_tbl %>% expect_is(c("tbl_df", "tbl", "data.frame")) - css_tbl %>% dim() %>% expect_equal(c(104, 4)) + css_tbl %>% dim() %>% expect_equal(c(108, 4)) css_tbl %>% colnames() %>% @@ -429,7 +429,7 @@ test_that("the `inline_html_styles()` function works correctly", { # Expect that the style rule from `tab_style` is a listed value along with # the inlined rules derived from the CSS classes expect_true( - grepl("style=\"padding:10px;margin:10px;vertical-align:middle;text-align:right;font-variant-numeric:tabular-nums;font-size:10px;\"", inlined_html) + grepl("style=\"padding:8px;margin:10px;vertical-align:middle;text-align:right;font-variant-numeric:tabular-nums;font-size:10px;\"", inlined_html) ) # Create a gt table with a custom style in the title and subtitle From 75f864783e581905928355e71118ed06fb00d343 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sat, 23 Feb 2019 18:34:02 -0500 Subject: [PATCH 41/92] Allow for stub creation when necessary --- R/summary_rows.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/R/summary_rows.R b/R/summary_rows.R index 9caab3a1af..c0344b960a 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -96,6 +96,20 @@ summary_rows <- function(data, return(data) } + # Get the `stub_df` object from `data` + stub_df <- attr(data, "stub_df", exact = TRUE) + + # If there isn't a stub available, create an + # 'empty' stub (populated with empty strings); + # the stub is necessary for summary row labels + if (!is_stub_available(stub_df) && is.null(groups)) { + + # Place the `rowname` values into `stub_df$rowname` + stub_df[["rowname"]] <- rep("", nrow(stub_df)) + + attr(data, "stub_df") <- stub_df + } + # Get a character vector of column names to # which `fns` applies # TODO: replace with improved resolver functions From de1d4520ff04e344396e91be747259ea21b93021 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sun, 24 Feb 2019 23:21:25 -0500 Subject: [PATCH 42/92] Add several tests for `summary_rows()` --- tests/testthat/test-summary_rows.R | 672 +++++++++++++++++++++++++---- 1 file changed, 590 insertions(+), 82 deletions(-) diff --git a/tests/testthat/test-summary_rows.R b/tests/testthat/test-summary_rows.R index da35f5c339..16b5ad753b 100644 --- a/tests/testthat/test-summary_rows.R +++ b/tests/testthat/test-summary_rows.R @@ -1,30 +1,37 @@ context("Ensuring that the `summary_rows()` function works as expected") -# Create a table with group names, rownames, and two columns of values +# Create a table based on `sp500`, with +# group names, rownames, and four +# columns of values tbl <- - dplyr::tribble( - ~groupname, ~rowname, ~value_1, ~value_2, - "A", "1", NA, 260.1, - "A", "2", 184.3, 84.4, - "A", "3", 342.3, 126.3, - "A", "4", 234.9, NA, - "B", "1", 190.9, 832.5, - "B", "2", 743.3, 281.2, - "B", "3", 252.3, 732.5, - "B", "4", 344.7, NA, - "C", "1", 197.2, 818.0, - "C", "2", 284.3, 394.4) - -test_that("the `summary_rows()` function works correctly", { - - # Create a table with summary rows for the `A` and `C` groups; - # the 3 summary rows for these groups represent the mean, sum, - # and standard deviation of `value` + sp500 %>% + dplyr::filter( + date >= "2015-01-05" & + date <="2015-01-16" + ) %>% + dplyr::arrange(date) %>% + dplyr::mutate( + week = paste0( + "W", strftime(date, format = "%V")) + ) %>% + dplyr::select(-adj_close, -volume) %>% + gt( + rowname_col = "date", + groupname_col = "week" + ) + +test_that("the `summary_rows()` can make groupwise summaries", { + + # Create a table with summary rows for + # the `W02` group; the 3 summary rows for + # this group represent the mean, sum, + # and standard deviation of all numeric + # columns gt_tbl <- - gt(tbl) %>% + tbl %>% summary_rows( - groups = c("A", "C"), - columns = vars(value_1), + groups = "W02", + columns = vars(open, high, low, close), fns = list( average = ~mean(., na.rm = TRUE), total = ~sum(., na.rm = TRUE), @@ -33,8 +40,9 @@ test_that("the `summary_rows()` function works correctly", { # Extract the internal `summary` object summary <- attr(gt_tbl, "summary", exact = TRUE) - # Expect that the internal `summary` list object has - # a length of `1` since there was only one call of `summary_rows()` + # Expect that the internal `summary` list + # object has a length of `1` since there was + # only one call of `summary_rows()` length(summary) %>% expect_equal(1) @@ -48,17 +56,17 @@ test_that("the `summary_rows()` function works correctly", { # Expect the `groups` provided in `summary[[1]]$groups` summary[[1]]$groups %>% - expect_equal(c("A", "C")) + expect_equal("W02") # Expect the `columns` provided in `summary[[1]]$columns` summary[[1]]$columns %>% - expect_equal("value_1") + expect_equal(c("open", "high", "low", "close")) - # Expect that `summary[[1]]$fns` is a `fun_list` object + # Expect that `summary[[1]]$fns` is a `list` object summary[[1]]$fns %>% expect_is("list") - # Expect that the components of `summary[[1]]$fns` are quosures + # Expect that the components of `summary[[1]]$fns` are formulas summary[[1]]$fns$average %>% expect_is("formula") summary[[1]]$fns$total %>% expect_is("formula") summary[[1]]$fns$`std dev` %>% expect_is("formula") @@ -75,14 +83,129 @@ test_that("the `summary_rows()` function works correctly", { summary[[1]]$formatter_options %>% expect_is("list") - # Create a table with summary rows for all groups and for `value_1`; - # the 3 summary rows for these groups represent the mean, sum, - # and the standard deviation + # Expect that `summary[[1]]$formatter_options` is + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) + + # Create a table with summary rows for + # the `W02` group; the 3 summary rows for + # this group represent the mean, sum, + # and standard deviation of only the + # `open` column gt_tbl <- - gt(tbl) %>% + tbl %>% + summary_rows( + groups = "W02", + columns = vars(open), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE))) + + # Extract the internal `summary` object + summary <- attr(gt_tbl, "summary", exact = TRUE) + + # Expect the `groups` provided in `summary[[1]]$groups` + summary[[1]]$groups %>% + expect_equal("W02") + + # Expect the `columns` provided in `summary[[1]]$columns` + summary[[1]]$columns %>% + expect_equal("open") + + # Expect that `summary[[1]]$fns` is a `list` object + summary[[1]]$fns %>% + expect_is("list") + + # Expect that the components of `summary[[1]]$fns` are formulas + summary[[1]]$fns$average %>% expect_is("formula") + summary[[1]]$fns$total %>% expect_is("formula") + summary[[1]]$fns$`std dev` %>% expect_is("formula") + + # Expect that `summary[[1]]$missing_text` has a specific value + summary[[1]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1]]$formatter` is a `function` object + summary[[1]]$formatter %>% + expect_is("function") + + # Expect that `summary[[1]]$formatter_options` is a list + summary[[1]]$formatter_options %>% + expect_is("list") + + # Expect that `summary[[1]]$formatter_options` is + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) + + # Create a table with summary rows for + # the `W02` and `W03` groups; the 3 summary + # rows for these groups represent the mean, + # sum, and standard deviation of only the + # `open` column + gt_tbl <- + tbl %>% + summary_rows( + groups = c("W02", "W03"), + columns = vars(open), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE))) + + # Extract the internal `summary` object + summary <- attr(gt_tbl, "summary", exact = TRUE) + + # Expect the `groups` provided in `summary[[1]]$groups` + summary[[1]]$groups %>% + expect_equal(c("W02", "W03")) + + # Expect the `columns` provided in `summary[[1]]$columns` + summary[[1]]$columns %>% + expect_equal("open") + + # Expect that `summary[[1]]$fns` is a `list` object + summary[[1]]$fns %>% + expect_is("list") + + # Expect that the components of `summary[[1]]$fns` are formulas + summary[[1]]$fns$average %>% expect_is("formula") + summary[[1]]$fns$total %>% expect_is("formula") + summary[[1]]$fns$`std dev` %>% expect_is("formula") + + # Expect that `summary[[1]]$missing_text` has a specific value + summary[[1]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1]]$formatter` is a `function` object + summary[[1]]$formatter %>% + expect_is("function") + + # Expect that `summary[[1]]$formatter_options` is a list + summary[[1]]$formatter_options %>% + expect_is("list") + + # Expect that `summary[[1]]$formatter_options` is + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) + + # Create a table with summary rows for + # the `W02` and `W03` groups (using + # `groups = TRUE`); the 3 summary rows for + # these groups represent the mean, + # sum, and standard deviation of only the + # `open` column + gt_tbl <- + tbl %>% summary_rows( groups = TRUE, - columns = vars(value_1), + columns = vars(open), fns = list( average = ~mean(., na.rm = TRUE), total = ~sum(., na.rm = TRUE), @@ -91,55 +214,151 @@ test_that("the `summary_rows()` function works correctly", { # Extract the internal `summary` object summary <- attr(gt_tbl, "summary", exact = TRUE) - # Expect that the internal `summary` list object has - # a length of `1` since there was only one call of `summary_rows()` + # Expect the `groups` provided in `summary[[1]]$groups` + # to be `TRUE` + summary[[1]]$groups %>% + expect_true() + + # Expect the `columns` provided in `summary[[1]]$columns` + summary[[1]]$columns %>% + expect_equal("open") + + # Expect that `summary[[1]]$fns` is a `list` object + summary[[1]]$fns %>% + expect_is("list") + + # Expect that the components of `summary[[1]]$fns` are formulas + summary[[1]]$fns$average %>% expect_is("formula") + summary[[1]]$fns$total %>% expect_is("formula") + summary[[1]]$fns$`std dev` %>% expect_is("formula") + + # Expect that `summary[[1]]$missing_text` has a specific value + summary[[1]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1]]$formatter` is a `function` object + summary[[1]]$formatter %>% + expect_is("function") + + # Expect that `summary[[1]]$formatter_options` is a list + summary[[1]]$formatter_options %>% + expect_is("list") + + # Expect that `summary[[1]]$formatter_options` is + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) + + # Create a table with two sets of summary rows for all groups + # and all columns + gt_tbl <- + tbl %>% + summary_rows( + groups = TRUE, + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE) + ) + ) %>% + summary_rows( + groups = TRUE, + columns = vars(open, high, low, close), + fns = list( + max = ~max(., na.rm = TRUE) + ) + ) + + # Extract the internal `summary` object + summary <- attr(gt_tbl, "summary", exact = TRUE) + + # Expect that the internal `summary` list + # object has a length of `2` since there + # were two calls of `summary_rows()` length(summary) %>% - expect_equal(1) + expect_equal(2) - # For the single list component in `summary`, expect specific - # names within it + # For the two list components in `summary`, expect specific + # names within them summary[[1]] %>% names() %>% expect_equal( c("groups", "columns", "fns", "missing_text", "formatter", "formatter_options")) - # Expect that `summary[[1]]$groups` is TRUE + summary[[2]] %>% + names() %>% + expect_equal( + c("groups", "columns", "fns", "missing_text", + "formatter", "formatter_options")) + + # Expect that `summary[[1|2]]$groups` is TRUE summary[[1]]$groups %>% expect_true() - # Expect that `summary[[1]]$columns` is `value_1` + summary[[2]]$groups %>% + expect_true() + + # Expect that `summary[[1|2]]$columns` has specific values summary[[1]]$columns %>% - expect_equal("value_1") + expect_equal(c("open", "high", "low", "close")) - # Expect that `summary[[1]]$fns` is a `fun_list` object + summary[[2]]$columns %>% + expect_equal(c("open", "high", "low", "close")) + + # Expect that `summary[[1|2]]$fns` is a `list` object summary[[1]]$fns %>% expect_is("list") - # Expect that the components of `summary[[1]]$fns` are quosures + summary[[2]]$fns %>% + expect_is("list") + + # Expect that the components of `summary[[1|2]]$fns` are formulas summary[[1]]$fns$average %>% expect_is("formula") summary[[1]]$fns$total %>% expect_is("formula") summary[[1]]$fns$`std dev` %>% expect_is("formula") + summary[[2]]$fns$max %>% expect_is("formula") - # Expect that `summary[[1]]$missing_text` has a specific value + # Expect that `summary[[1|2]]$missing_text` has a specific value summary[[1]]$missing_text %>% expect_equal("---") - # Expect that `summary[[1]]$formatter` is a `function` object + summary[[2]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1|2]]$formatter` is a `function` object summary[[1]]$formatter %>% expect_is("function") - # Expect that `summary[[1]]$formatter_options` is a list + summary[[2]]$formatter %>% + expect_is("function") + + # Expect that `summary[[1|2]]$formatter_options` is a list summary[[1]]$formatter_options %>% expect_is("list") + summary[[2]]$formatter_options %>% + expect_is("list") + + # Expect that `summary[[1|2]]$formatter_options` are both + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) + + summary[[2]]$formatter_options %>% + length() %>% + expect_equal(0) + # Create a table with two sets of summary rows for all groups # and all columns gt_tbl <- - gt(tbl) %>% + tbl %>% summary_rows( groups = TRUE, - columns = vars(value_1, value_2), + columns = vars(open, high), fns = list( average = ~mean(., na.rm = TRUE), total = ~sum(., na.rm = TRUE), @@ -148,17 +367,20 @@ test_that("the `summary_rows()` function works correctly", { ) %>% summary_rows( groups = TRUE, - columns = vars(value_1, value_2), + columns = vars(low, close), fns = list( - max = ~max(., na.rm = TRUE) + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE) ) ) # Extract the internal `summary` object summary <- attr(gt_tbl, "summary", exact = TRUE) - # Expect that the internal `summary` list object has - # a length of `2 since there are two calls of `summary_rows()` + # Expect that the internal `summary` list + # object has a length of `2` since there + # were two calls of `summary_rows()` length(summary) %>% expect_equal(2) @@ -185,23 +407,25 @@ test_that("the `summary_rows()` function works correctly", { # Expect that `summary[[1|2]]$columns` has specific values summary[[1]]$columns %>% - expect_equal(c("value_1", "value_2")) + expect_equal(c("open", "high")) summary[[2]]$columns %>% - expect_equal(c("value_1", "value_2")) + expect_equal(c("low", "close")) - # Expect that `summary[[1|2]]$fns` is a `fun_list` object + # Expect that `summary[[1|2]]$fns` is a `list` object summary[[1]]$fns %>% expect_is("list") summary[[2]]$fns %>% expect_is("list") - # Expect that the components of `summary[[1|2]]$fns` are quosures + # Expect that the components of `summary[[1|2]]$fns` are formulas summary[[1]]$fns$average %>% expect_is("formula") summary[[1]]$fns$total %>% expect_is("formula") summary[[1]]$fns$`std dev` %>% expect_is("formula") - summary[[2]]$fns$max %>% expect_is("formula") + summary[[2]]$fns$average %>% expect_is("formula") + summary[[2]]$fns$total %>% expect_is("formula") + summary[[2]]$fns$`std dev` %>% expect_is("formula") # Expect that `summary[[1|2]]$missing_text` has a specific value summary[[1]]$missing_text %>% @@ -224,45 +448,329 @@ test_that("the `summary_rows()` function works correctly", { summary[[2]]$formatter_options %>% expect_is("list") - # Create a table with summary rows for the `A` and `C` groups; - # the 3 summary rows for these groups represent the mean, sum, - # and standard deviation of `value` + # Expect that `summary[[1|2]]$formatter_options` are both + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) + + summary[[2]]$formatter_options %>% + length() %>% + expect_equal(0) +}) + +test_that("the `summary_rows()` can make grand summaries", { + + # Create a table with a grand summary; + # the 3 summary rows for represent the + # mean, sum, and standard deviation of + # all numeric columns gt_tbl <- - gt(tbl) %>% + tbl %>% summary_rows( - groups = c("A", "C"), - columns = vars(value_1), + groups = NULL, + columns = vars(open, high, low, close), fns = list( average = ~mean(., na.rm = TRUE), total = ~sum(., na.rm = TRUE), `std dev` = ~sd(., na.rm = TRUE))) - # Extract the summary data from `gt_tbl` - summaries <- extract_summary(gt_tbl) + # Extract the internal `summary` object + summary <- attr(gt_tbl, "summary", exact = TRUE) - # Expect that `summaries` is a list object - summaries %>% expect_is("list") + # Expect that the internal `summary` list + # object has a length of `1` since there was + # only one call of `summary_rows()` + length(summary) %>% + expect_equal(1) - # Expect that `summaries` has a length of `2` - summaries %>% + # For the single list component in `summary`, expect specific + # names within it + summary[[1]] %>% + names() %>% + expect_equal( + c("groups", "columns", "fns", "missing_text", + "formatter", "formatter_options")) + + # Expect the `groups` provided in `summary[[1]]$groups` + # is NULL + summary[[1]]$groups %>% + expect_null() + + # Expect the `columns` provided in `summary[[1]]$columns` + # provide names for all columns + summary[[1]]$columns %>% + expect_equal(c("open", "high", "low", "close")) + + # Expect that `summary[[1]]$fns` is a `list` object + summary[[1]]$fns %>% + expect_is("list") + + # Expect that the components of `summary[[1]]$fns` are formulas + summary[[1]]$fns$average %>% expect_is("formula") + summary[[1]]$fns$total %>% expect_is("formula") + summary[[1]]$fns$`std dev` %>% expect_is("formula") + + # Expect that `summary[[1]]$missing_text` has a specific value + summary[[1]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1]]$formatter` is a `function` object + summary[[1]]$formatter %>% + expect_is("function") + + # Expect that `summary[[1]]$formatter_options` is a list + summary[[1]]$formatter_options %>% + expect_is("list") + + # Create a table with a grand summary; + # the 3 summary rows for represent the + # mean, sum, and standard deviation of + # all numeric columns; split into 2 calls + # that allow for different formatting + # options + gt_tbl <- + tbl %>% + summary_rows( + groups = NULL, + columns = vars(open, high), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE)), + formatter = fmt_number, + decimals = 3) %>% + summary_rows( + groups = NULL, + columns = vars(low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE)), + formatter = fmt_number, + decimals = 5) + + # Extract the internal `summary` object + summary <- attr(gt_tbl, "summary", exact = TRUE) + + # Expect that the internal `summary` list + # object has a length of `2` since there + # were two calls of `summary_rows()` + length(summary) %>% + expect_equal(2) + + # For the two list components in `summary`, expect specific + # names within them + summary[[1]] %>% + names() %>% + expect_equal( + c("groups", "columns", "fns", "missing_text", + "formatter", "formatter_options")) + + summary[[2]] %>% + names() %>% + expect_equal( + c("groups", "columns", "fns", "missing_text", + "formatter", "formatter_options")) + + # Expect that `summary[[1|2]]$groups` is TRUE + summary[[1]]$groups %>% + expect_null() + + summary[[2]]$groups %>% + expect_null() + + # Expect that `summary[[1|2]]$columns` has specific values + summary[[1]]$columns %>% + expect_equal(c("open", "high")) + + summary[[2]]$columns %>% + expect_equal(c("low", "close")) + + # Expect that `summary[[1|2]]$fns` is a `list` object + summary[[1]]$fns %>% + expect_is("list") + + summary[[2]]$fns %>% + expect_is("list") + + # Expect that the functions used in each call + # are the same + expect_identical(summary[[1]]$fns, summary[[1]]$fns) + + # Expect that the components of `summary[[1|2]]$fns` are formulas + summary[[1]]$fns$average %>% expect_is("formula") + summary[[1]]$fns$total %>% expect_is("formula") + summary[[1]]$fns$`std dev` %>% expect_is("formula") + summary[[2]]$fns$average %>% expect_is("formula") + summary[[2]]$fns$total %>% expect_is("formula") + summary[[2]]$fns$`std dev` %>% expect_is("formula") + + # Expect that `summary[[1|2]]$missing_text` has a specific value + summary[[1]]$missing_text %>% + expect_equal("---") + + summary[[2]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1|2]]$formatter` is a `function` object + summary[[1]]$formatter %>% + expect_is("function") + + summary[[2]]$formatter %>% + expect_is("function") + + # Expect that the formatters used in each call + # are the same + expect_identical(summary[[1]]$formatter, summary[[2]]$formatter) + + # Expect that `summary[[1|2]]$formatter_options` is a list + summary[[1]]$formatter_options %>% + expect_is("list") + + summary[[2]]$formatter_options %>% + expect_is("list") + + # Expect that `summary[[1|2]]$formatter_options` are both + # of length 1 + summary[[1]]$formatter_options %>% length() %>% + expect_equal(1) + + summary[[2]]$formatter_options %>% + length() %>% + expect_equal(1) + + # Expect that `summary[[1|2]]$formatter_options` + # are both named `decimals` + summary[[1]]$formatter_options %>% + names() %>% + expect_equal("decimals") + + summary[[2]]$formatter_options %>% + names() %>% + expect_equal("decimals") + + # Expect that the `summary[[1|2]]$formatter_options` + # `decimals` options have specific values + summary[[1]]$formatter_options[[1]] %>% + expect_equal(3) + + summary[[2]]$formatter_options[[1]] %>% + expect_equal(5) + + # Create a table with groupwsie summaries + # and a grand summary; all summary rows + # represent the mean, sum, and standard + # deviation of all numeric columns; + gt_tbl <- + tbl %>% + summary_rows( + groups = TRUE, + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE)) + ) %>% + summary_rows( + groups = NULL, + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE)) + ) + + # Extract the internal `summary` object + summary <- attr(gt_tbl, "summary", exact = TRUE) + + # Expect that the internal `summary` list + # object has a length of `2` since there + # were two calls of `summary_rows()` + length(summary) %>% expect_equal(2) - # Expect that `summaries` the names `A` and `C` - summaries %>% + # For the two list components in `summary`, expect specific + # names within them + summary[[1]] %>% + names() %>% + expect_equal( + c("groups", "columns", "fns", "missing_text", + "formatter", "formatter_options")) + + summary[[2]] %>% names() %>% - expect_equal(c("A", "C")) + expect_equal( + c("groups", "columns", "fns", "missing_text", + "formatter", "formatter_options")) + + # Expect that `summary[[1]]$groups` is TRUE + summary[[1]]$groups %>% + expect_true() + + # Expect that `summary[[1]]$groups` is NULL + summary[[2]]$groups %>% + expect_null() + + # Expect that `summary[[1|2]]$columns` has specific values + summary[[1]]$columns %>% + expect_equal(c("open", "high", "low", "close")) + + summary[[2]]$columns %>% + expect_equal(c("open", "high", "low", "close")) + + # Expect that `summary[[1|2]]$fns` is a `list` object + summary[[1]]$fns %>% + expect_is("list") + + summary[[2]]$fns %>% + expect_is("list") + + # Expect that the functions used in each call + # are the same + expect_identical(summary[[1]]$fns, summary[[1]]$fns) + + # Expect that the components of `summary[[1|2]]$fns` are formulas + summary[[1]]$fns$average %>% expect_is("formula") + summary[[1]]$fns$total %>% expect_is("formula") + summary[[1]]$fns$`std dev` %>% expect_is("formula") + summary[[2]]$fns$average %>% expect_is("formula") + summary[[2]]$fns$total %>% expect_is("formula") + summary[[2]]$fns$`std dev` %>% expect_is("formula") + + # Expect that `summary[[1|2]]$missing_text` has a specific value + summary[[1]]$missing_text %>% + expect_equal("---") + + summary[[2]]$missing_text %>% + expect_equal("---") + + # Expect that `summary[[1|2]]$formatter` is a `function` object + summary[[1]]$formatter %>% + expect_is("function") + + summary[[2]]$formatter %>% + expect_is("function") + + # Expect that the formatters used in each call + # are the same + expect_identical(summary[[1]]$formatter, summary[[2]]$formatter) + + # Expect that `summary[[1|2]]$formatter_options` is a list + summary[[1]]$formatter_options %>% + expect_is("list") - # Expect that each of the components contains a `tibble` - summaries[[1]] %>% - expect_is(c("tbl_df", "tbl", "data.frame")) + summary[[2]]$formatter_options %>% + expect_is("list") - summaries[[2]] %>% - expect_is(c("tbl_df", "tbl", "data.frame")) + # Expect that `summary[[1|2]]$formatter_options` are both + # of length 0 + summary[[1]]$formatter_options %>% + length() %>% + expect_equal(0) - # Expect an error in the case where `extract_summary()` - # is called on a gt table object where there is no summary - expect_error( - gt(mtcars) %>% - extract_summary()) + summary[[2]]$formatter_options %>% + length() %>% + expect_equal(0) }) From 6ca45518c840626b5f4fb796764c5f8a4d1f518d Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 02:31:10 -0500 Subject: [PATCH 43/92] Modify roxygen @param statement --- R/summary_rows.R | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index c0344b960a..495ee6245d 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -6,14 +6,13 @@ #' purposes, the \code{\link{extract_summary}()} can be used with a #' \code{gt_tbl} object where summary rows were added via \code{summary_rows()}. #' @param data a table object that is created using the \code{gt()} function. -#' @param groups the groups to consider for generation of groupwise summary rows -#' or a logical value. Providing the names of row groups in \code{c()} will -#' limit summary rows to those groups. Setting this to \code{TRUE} indicates -#' that all available groups will receive summary rows. Setting to either -#' \code{FALSE} or \code{NULL} will result in the addition of grand summary -#' rows, a summary of which operates on all table data. By default, this is -#' set to \code{TRUE} which means that all row groups will receive their own -#' sets of summary rows. +#' @param groups the groups to consider for generation of groupwise summary +#' rows. By default this is set to \code{NULL}, which results in the formation +#' of grand summary rows (a grand summary operates on all table data). +#' Providing the names of row groups in \code{c()} will create a groupwise +#' summary and generate summary rows for the specified groups. Setting this to +#' \code{TRUE} indicates that all available groups will receive groupwise +#' summary rows. #' @param columns the columns for which the summaries should be calculated. #' @param fns functions used for aggregations. This can include base functions #' like \code{mean}, \code{min}, \code{max}, \code{median}, \code{sd}, or From a73a4a716db849ada964dddf0acf42f81fc27906 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 02:34:18 -0500 Subject: [PATCH 44/92] Modify roxygen @param statement --- R/summary_rows.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 495ee6245d..074225273d 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -19,12 +19,12 @@ #' \code{sum} or any other user-defined aggregation function. The function(s) #' should be supplied within a \code{list()}. Within that list, we can specify #' the functions by use of function names in quotes (e.g., \code{"sum"}), as -#' bare functions (e.g., \code{sum}), or one-sided R formulas using a leading -#' \code{~} and a \code{.} that serves as the data to be summarized (e.g., -#' \code{sum(., na.rm = TRUE)}). The use of named arguments is recommended as -#' the names will serve as summary row labels for the corresponding summary -#' rows data (the labels can derived from the function names but only when not -#' providing bare function names). +#' bare functions (e.g., \code{sum}), or as one-sided R formulas using a +#' leading \code{~}. In the formula representation, a \code{.} serves as the +#' data to be summarized (e.g., \code{sum(., na.rm = TRUE)}). The use of named +#' arguments is recommended as the names will serve as summary row labels for +#' the corresponding summary rows data (the labels can derived from the +#' function names but only when not providing bare function names). #' @param missing_text the text to be used in place of \code{NA} values in #' summary cells with no data outputs. #' @param formatter a formatter function name. These can be any of the From 44f1ee033c5fa283319487521be74efedf41a6a2 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 02:34:41 -0500 Subject: [PATCH 45/92] Update help file using roxygen --- man/summary_rows.Rd | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/man/summary_rows.Rd b/man/summary_rows.Rd index 951a85a961..94ae6cc801 100644 --- a/man/summary_rows.Rd +++ b/man/summary_rows.Rd @@ -10,14 +10,13 @@ summary_rows(data, groups = NULL, columns = TRUE, fns, \arguments{ \item{data}{a table object that is created using the \code{gt()} function.} -\item{groups}{the groups to consider for generation of groupwise summary rows -or a logical value. Providing the names of row groups in \code{c()} will -limit summary rows to those groups. Setting this to \code{TRUE} indicates -that all available groups will receive summary rows. Setting to either -\code{FALSE} or \code{NULL} will result in the addition of grand summary -rows, a summary of which operates on all table data. By default, this is -set to \code{TRUE} which means that all row groups will receive their own -sets of summary rows.} +\item{groups}{the groups to consider for generation of groupwise summary +rows. By default this is set to \code{NULL}, which results in the formation +of grand summary rows (a grand summary operates on all table data). +Providing the names of row groups in \code{c()} will create a groupwise +summary and generate summary rows for the specified groups. Setting this to +\code{TRUE} indicates that all available groups will receive groupwise +summary rows.} \item{columns}{the columns for which the summaries should be calculated.} @@ -26,12 +25,12 @@ like \code{mean}, \code{min}, \code{max}, \code{median}, \code{sd}, or \code{sum} or any other user-defined aggregation function. The function(s) should be supplied within a \code{list()}. Within that list, we can specify the functions by use of function names in quotes (e.g., \code{"sum"}), as -bare functions (e.g., \code{sum}), or one-sided R formulas using a leading -\code{~} and a \code{.} that serves as the data to be summarized (e.g., -\code{sum(., na.rm = TRUE)}). The use of named arguments is recommended as -the names will serve as summary row labels for the corresponding summary -rows data (the labels can derived from the function names but only when not -providing bare function names).} +bare functions (e.g., \code{sum}), or as one-sided R formulas using a +leading \code{~}. In the formula representation, a \code{.} serves as the +data to be summarized (e.g., \code{sum(., na.rm = TRUE)}). The use of named +arguments is recommended as the names will serve as summary row labels for +the corresponding summary rows data (the labels can derived from the +function names but only when not providing bare function names).} \item{missing_text}{the text to be used in place of \code{NA} values in summary cells with no data outputs.} From 491c755d2d180c08d7c1ac7762cf7598c02ee795 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 02:43:13 -0500 Subject: [PATCH 46/92] Modify roxygen description text --- R/summary_rows.R | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 074225273d..8d8c4a5cbe 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -1,10 +1,16 @@ #' Add summary rows using aggregation functions #' -#' Add summary rows to one or more row groups by using the input data already -#' provided in the \code{\link{gt}()} function alongside any suitable -#' aggregation functions. Should we need to obtain the summary data for external -#' purposes, the \code{\link{extract_summary}()} can be used with a -#' \code{gt_tbl} object where summary rows were added via \code{summary_rows()}. +#' Add groupwise summary rows to one or more row groups by using the input data +#' already provided in the \code{\link{gt}()} function alongside any suitable +#' aggregation functions. Or, add a grand summary that incorporates all +#' available data, regardless of grouping. You choose how to format the values +#' in the resulting summary cells by use of a \code{formatter} function (e.g, +#' \code{\link{fmt_number}()) and any relevant options. +#' +#' Should we need to obtain the summary data for external purposes, the +#' \code{\link{extract_summary}()} function can be used with a \code{gt_tbl} +#' object where summary rows were added via \code{summary_rows()}. +#' #' @param data a table object that is created using the \code{gt()} function. #' @param groups the groups to consider for generation of groupwise summary #' rows. By default this is set to \code{NULL}, which results in the formation From bf924c94ad8694fcf3f230c10beda2ccea3e84c0 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 02:43:50 -0500 Subject: [PATCH 47/92] Modify roxygen description text --- R/summary_rows.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 8d8c4a5cbe..335df155de 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -5,7 +5,7 @@ #' aggregation functions. Or, add a grand summary that incorporates all #' available data, regardless of grouping. You choose how to format the values #' in the resulting summary cells by use of a \code{formatter} function (e.g, -#' \code{\link{fmt_number}()) and any relevant options. +#' \code{\link{fmt_number}()}) and any relevant options. #' #' Should we need to obtain the summary data for external purposes, the #' \code{\link{extract_summary}()} function can be used with a \code{gt_tbl} From 46bb9f76e46ac671bafc1ea081a9fdad4dfc499e Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 02:43:59 -0500 Subject: [PATCH 48/92] Update help file using roxygen --- man/summary_rows.Rd | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/man/summary_rows.Rd b/man/summary_rows.Rd index 94ae6cc801..38d1a4eb1b 100644 --- a/man/summary_rows.Rd +++ b/man/summary_rows.Rd @@ -51,11 +51,17 @@ as \code{decimals}, \code{use_seps}, and \code{locale} can be used.} an object of class \code{gt_tbl}. } \description{ -Add summary rows to one or more row groups by using the input data already -provided in the \code{\link{gt}()} function alongside any suitable -aggregation functions. Should we need to obtain the summary data for external -purposes, the \code{\link{extract_summary}()} can be used with a -\code{gt_tbl} object where summary rows were added via \code{summary_rows()}. +Add groupwise summary rows to one or more row groups by using the input data +already provided in the \code{\link{gt}()} function alongside any suitable +aggregation functions. Or, add a grand summary that incorporates all +available data, regardless of grouping. You choose how to format the values +in the resulting summary cells by use of a \code{formatter} function (e.g, +\code{\link{fmt_number}()}) and any relevant options. +} +\details{ +Should we need to obtain the summary data for external purposes, the +\code{\link{extract_summary}()} function can be used with a \code{gt_tbl} +object where summary rows were added via \code{summary_rows()}. } \section{Figures}{ From c56070b58ae9e20fd1791b65fdb727a9bb855b34 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 16:32:01 -0500 Subject: [PATCH 49/92] Modify assignment to df --- R/summary_rows.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 335df155de..4c7ccaea0c 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -110,7 +110,7 @@ summary_rows <- function(data, if (!is_stub_available(stub_df) && is.null(groups)) { # Place the `rowname` values into `stub_df$rowname` - stub_df[["rowname"]] <- rep("", nrow(stub_df)) + stub_df[["rowname"]] <- "" attr(data, "stub_df") <- stub_df } From b22c73499afe28ed1c92ea2f14c7c6285482b30f Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Mon, 25 Feb 2019 21:38:03 -0500 Subject: [PATCH 50/92] Use `resolve_vars()` to obtain colnames --- R/summary_rows.R | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 4c7ccaea0c..638cec056a 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -115,15 +115,9 @@ summary_rows <- function(data, attr(data, "stub_df") <- stub_df } - # Get a character vector of column names to - # which `fns` applies - # TODO: replace with improved resolver functions - # once that is merged to master - if (is.null(columns)) { - columns <- TRUE - } else if (!is.null(columns) && inherits(columns, "quosures")) { - columns <- columns %>% lapply(`[[`, 2) %>% as.character() - } + columns <- enquo(columns) + + columns <- resolve_vars(var_expr = !!columns, data = data) # Append list of summary inputs to the # `summary` attribute From b63cebb2d5fad2933e1236138aae683108233c2c Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 27 Feb 2019 10:56:15 -0500 Subject: [PATCH 51/92] Obtain and store labels in `summary_rows()` --- R/summary_rows.R | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 82c3265051..be49374cda 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -119,9 +119,15 @@ summary_rows <- function(data, attr(data, "stub_df") <- stub_df } - columns <- enquo(columns) + # Derive the summary labels + summary_labels <- + vapply(fns, derive_summary_label, FUN.VALUE = character(1)) - columns <- resolve_vars(var_expr = !!columns, data = data) + # If there are names, use those names + # as the summary labels + if (!is.null(names(summary_labels))) { + summary_labels <- names(summary_labels) + } # Append list of summary inputs to the # `summary` attribute @@ -133,6 +139,7 @@ summary_rows <- function(data, groups = groups, columns = columns, fns = fns, + summary_labels = summary_labels, missing_text = missing_text, formatter = formatter, formatter_options = formatter_options From f6dacb3a9f61974daed6140a1b69e3848e572a18 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 27 Feb 2019 10:58:10 -0500 Subject: [PATCH 52/92] Revise `*.cells_summary` to use multiple expr types --- R/tab_footnote.R | 91 ++++++++++++++++++++++++++++++++++++++++-------- R/tab_style.R | 91 ++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 154 insertions(+), 28 deletions(-) diff --git a/R/tab_footnote.R b/R/tab_footnote.R index 32d882cda3..277c63b0e5 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -200,21 +200,84 @@ set_footnote.cells_title <- function(loc, data, footnote) { set_footnote.cells_summary <- function(loc, data, footnote) { - groups <- (loc$groups %>% as.character())[-1] - rows <- (loc$rows %>% as.character())[-1] %>% as.integer() - - resolved <- resolve_cells_column_labels(data = data, object = loc) - - cols <- resolved$columns - - colnames <- colnames(as.data.frame(data))[cols] + stub_df <- attr(data, "stub_df", exact = TRUE) + + row_groups <- + stub_df[, "groupname"] %>% + unique() + + summary_data <- attr(data, "summary", exact = TRUE) + summary_data <- subset(summary_data, is.null(summary_data$groups)) + + summary_data_summaries <- + vapply( + seq(summary_data), + function(x) !is.null(summary_data[[x]]$groups), + logical(1) + ) + + summary_data <- summary_data[summary_data_summaries] + + groups <- + row_groups[resolve_data_vals_idx( + var_expr = !!loc$groups, + data = NULL, + vals = row_groups + )] + + for (group in groups) { + + summary_labels <- + lapply( + seq(summary_data), + function(x) { + if (is.logical(summary_data[[x]]$groups)) { + summary_data[[x]]$summary_labels + } else if (group %in% summary_data[[x]]$groups){ + summary_data[[x]]$summary_labels + } + } + ) %>% + unlist() %>% + unique() + + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data = NULL, + vals = summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } - attr(data, "footnotes_df") <- - add_location_row( - data, df_type = "footnotes_df", - locname = "summary_cells", locnum = 5, - grpname = groups, colname = colnames, - rownum = rows, text = footnote) + attr(data, "footnotes_df") <- + add_location_row( + data, + df_type = "footnotes_df", + locname = "summary_cells", + locnum = 5, + grpname = group, + colname = columns, + rownum = rows, + text = footnote + ) + } data } diff --git a/R/tab_style.R b/R/tab_style.R index d19b3e56e3..a51e11ab97 100644 --- a/R/tab_style.R +++ b/R/tab_style.R @@ -234,21 +234,84 @@ set_style.cells_title <- function(loc, data, style) { set_style.cells_summary <- function(loc, data, style) { - groups <- (loc$groups %>% as.character())[-1] - rows <- (loc$rows %>% as.character())[-1] %>% as.integer() - - resolved <- resolve_cells_column_labels(data = data, object = loc) - - cols <- resolved$columns - - colnames <- colnames(as.data.frame(data))[cols] + stub_df <- attr(data, "stub_df", exact = TRUE) + + row_groups <- + stub_df[, "groupname"] %>% + unique() + + summary_data <- attr(data, "summary", exact = TRUE) + summary_data <- subset(summary_data, is.null(summary_data$groups)) + + summary_data_summaries <- + vapply( + seq(summary_data), + function(x) !is.null(summary_data[[x]]$groups), + logical(1) + ) + + summary_data <- summary_data[summary_data_summaries] + + groups <- + row_groups[resolve_data_vals_idx( + var_expr = !!loc$groups, + data = NULL, + vals = row_groups + )] + + for (group in groups) { + + summary_labels <- + lapply( + seq(summary_data), + function(x) { + if (is.logical(summary_data[[x]]$groups)) { + summary_data[[x]]$summary_labels + } else if (group %in% summary_data[[x]]$groups){ + summary_data[[x]]$summary_labels + } + } + ) %>% + unlist() %>% + unique() + + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data = NULL, + vals = summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } - attr(data, "styles_df") <- - add_location_row( - data, df_type = "styles_df", - locname = "summary_cells", locnum = 5, - grpname = groups, colname = colnames, - rownum = rows, text = style) + attr(data, "styles_df") <- + add_location_row( + data, + df_type = "styles_df", + locname = "summary_cells", + locnum = 5, + grpname = group, + colname = columns, + rownum = rows, + text = style + ) + } data } From f6dddbe0c7a8b6b6e4fa4938dfcdb7e5da1a6452 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 27 Feb 2019 10:58:29 -0500 Subject: [PATCH 53/92] Revise `*.cells_grand_summary` to use multiple expr types --- R/tab_footnote.R | 47 +++++++++++++++++++++++++++++++++++++++-------- R/tab_style.R | 47 +++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 78 insertions(+), 16 deletions(-) diff --git a/R/tab_footnote.R b/R/tab_footnote.R index 277c63b0e5..a874a0eb02 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -284,20 +284,51 @@ set_footnote.cells_summary <- function(loc, data, footnote) { set_footnote.cells_grand_summary <- function(loc, data, footnote) { - rows <- (loc$rows %>% as.character())[-1] %>% as.integer() + summary_data <- attr(data, "summary", exact = TRUE) - resolved <- resolve_cells_column_labels(data = data, object = loc) + grand_summary_data <- subset(summary_data, is.null(summary_data$groups)) - cols <- resolved$columns + grand_summary_labels <- + lapply(grand_summary_data, `[[`, "summary_labels") %>% + unlist() %>% + unique() - colnames <- colnames(as.data.frame(data))[cols] + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data = NULL, + vals = grand_summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } attr(data, "footnotes_df") <- add_location_row( - data, df_type = "footnotes_df", - locname = "grand_summary_cells", locnum = 6, - grpname = NA_character_, colname = colnames, - rownum = rows, text = footnote) + data, + df_type = "footnotes_df", + locname = "grand_summary_cells", + locnum = 6, + grpname = NA_character_, + colname = columns, + rownum = rows, + text = footnote + ) data } diff --git a/R/tab_style.R b/R/tab_style.R index a51e11ab97..4e41c12fe8 100644 --- a/R/tab_style.R +++ b/R/tab_style.R @@ -318,20 +318,51 @@ set_style.cells_summary <- function(loc, data, style) { set_style.cells_grand_summary <- function(loc, data, style) { - rows <- (loc$rows %>% as.character())[-1] %>% as.integer() + summary_data <- attr(data, "summary", exact = TRUE) - resolved <- resolve_cells_column_labels(data = data, object = loc) + grand_summary_data <- subset(summary_data, is.null(summary_data$groups)) - cols <- resolved$columns + grand_summary_labels <- + lapply(grand_summary_data, `[[`, "summary_labels") %>% + unlist() %>% + unique() - colnames <- colnames(as.data.frame(data))[cols] + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data = NULL, + vals = grand_summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } attr(data, "styles_df") <- add_location_row( - data, df_type = "styles_df", - locname = "grand_summary_cells", locnum = 6, - grpname = NA_character_, colname = colnames, - rownum = rows, text = style) + data, + df_type = "styles_df", + locname = "grand_summary_cells", + locnum = 6, + grpname = NA_character_, + colname = columns, + rownum = rows, + text = style + ) data } From 1ade3d851d67332dccb93355e626394075fb6708 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 27 Feb 2019 10:58:45 -0500 Subject: [PATCH 54/92] Modify several testthat tests --- tests/testthat/test-summary_rows.R | 50 ++++++++++++++++++------------ 1 file changed, 30 insertions(+), 20 deletions(-) diff --git a/tests/testthat/test-summary_rows.R b/tests/testthat/test-summary_rows.R index 16b5ad753b..574cd149e2 100644 --- a/tests/testthat/test-summary_rows.R +++ b/tests/testthat/test-summary_rows.R @@ -51,8 +51,9 @@ test_that("the `summary_rows()` can make groupwise summaries", { summary[[1]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) # Expect the `groups` provided in `summary[[1]]$groups` summary[[1]]$groups %>% @@ -285,14 +286,16 @@ test_that("the `summary_rows()` can make groupwise summaries", { summary[[1]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) summary[[2]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) # Expect that `summary[[1|2]]$groups` is TRUE summary[[1]]$groups %>% @@ -389,14 +392,16 @@ test_that("the `summary_rows()` can make groupwise summaries", { summary[[1]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) summary[[2]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) # Expect that `summary[[1|2]]$groups` is TRUE summary[[1]]$groups %>% @@ -489,8 +494,9 @@ test_that("the `summary_rows()` can make grand summaries", { summary[[1]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) # Expect the `groups` provided in `summary[[1]]$groups` # is NULL @@ -564,14 +570,16 @@ test_that("the `summary_rows()` can make grand summaries", { summary[[1]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) summary[[2]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) # Expect that `summary[[1|2]]$groups` is TRUE summary[[1]]$groups %>% @@ -696,14 +704,16 @@ test_that("the `summary_rows()` can make grand summaries", { summary[[1]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) summary[[2]] %>% names() %>% expect_equal( - c("groups", "columns", "fns", "missing_text", - "formatter", "formatter_options")) + c("groups", "columns", "fns", "summary_labels", + "missing_text", "formatter", "formatter_options") + ) # Expect that `summary[[1]]$groups` is TRUE summary[[1]]$groups %>% From 6c7d2c93678fdcf448d721e2f9073e6d69f02c6f Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Fri, 29 Mar 2019 18:44:13 -0400 Subject: [PATCH 55/92] Update help file using roxygen --- man/tab_options.Rd | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/man/tab_options.Rd b/man/tab_options.Rd index 62d054c691..882efc0d28 100644 --- a/man/tab_options.Rd +++ b/man/tab_options.Rd @@ -57,17 +57,17 @@ units of pixels. The \code{\link{px}()} and \code{\link{pct}()} helper functions can also be used to pass in numeric values and obtain values as pixel or percent units.} -\item{table.background.color, heading.background.color, column_labels.background.color, stub_group.background.color, summary_row.background.color, grand_summary_row.background.color}{background colors for the parent element \code{table} and the following -child elements: \code{heading}, \code{columns}, \code{stub_group}, -\code{summary_row}, and \code{field}. A color name or a hexadecimal color -code should be provided.} +\item{table.background.color, heading.background.color, column_labels.background.color, row_group.background.color, summary_row.background.color, grand_summary_row.background.color}{background colors for the parent element \code{table} and the following +child elements: \code{heading}, \code{columns}, \code{row_group}, +\code{summary_row}, and \code{table_body}. A color name or a hexadecimal +color code should be provided.} \item{table.border.top.style, table.border.top.width, table.border.top.color}{the style, width, and color of the table's top border.} \item{heading.border.bottom.style, heading.border.bottom.width, heading.border.bottom.color}{the style, width, and color of the heading's bottom border.} -\item{column_labels.font.weight, stub_group.font.weight}{the font weight of -the \code{columns} and \code{stub_group} text element.} +\item{column_labels.font.weight, row_group.font.weight}{the font weight of +the \code{columns} and \code{row_group} text element.} \item{row_group.border.top.style, row_group.border.top.width, row_group.border.top.color}{the style, width, and color of the row group's top border.} From 7020695786197dac111f1bc32fdfe0c3c044f9f9 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Fri, 29 Mar 2019 20:52:23 -0400 Subject: [PATCH 56/92] Simplify statements --- R/utils_render_common.R | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 5d636bb6b6..e26c8f0ef2 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -406,9 +406,7 @@ create_summary_dfs <- function(summary_list, select_data_df <- cbind( - stub_df[ - seq(nrow(stub_df)), - c("groupname", "rowname")], + stub_df[c("groupname", "rowname")], data_df)[, -2] %>% dplyr::select(groupname, columns) @@ -416,16 +414,13 @@ create_summary_dfs <- function(summary_list, select_data_df <- cbind( - stub_df[ - seq(nrow(stub_df)), - c("groupname", "rowname")], + stub_df[c("groupname", "rowname")], data_df)[, -2] %>% dplyr::mutate(groupname = "::GRAND_SUMMARY") %>% dplyr::select(groupname, columns) } # Get the registered function calls - #agg_funs <- fns %>% lapply(rlang::as_function) agg_funs <- fns %>% lapply(rlang::as_closure) # Get the names if any were provided From f3039e7936a07eb8e07d59e7d3280f141c42dd00 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sun, 21 Apr 2019 00:46:54 -0400 Subject: [PATCH 57/92] Modify roxygen documentation --- R/summary_rows.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index be49374cda..178c3dcf9f 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -11,16 +11,16 @@ #' \code{\link{extract_summary}()} function can be used with a \code{gt_tbl} #' object where summary rows were added via \code{summary_rows()}. #' -#' @param data a table object that is created using the \code{gt()} function. -#' @param groups the groups to consider for generation of groupwise summary +#' @param data A table object that is created using the \code{gt()} function. +#' @param groups The groups to consider for generation of groupwise summary #' rows. By default this is set to \code{NULL}, which results in the formation #' of grand summary rows (a grand summary operates on all table data). #' Providing the names of row groups in \code{c()} will create a groupwise #' summary and generate summary rows for the specified groups. Setting this to #' \code{TRUE} indicates that all available groups will receive groupwise #' summary rows. -#' @param columns the columns for which the summaries should be calculated. -#' @param fns functions used for aggregations. This can include base functions +#' @param columns The columns for which the summaries should be calculated. +#' @param fns Functions used for aggregations. This can include base functions #' like \code{mean}, \code{min}, \code{max}, \code{median}, \code{sd}, or #' \code{sum} or any other user-defined aggregation function. The function(s) #' should be supplied within a \code{list()}. Within that list, we can specify @@ -31,19 +31,19 @@ #' arguments is recommended as the names will serve as summary row labels for #' the corresponding summary rows data (the labels can derived from the #' function names but only when not providing bare function names). -#' @param missing_text the text to be used in place of \code{NA} values in +#' @param missing_text The text to be used in place of \code{NA} values in #' summary cells with no data outputs. -#' @param formatter a formatter function name. These can be any of the +#' @param formatter A formatter function name. These can be any of the #' \code{fmt_*()}functions available in the package (e.g., #' \code{\link{fmt_number}()}, \code{link{fmt_percent}()}, etc.), or a custom #' function using \code{\link{fmt}()}. The default function is #' \code{\link{fmt_number}()} and its options can be accessed through #' \code{...}. -#' @param ... values passed to the \code{formatter} function, where the provided +#' @param ... Values passed to the \code{formatter} function, where the provided #' values are to be in the form of named vectors. For example, when using the #' default \code{formatter} function, \code{\link{fmt_number}()}, options such #' as \code{decimals}, \code{use_seps}, and \code{locale} can be used. -#' @return an object of class \code{gt_tbl}. +#' @return An object of class \code{gt_tbl}. #' @examples #' # Use `sp500` to create a gt table with #' # row groups; create summary rows (`min`, From e98919e011d629cee681f979042b5630791f8a07 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Sun, 21 Apr 2019 00:47:02 -0400 Subject: [PATCH 58/92] Update help file using roxygen --- man/summary_rows.Rd | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/man/summary_rows.Rd b/man/summary_rows.Rd index 38d1a4eb1b..2ce924814c 100644 --- a/man/summary_rows.Rd +++ b/man/summary_rows.Rd @@ -8,9 +8,9 @@ summary_rows(data, groups = NULL, columns = TRUE, fns, missing_text = "---", formatter = fmt_number, ...) } \arguments{ -\item{data}{a table object that is created using the \code{gt()} function.} +\item{data}{A table object that is created using the \code{gt()} function.} -\item{groups}{the groups to consider for generation of groupwise summary +\item{groups}{The groups to consider for generation of groupwise summary rows. By default this is set to \code{NULL}, which results in the formation of grand summary rows (a grand summary operates on all table data). Providing the names of row groups in \code{c()} will create a groupwise @@ -18,9 +18,9 @@ summary and generate summary rows for the specified groups. Setting this to \code{TRUE} indicates that all available groups will receive groupwise summary rows.} -\item{columns}{the columns for which the summaries should be calculated.} +\item{columns}{The columns for which the summaries should be calculated.} -\item{fns}{functions used for aggregations. This can include base functions +\item{fns}{Functions used for aggregations. This can include base functions like \code{mean}, \code{min}, \code{max}, \code{median}, \code{sd}, or \code{sum} or any other user-defined aggregation function. The function(s) should be supplied within a \code{list()}. Within that list, we can specify @@ -32,23 +32,23 @@ arguments is recommended as the names will serve as summary row labels for the corresponding summary rows data (the labels can derived from the function names but only when not providing bare function names).} -\item{missing_text}{the text to be used in place of \code{NA} values in +\item{missing_text}{The text to be used in place of \code{NA} values in summary cells with no data outputs.} -\item{formatter}{a formatter function name. These can be any of the +\item{formatter}{A formatter function name. These can be any of the \code{fmt_*()}functions available in the package (e.g., \code{\link{fmt_number}()}, \code{link{fmt_percent}()}, etc.), or a custom function using \code{\link{fmt}()}. The default function is \code{\link{fmt_number}()} and its options can be accessed through \code{...}.} -\item{...}{values passed to the \code{formatter} function, where the provided +\item{...}{Values passed to the \code{formatter} function, where the provided values are to be in the form of named vectors. For example, when using the default \code{formatter} function, \code{\link{fmt_number}()}, options such as \code{decimals}, \code{use_seps}, and \code{locale} can be used.} } \value{ -an object of class \code{gt_tbl}. +An object of class \code{gt_tbl}. } \description{ Add groupwise summary rows to one or more row groups by using the input data From 8d8c6a3b6bf74d6666246d69982d83d3a684f152 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 10:35:39 -0400 Subject: [PATCH 59/92] Get `labels` from `summary_attrs` --- R/utils_render_common.R | 45 +++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index e26c8f0ef2..0a2ff985b0 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -340,6 +340,7 @@ create_summary_dfs <- function(summary_list, missing_text <- summary_attrs$missing_text formatter <- summary_attrs$formatter formatter_options <- summary_attrs$formatter_options + labels <- summary_attrs$summary_labels # Resolve the `missing_text` if (missing_text == "---") { @@ -423,28 +424,28 @@ create_summary_dfs <- function(summary_list, # Get the registered function calls agg_funs <- fns %>% lapply(rlang::as_closure) - # Get the names if any were provided - labels <- - names(fns) %>% - { - labels <- . - if (length(labels) < 1) { - rep(NA_character_, length(fns)) - } else { - labels - } - } %>% - mapply(., fns, SIMPLIFY = FALSE, FUN = function(label, fn) { - if (is.na(label)) { - derive_summary_label(fn) - } else if(label == "") { - derive_summary_label(fn) - } else { - process_text(label, context = context) - } - }) %>% - unlist() %>% - unname() + # # Get the names if any were provided + # labels <- + # names(fns) %>% + # { + # labels <- . + # if (length(labels) < 1) { + # rep(NA_character_, length(fns)) + # } else { + # labels + # } + # } %>% + # mapply(., fns, SIMPLIFY = FALSE, FUN = function(label, fn) { + # if (is.na(label)) { + # derive_summary_label(fn) + # } else if(label == "") { + # derive_summary_label(fn) + # } else { + # process_text(label, context = context) + # } + # }) %>% + # unlist() %>% + # unname() if (length(labels) != length(unique(labels))) { From af26c4bc24a1acab44141c58cf3ba8f01ae1a35a Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:39:06 -0400 Subject: [PATCH 60/92] Assign identifier string to local variable --- R/utils_render_common.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 0a2ff985b0..2f26528285 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -329,6 +329,7 @@ create_summary_dfs <- function(summary_list, # purposes summary_df_display_list <- list() summary_df_data_list <- list() + grand_summary_col <- "::GRAND_SUMMARY" for (i in seq(summary_list)) { From 80bf52ff806fd18e633f3ac3e52ecca57eabf324 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:39:37 -0400 Subject: [PATCH 61/92] Add the `assert_rowgroups()` function --- R/utils_render_common.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 2f26528285..b301979e6f 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -350,10 +350,7 @@ create_summary_dfs <- function(summary_list, missing_text <- "\u2013" } - # Resolve the groups to consider; if - # `groups` is TRUE then we are to obtain - # summary row data for all groups - if (isTRUE(groups)) { + assert_rowgroups <- function() { if (all(is.na(stub_df$groupname))) { stop("There are no row groups in the gt object:\n", @@ -361,6 +358,7 @@ create_summary_dfs <- function(summary_list, " * Define row groups using `gt()` or `tab_row_group()`", call. = FALSE) } + } groups <- unique(stub_df$groupname) From 1c9dd74b501a70b181334aaa7cabfdc1b66b099b Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:40:23 -0400 Subject: [PATCH 62/92] Add calls the `assert_rowgroups()` fcn --- R/utils_render_common.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index b301979e6f..1c8a868341 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -360,18 +360,18 @@ create_summary_dfs <- function(summary_list, } } + # Resolve the groups to consider; if + # `groups` is TRUE then we are to obtain + # summary row data for all groups + if (isTRUE(groups)) { + + assert_rowgroups() + groups <- unique(stub_df$groupname) } else if (!is.null(groups) && is.character(groups)) { - # TODO: this is repeated from above, make - # this a utility function - if (all(is.na(stub_df$groupname))) { - stop("There are no row groups in the gt object:\n", - " * Use `groups = NULL` to create a grand summary\n", - " * Define row groups using `gt()` or `tab_row_group()`", - call. = FALSE) - } + assert_rowgroups() # Get the names of row groups available # in the gt object From 39c31e4767cf423813cff04c54837502f574a729 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:41:02 -0400 Subject: [PATCH 63/92] Remove statements to obtain row labels --- R/utils_render_common.R | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 1c8a868341..3c380e2e2e 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -423,29 +423,6 @@ create_summary_dfs <- function(summary_list, # Get the registered function calls agg_funs <- fns %>% lapply(rlang::as_closure) - # # Get the names if any were provided - # labels <- - # names(fns) %>% - # { - # labels <- . - # if (length(labels) < 1) { - # rep(NA_character_, length(fns)) - # } else { - # labels - # } - # } %>% - # mapply(., fns, SIMPLIFY = FALSE, FUN = function(label, fn) { - # if (is.na(label)) { - # derive_summary_label(fn) - # } else if(label == "") { - # derive_summary_label(fn) - # } else { - # process_text(label, context = context) - # } - # }) %>% - # unlist() %>% - # unname() - if (length(labels) != length(unique(labels))) { stop("All summary labels must be unique:\n", From 353ce27b12355d2ba5b19393bb8d420e40cf5f32 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:41:24 -0400 Subject: [PATCH 64/92] Replace identifier string with local variable --- R/utils_render_common.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 3c380e2e2e..345d05da82 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -394,7 +394,7 @@ create_summary_dfs <- function(summary_list, # If groups is given as NULL (the default) # then use a special group (`::GRAND_SUMMARY`) - groups <- "::GRAND_SUMMARY" + groups <- grand_summary_col } # Resolve the columns to exclude @@ -402,7 +402,7 @@ create_summary_dfs <- function(summary_list, # Combine `groupname` with the table body data in order to # process data by groups - if (groups[1] != "::GRAND_SUMMARY") { + if (groups[1] != grand_summary_col) { select_data_df <- cbind( @@ -410,13 +410,13 @@ create_summary_dfs <- function(summary_list, data_df)[, -2] %>% dplyr::select(groupname, columns) - } else if (groups == "::GRAND_SUMMARY") { + } else if (identical(groups, grand_summary_col)) { select_data_df <- cbind( stub_df[c("groupname", "rowname")], data_df)[, -2] %>% - dplyr::mutate(groupname = "::GRAND_SUMMARY") %>% + dplyr::mutate(groupname = grand_summary_col) %>% dplyr::select(groupname, columns) } From c216c3110ccc02e7870211038ecee48a4288fe91 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:41:54 -0400 Subject: [PATCH 65/92] Remove `subset()` statements --- R/tab_footnote.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/tab_footnote.R b/R/tab_footnote.R index a874a0eb02..3c85d9f7c2 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -207,7 +207,6 @@ set_footnote.cells_summary <- function(loc, data, footnote) { unique() summary_data <- attr(data, "summary", exact = TRUE) - summary_data <- subset(summary_data, is.null(summary_data$groups)) summary_data_summaries <- vapply( @@ -286,8 +285,6 @@ set_footnote.cells_grand_summary <- function(loc, data, footnote) { summary_data <- attr(data, "summary", exact = TRUE) - grand_summary_data <- subset(summary_data, is.null(summary_data$groups)) - grand_summary_labels <- lapply(grand_summary_data, `[[`, "summary_labels") %>% unlist() %>% From a4b179139cbddd4031ebc3fad4795d0e51022246 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:42:12 -0400 Subject: [PATCH 66/92] Refactor `lapply()` statements --- R/tab_footnote.R | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/R/tab_footnote.R b/R/tab_footnote.R index 3c85d9f7c2..2b2dc513d8 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -224,16 +224,18 @@ set_footnote.cells_summary <- function(loc, data, footnote) { vals = row_groups )] + # Adding footnotes to intersections of group, row, and column; any + # that are missing at render time will be ignored for (group in groups) { summary_labels <- lapply( - seq(summary_data), - function(x) { - if (is.logical(summary_data[[x]]$groups)) { - summary_data[[x]]$summary_labels - } else if (group %in% summary_data[[x]]$groups){ - summary_data[[x]]$summary_labels + summary_data, + function(summary_data_item) { + if (isTRUE(summary_data_item$groups)) { + summary_data_item$summary_labels + } else if (group %in% summary_data_item$groups){ + summary_data_item$summary_labels } } ) %>% @@ -286,7 +288,13 @@ set_footnote.cells_grand_summary <- function(loc, data, footnote) { summary_data <- attr(data, "summary", exact = TRUE) grand_summary_labels <- - lapply(grand_summary_data, `[[`, "summary_labels") %>% + lapply(summary_data, function(summary_data_item) { + if (is.null(summary_data_item$groups)) { + return(summary_data_item$summary_labels) + } + + NULL + }) %>% unlist() %>% unique() From 6cbcb56f4123a095dd24583f21a8f415b061ae1b Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:43:17 -0400 Subject: [PATCH 67/92] Add tests for `cells_summary()` --- tests/testthat/test-location_cells.R | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-location_cells.R b/tests/testthat/test-location_cells.R index d8aedc2717..5a03a0cf79 100644 --- a/tests/testthat/test-location_cells.R +++ b/tests/testthat/test-location_cells.R @@ -238,7 +238,8 @@ test_that("the `cells_summary()` function works correctly", { helper_cells_summary <- cells_summary( groups = "group_a", - columns = c("col_1", "col_2")) + columns = c("col_1", "col_2") + ) # Expect this has the `cells_summary` and `location_cells` classes helper_cells_summary %>% @@ -274,6 +275,20 @@ test_that("the `cells_summary()` function works correctly", { helper_cells_summary[[2]][2] %>% as.character() %>% expect_equal("c(\"col_1\", \"col_2\")") + + # Create a `cells_summary` object with + # columns in `vars()` provided to `columns` + helper_cells_summary <- + cells_summary( + groups = "group_a", + columns = vars(col_1, col_2) + ) + + # Expect the RHS of the second component formula to contain + # the vector provided + helper_cells_summary[[2]][2] %>% + as.character() %>% + expect_equal("vars(col_1, col_2)") }) From 5072ad8654a69bf8cdcbe4033759a10513545332 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 18:43:25 -0400 Subject: [PATCH 68/92] Add tests for `cells_grand_summary()` --- tests/testthat/test-location_cells.R | 46 ++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/tests/testthat/test-location_cells.R b/tests/testthat/test-location_cells.R index 5a03a0cf79..1643a359f6 100644 --- a/tests/testthat/test-location_cells.R +++ b/tests/testthat/test-location_cells.R @@ -291,5 +291,51 @@ test_that("the `cells_summary()` function works correctly", { expect_equal("vars(col_1, col_2)") }) +test_that("the `cells_grand_summary()` function works correctly", { + # Create a `cells_grand_summary` object with names provided to `columns` + helper_cells_grand_summary <- + cells_grand_summary( + columns = c("col_1", "col_2") + ) + + # Expect this has the `cells_summary` and `location_cells` classes + helper_cells_grand_summary %>% + expect_is(c("cells_grand_summary", "location_cells")) + + # Expect the length of the object to be `2` + helper_cells_grand_summary %>% + length() %>% + expect_equal(2) + + # Expect that the object has the names `columns` and `rows` + helper_cells_grand_summary %>% + names() %>% + expect_equal(c("columns", "rows")) + + # Expect the first list component to have the `quosure` and `formula` classes + helper_cells_grand_summary[[1]] %>% expect_is(c("quosure", "formula")) + + # Expect the second list component to have the `quosure` and `formula` classes + helper_cells_grand_summary[[2]] %>% expect_is(c("quosure", "formula")) + + # Expect the RHS of the first component formula to contain + # the vector provided + helper_cells_grand_summary[[1]][2] %>% + as.character() %>% + expect_equal("c(\"col_1\", \"col_2\")") + + # Create a `cells_grand_summary` object with + # columns in `vars()` provided to `columns` + helper_cells_grand_summary <- + cells_grand_summary( + columns = vars(col_1, col_2) + ) + + # Expect the RHS of the first component formula to contain + # the vector provided + helper_cells_grand_summary[[1]][2] %>% + as.character() %>% + expect_equal("vars(col_1, col_2)") +}) From a4e2790cc41ba24f5f61aaec1182345f9a9b03d5 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 22:39:52 -0400 Subject: [PATCH 69/92] Add tests for `tab_footnote()` --- tests/testthat/test-tab_footnote.R | 103 +++++++++++++++++++++++++---- 1 file changed, 90 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-tab_footnote.R b/tests/testthat/test-tab_footnote.R index f399213704..1928e17fc4 100644 --- a/tests/testthat/test-tab_footnote.R +++ b/tests/testthat/test-tab_footnote.R @@ -10,11 +10,14 @@ data <- cols_hide(columns = "vs") %>% tab_row_group( group = "Mercs", - rows = contains("Merc") + rows = contains("Merc"), ) %>% tab_row_group( group = "Mazdas", - rows = contains("Mazda") + rows = contains("Mazda"), + ) %>% + tab_row_group( + others = "Others" ) %>% tab_spanner( label = "gear_carb_cyl", @@ -36,6 +39,12 @@ data <- fns = list( ~mean(., na.rm = TRUE), ~sum(., na.rm = TRUE)) + ) %>% + summary_rows( + columns = vars(hp, wt), + fns = list( + ~mean(., na.rm = TRUE), + ~sum(., na.rm = TRUE)) ) # Create a table from `gtcars` that has footnotes @@ -103,7 +112,9 @@ test_that("the `tab_footnote()` function works correctly", { footnote = "Column labels and stub footnote.", locations = list( cells_column_labels(columns = TRUE), - cells_stub(rows = TRUE))) + cells_stub(rows = TRUE) + ) + ) # Expect that the internal `footnotes_df` data frame will have # its `locname` column entirely populated with `columns_columns` @@ -125,7 +136,8 @@ test_that("the `tab_footnote()` function works correctly", { data %>% tab_footnote( footnote = "Stub cell footnote.", - locations = cells_stub(rows = "Merc 240D")) + locations = cells_stub(rows = "Merc 240D") + ) # Expect that the internal `footnotes_df` data frame will have # a single row @@ -138,14 +150,16 @@ test_that("the `tab_footnote()` function works correctly", { expect_attr_equal( tab, "footnotes_df", c("stub", "5", NA_character_, NA_character_, "8", - "Stub cell footnote.")) + "Stub cell footnote.") + ) # Apply a footnote to the table title tab <- data %>% tab_footnote( footnote = "Title footnote.", - locations = cells_title(groups = "title")) + locations = cells_title(groups = "title") + ) # Expect that the internal `footnotes_df` data frame will have # a single row @@ -158,14 +172,16 @@ test_that("the `tab_footnote()` function works correctly", { expect_attr_equal( tab, "footnotes_df", c("title", "1", NA_character_, NA_character_, NA_character_, - "Title footnote.")) + "Title footnote.") + ) # Apply a footnote to the table subtitle tab <- data %>% tab_footnote( footnote = "Subtitle footnote.", - locations = cells_title(groups = "subtitle")) + locations = cells_title(groups = "subtitle") + ) # Expect that the internal `footnotes_df` data frame will have # a single row @@ -178,7 +194,8 @@ test_that("the `tab_footnote()` function works correctly", { expect_attr_equal( tab, "footnotes_df", c("subtitle", "2", NA_character_, NA_character_, NA_character_, - "Subtitle footnote.")) + "Subtitle footnote.") + ) # Apply a footnote to a single cell in a group summary section tab <- @@ -186,7 +203,8 @@ test_that("the `tab_footnote()` function works correctly", { tab_footnote( footnote = "Summary cell footnote.", locations = cells_summary( - groups = "Mercs", columns = "hp", rows = 2)) + groups = "Mercs", columns = "hp", rows = 2) + ) # Expect that the internal `footnotes_df` data frame will have # a single row @@ -199,7 +217,66 @@ test_that("the `tab_footnote()` function works correctly", { expect_attr_equal( tab, "footnotes_df", c("summary_cells", "5", "Mercs", "hp", "2", - "Summary cell footnote.")) + "Summary cell footnote.") + ) + + # Apply a footnote to a single cell in a grand + # summary section + tab <- + data %>% + tab_footnote( + footnote = "Grand summary cell footnote.", + locations = cells_grand_summary( + columns = vars(wt), rows = starts_with("s") + ) + ) + + # Expect that the internal `footnotes_df` data frame + # will have a single row + attr(tab, "footnotes_df", exact = TRUE) %>% + nrow() %>% + expect_equal(1) + + # Expect certain values for each of the columns in the + # single-row `footnotes_df` data frame + expect_attr_equal( + tab, "footnotes_df", + c("grand_summary_cells", "6", NA, "wt", "2", + "Grand summary cell footnote.") + ) + + # Apply a footnote to a single cell in a group + # summary section, and, to a single cell in a grand + # summary section + tab <- + data %>% + tab_footnote( + footnote = "Summary cell footnote.", + locations = cells_summary( + groups = "Mercs", columns = "hp", rows = 2) + ) %>% + tab_footnote( + footnote = "Grand summary cell footnote.", + locations = cells_grand_summary( + columns = vars(wt), rows = starts_with("s") + ) + ) + + # Expect that the internal `footnotes_df` data frame + # will have two rows + attr(tab, "footnotes_df", exact = TRUE) %>% + nrow() %>% + expect_equal(2) + + # Expect certain values for each of the columns in the + # double-row `footnotes_df` data frame + expect_attr_equal( + tab, "footnotes_df", + c("summary_cells", "grand_summary_cells", + "5", "6", "Mercs", NA, "hp", "wt", "2", "2", + "Summary cell footnote.", + "Grand summary cell footnote.") + ) # Apply a footnote to the `Mazdas` stub group cell tab <- @@ -208,8 +285,8 @@ test_that("the `tab_footnote()` function works correctly", { footnote = "Group cell footnote.", locations = cells_group(groups = "Mazdas")) - # Expect that the internal `footnotes_df` data frame will have - # a single row + # Expect that the internal `footnotes_df` data frame + # will have a single row attr(tab, "footnotes_df", exact = TRUE) %>% nrow() %>% expect_equal(1) From 7b0659b74e97688b08404a0e3014264b9a581496 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 22:44:07 -0400 Subject: [PATCH 70/92] Use the internal `is_false()` fcn --- R/summary_rows.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 178c3dcf9f..32ed3e1dfc 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -97,7 +97,7 @@ summary_rows <- function(data, # as `NULL` signifies a grand summary, `TRUE` # is used for groupwise summaries across all # groups - if (!is.null(groups) && is.logical(groups) && groups == FALSE) { + if (!is_false(groups)) { return(data) } From a7535f1074fcf616d85bba1a25b95ad887abce0f Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Tue, 23 Apr 2019 22:54:37 -0400 Subject: [PATCH 71/92] Modify the `is_false()` call --- R/summary_rows.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 32ed3e1dfc..961590e8e3 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -97,7 +97,7 @@ summary_rows <- function(data, # as `NULL` signifies a grand summary, `TRUE` # is used for groupwise summaries across all # groups - if (!is_false(groups)) { + if (is_false(groups)) { return(data) } From 57d6db11999a4a248782c7fdfa5f0bee19d23a1b Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 01:17:48 -0400 Subject: [PATCH 72/92] Add several testthat tests --- tests/testthat/test-summary_rows.R | 219 +++++++++++++++++++++++++++++ tests/testthat/test-tab_footnote.R | 40 ++++++ 2 files changed, 259 insertions(+) diff --git a/tests/testthat/test-summary_rows.R b/tests/testthat/test-summary_rows.R index 574cd149e2..453c8d19cd 100644 --- a/tests/testthat/test-summary_rows.R +++ b/tests/testthat/test-summary_rows.R @@ -784,3 +784,222 @@ test_that("the `summary_rows()` can make grand summaries", { length() %>% expect_equal(0) }) + +test_that("`groups = FALSE` returns data unchanged", { + + # Expect that using `groups = FALSE` with + # `summary_rows()` creates no summary rows + expect_equal( + tbl %>% as_raw_html(), + tbl %>% + summary_rows( + groups = FALSE, + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE))) %>% + as_raw_html() + ) +}) + +test_that("summary rows can be created when there is no stub", { + + # Create a table based on `sp500`, with + # four columns of values + tbl_2 <- + sp500 %>% + dplyr::filter( + date >= "2015-01-05" & + date <="2015-01-09" + ) %>% + dplyr::arrange(date) %>% + dplyr::select(-adj_close, -volume) %>% + gt() + + # Create a gt table with a grand summary; + # the table doesn't have a stub (and there + # are no row groups) + gt_tbl <- + tbl_2 %>% + summary_rows( + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE)) + ) + + # Extract `output_df` in the HTML context and + # expect that the `rowname` column is entirely + # filled with empty strings + expect_equal( + (gt_tbl %>% render_formats_test("html"))[["rowname"]], + rep("", 5) + ) + + # Expect that the grand summary row labels are + # available in the rendered output table + expect_match( + gt_tbl %>% + as_raw_html(inline_css = FALSE), + "average") + + expect_match( + gt_tbl %>% + as_raw_html(inline_css = FALSE), + "total") + + expect_match( + gt_tbl %>% + as_raw_html(inline_css = FALSE), + "std dev") +}) + +test_that("extracting a summary from a gt table is possible", { + + # Create a table with summary rows for + # the `W02` and `W03` groups; the 3 summary + # rows represent the mean, sum, and standard + # deviation of all numeric columns; extract + # the internal summary with `extract_summary()` + gt_tbl_summary_groupwise <- + tbl %>% + summary_rows( + groups = c("W02", "W03"), + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE))) %>% + extract_summary() + + # Expect that the summary object is a list + expect_is(gt_tbl_summary_groupwise, "list") + + # Expect that the length of the list is `2` + expect_equal(length(gt_tbl_summary_groupwise), 2) + + # Expect specific names for the list components + expect_equal( + names(gt_tbl_summary_groupwise), + c("W02", "W03") + ) + + # Expect that each component of the list inherits + # from `tbl_df` + expect_is(gt_tbl_summary_groupwise[[1]], "tbl_df") + expect_is(gt_tbl_summary_groupwise[[2]], "tbl_df") + + # Expect specific column names for each of the + # tibbles in `gt_tbl_summary_groupwise` + expect_equal( + names(gt_tbl_summary_groupwise[[1]]), + c("groupname", "rowname", "open", "high", "low", "close") + ) + + expect_equal( + names(gt_tbl_summary_groupwise[[2]]), + c("groupname", "rowname", "open", "high", "low", "close") + ) + + # Expect specific values in each of the tibbles + expect_equal( + gt_tbl_summary_groupwise[[1]]$open, + c(2035.23998, 10176.19990, 23.65756), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[1]]$high, + c(2048.56198, 10242.80990, 17.47612), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[1]]$low, + c(2016.8540, 10084.2699, 18.5372), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[1]]$close, + c(2031.2080, 10156.0400, 22.9171), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[2]]$open, + c(2020.42200, 10102.11000, 20.17218), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[2]]$high, + c(2033.28798, 10166.43990, 18.33064), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[2]]$low, + c(1999.77198, 9998.85990, 15.20847), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_groupwise[[2]]$close, + c(2014.9300, 10074.6500, 13.8957), tolerance = .002 + ) + + # Create a table with a grand summary; the 3 + # summary rows represent the mean, sum, and + # standard deviation of all numeric columns; + # extract the internal summary with `extract_summary()` + gt_tbl_summary_grand <- + tbl %>% + summary_rows( + columns = vars(open, high, low, close), + fns = list( + average = ~mean(., na.rm = TRUE), + total = ~sum(., na.rm = TRUE), + `std dev` = ~sd(., na.rm = TRUE))) %>% + extract_summary() + + # Expect that the summary object is a list + expect_is(gt_tbl_summary_grand, "list") + + # Expect that the length of the list is `1` + expect_equal(length(gt_tbl_summary_grand), 1) + + # Expect a specific name for the one list component + expect_equal(names(gt_tbl_summary_grand), "::GRAND_SUMMARY") + + # Expect that the single component of the list inherits + # from `tbl_df` + expect_is(gt_tbl_summary_grand[[1]], "tbl_df") + + # Expect specific column names for the + # tibble in `gt_tbl_summary_grand` + expect_equal( + names(gt_tbl_summary_grand[[1]]), + c("groupname", "rowname", "open", "high", "low", "close") + ) + + # Expect specific values in the tibble + expect_equal( + gt_tbl_summary_grand[[1]]$open, + c(2027.83099, 20278.30990, 22.14929), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_grand[[1]]$high, + c(2040.92498, 20409.24980, 18.70516), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_grand[[1]]$low, + c(2008.31298, 20083.12980, 18.34602), tolerance = .002 + ) + + expect_equal( + gt_tbl_summary_grand[[1]]$close, + c(2023.06900, 20230.69000, 19.82022), tolerance = .002 + ) + + # Expect an error with `extract_summary()` if there + # are no summaries (i.e., `summary_rows()` wasn't used) + expect_error(tbl %>% extract_summary()) +}) diff --git a/tests/testthat/test-tab_footnote.R b/tests/testthat/test-tab_footnote.R index 1928e17fc4..3210d0ed30 100644 --- a/tests/testthat/test-tab_footnote.R +++ b/tests/testthat/test-tab_footnote.R @@ -220,6 +220,26 @@ test_that("the `tab_footnote()` function works correctly", { "Summary cell footnote.") ) + # Expect an error if columns couldn't be resolved + expect_error( + data %>% + tab_footnote( + footnote = "Summary cell footnote.", + locations = cells_summary( + groups = "Mercs", columns = starts_with("x"), rows = 2) + ) + ) + + # Expect an error if rows couldn't be resolved + expect_error( + data %>% + tab_footnote( + footnote = "Summary cell footnote.", + locations = cells_summary( + groups = "Mercs", columns = starts_with("m"), rows = starts_with("x")) + ) + ) + # Apply a footnote to a single cell in a grand # summary section tab <- @@ -245,6 +265,26 @@ test_that("the `tab_footnote()` function works correctly", { "Grand summary cell footnote.") ) + # Expect an error if columns couldn't be resolved + expect_error( + data %>% + tab_footnote( + footnote = "Grand summary cell footnote.", + locations = cells_grand_summary( + columns = starts_with("x"), rows = 2) + ) + ) + + # Expect an error if rows couldn't be resolved + expect_error( + data %>% + tab_footnote( + footnote = "Grand summary cell footnote.", + locations = cells_grand_summary( + columns = starts_with("m"), rows = starts_with("x")) + ) + ) + # Apply a footnote to a single cell in a group # summary section, and, to a single cell in a grand # summary section From e3a409b39dff3ef3b2f0e4ae5b10fbcc5e8bd7e8 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 10:08:35 -0400 Subject: [PATCH 73/92] Add tests for the `tab_style()` fcn --- tests/testthat/test-tab_style.R | 72 +++++++++++++++++++++++++++++++++ 1 file changed, 72 insertions(+) diff --git a/tests/testthat/test-tab_style.R b/tests/testthat/test-tab_style.R index 8af6951d61..62ea98b3db 100644 --- a/tests/testthat/test-tab_style.R +++ b/tests/testthat/test-tab_style.R @@ -15,6 +15,9 @@ data <- group = "Mazdas", rows = contains("Mazda") ) %>% + tab_row_group( + others = "Others" + ) %>% tab_spanner( label = "gear_carb_cyl", columns = vars(gear, carb, cyl) @@ -35,6 +38,12 @@ data <- fns = list( ~mean(., na.rm = TRUE), ~sum(., na.rm = TRUE)) + ) %>% + summary_rows( + columns = vars(hp, wt), + fns = list( + ~mean(., na.rm = TRUE), + ~sum(., na.rm = TRUE)) ) # Function to skip tests if Suggested packages not available on system @@ -176,6 +185,69 @@ test_that("a gt table can store the correct style statements", { c("summary_cells", "5", "Mercs", "hp", "2", "background-color:green;color:white;")) + # Expect an error if columns couldn't be resolved + expect_error( + data %>% + tab_style( + style = cells_styles(bkgd_color = "green", text_color = "white"), + locations = cells_summary( + groups = "Mercs", columns = starts_with("x"), rows = 2) + ) + ) + + # Expect an error if rows couldn't be resolved + expect_error( + data %>% + tab_style( + style = cells_styles(bkgd_color = "green", text_color = "white"), + locations = cells_summary( + groups = "Mercs", columns = starts_with("m"), rows = starts_with("x")) + ) + ) + + # Apply a red background with white text to a single cell in + # the grand summary section + tbl_html <- + data %>% + tab_style( + style = cells_styles(bkgd_color = "red", text_color = "white"), + locations = cells_grand_summary( + columns = "hp", rows = vars(sum)) + ) + + # Expect that the internal `styles_df` data frame will have + # a single row + attr(tbl_html, "styles_df", exact = TRUE) %>% + nrow() %>% + expect_equal(1) + + # Expect certain values for each of the columns in the + # single-row `styles_df` data frame + expect_attr_equal( + tbl_html, "styles_df", + c("grand_summary_cells", "6", NA, "hp", "2", + "background-color:red;color:white;")) + + # Expect an error if columns couldn't be resolved + expect_error( + data %>% + tab_style( + style = cells_styles(bkgd_color = "red", text_color = "white"), + locations = cells_grand_summary( + columns = starts_with("x"), rows = 2) + ) + ) + + # Expect an error if rows couldn't be resolved + expect_error( + data %>% + tab_style( + style = cells_styles(bkgd_color = "red", text_color = "white"), + locations = cells_grand_summary( + columns = starts_with("m"), rows = starts_with("x")) + ) + ) + # Apply a `yellow` background to the `Mazdas` stub group cell tbl_html <- data %>% From 9088b8428533ae7799104a9a3f9989fead331559 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 10:35:33 -0400 Subject: [PATCH 74/92] Refactor some `set_style.*()` fcns --- R/tab_style.R | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/R/tab_style.R b/R/tab_style.R index 9062b9dcd6..e2c71512d0 100644 --- a/R/tab_style.R +++ b/R/tab_style.R @@ -240,7 +240,6 @@ set_style.cells_summary <- function(loc, data, style) { unique() summary_data <- attr(data, "summary", exact = TRUE) - summary_data <- subset(summary_data, is.null(summary_data$groups)) summary_data_summaries <- vapply( @@ -258,16 +257,18 @@ set_style.cells_summary <- function(loc, data, style) { vals = row_groups )] + # Adding styles to intersections of group, row, and column; any + # that are missing at render time will be ignored for (group in groups) { summary_labels <- lapply( - seq(summary_data), - function(x) { - if (is.logical(summary_data[[x]]$groups)) { - summary_data[[x]]$summary_labels - } else if (group %in% summary_data[[x]]$groups){ - summary_data[[x]]$summary_labels + summary_data, + function(summary_data_item) { + if (isTRUE(summary_data_item$groups)) { + summary_data_item$summary_labels + } else if (group %in% summary_data_item$groups){ + summary_data_item$summary_labels } } ) %>% @@ -319,10 +320,14 @@ set_style.cells_grand_summary <- function(loc, data, style) { summary_data <- attr(data, "summary", exact = TRUE) - grand_summary_data <- subset(summary_data, is.null(summary_data$groups)) - grand_summary_labels <- - lapply(grand_summary_data, `[[`, "summary_labels") %>% + lapply(summary_data, function(summary_data_item) { + if (is.null(summary_data_item$groups)) { + return(summary_data_item$summary_labels) + } + + NULL + }) %>% unlist() %>% unique() From d968fdae60001e7f985648cef80bce0b24e7f2ab Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 10:36:24 -0400 Subject: [PATCH 75/92] Add tests for the `tab_options()` fcn --- tests/testthat/test-tab_options.R | 40 +++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/tests/testthat/test-tab_options.R b/tests/testthat/test-tab_options.R index 089d5735a7..92674cf150 100644 --- a/tests/testthat/test-tab_options.R +++ b/tests/testthat/test-tab_options.R @@ -569,6 +569,46 @@ test_that("the internal `opts_df` table can be correctly modified", { dplyr::filter(parameter == "summary_row_text_transform") %>% dplyr::pull(value)) %>% expect_equal(c("inherit", "lowercase")) + # Modify the `grand_summary_row.background.color` + tbl_html <- data %>% tab_options(grand_summary_row.background.color = "pink") + + # Compare before and after values + c(opts_df_1 %>% + dplyr::filter(parameter == "grand_summary_row_background_color") %>% dplyr::pull(value), + attr(tbl_html, "opts_df", exact = TRUE) %>% + dplyr::filter(parameter == "grand_summary_row_background_color") %>% dplyr::pull(value)) %>% + expect_equal(c(NA_character_, "pink")) + + # Modify the `grand_summary_row.padding` + tbl_html <- data %>% tab_options(grand_summary_row.padding = px(4)) + + # Compare before and after values + c(opts_df_1 %>% + dplyr::filter(parameter == "grand_summary_row_padding") %>% dplyr::pull(value), + attr(tbl_html, "opts_df", exact = TRUE) %>% + dplyr::filter(parameter == "grand_summary_row_padding") %>% dplyr::pull(value)) %>% + expect_equal(c("8px", "4px")) + + # Modify the `grand_summary_row.padding` option using just a numeric value + tbl_html <- data %>% tab_options(grand_summary_row.padding = 4) + + # Compare before and after values + c(opts_df_1 %>% + dplyr::filter(parameter == "grand_summary_row_padding") %>% dplyr::pull(value), + attr(tbl_html, "opts_df", exact = TRUE) %>% + dplyr::filter(parameter == "grand_summary_row_padding") %>% dplyr::pull(value)) %>% + expect_equal(c("8px", "4px")) + + # Modify the `grand_summary_row.text_transform` + tbl_html <- data %>% tab_options(grand_summary_row.text_transform = "lowercase") + + # Compare before and after values + c(opts_df_1 %>% + dplyr::filter(parameter == "grand_summary_row_text_transform") %>% dplyr::pull(value), + attr(tbl_html, "opts_df", exact = TRUE) %>% + dplyr::filter(parameter == "grand_summary_row_text_transform") %>% dplyr::pull(value)) %>% + expect_equal(c("inherit", "lowercase")) + # Modify the `footnote.font.size` tbl_html <- data %>% tab_options(footnote.font.size = px(12)) From 08ea4d9339c1e4cdb88709bc12a262527c105894 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 13:21:56 -0400 Subject: [PATCH 76/92] Add several testthat tests --- tests/testthat/test-tab_footnote.R | 161 +++++++++++++++++++++++++++++ tests/testthat/test-table_parts.R | 16 +++ 2 files changed, 177 insertions(+) diff --git a/tests/testthat/test-tab_footnote.R b/tests/testthat/test-tab_footnote.R index 3210d0ed30..29de64fce2 100644 --- a/tests/testthat/test-tab_footnote.R +++ b/tests/testthat/test-tab_footnote.R @@ -76,6 +76,50 @@ data_2 <- tab_spanner(label = "make and model", columns = vars(mfr, model)) %>% tab_spanner(label = "specs and pricing", columns = vars(drivetrain, msrp)) + +# Create a table from `gtcars` that has footnotes +# in group summary and grand summary cells +data_3 <- + gtcars %>% + dplyr::filter(ctry_origin == "Germany") %>% + dplyr::group_by(mfr) %>% + dplyr::top_n(3, msrp) %>% + dplyr::ungroup() %>% + dplyr::select(mfr, model, drivetrain, msrp) %>% + gt(rowname_col = "model", groupname_col = "mfr") %>% + summary_rows( + groups = c("BMW", "Audi"), + columns = vars(msrp), + fns = list( + ~mean(., na.rm = TRUE), + ~min(., na.rm = TRUE)) + ) %>% + summary_rows( + columns = vars(msrp), + fns = list( + ~min(., na.rm = TRUE), + ~max(., na.rm = TRUE)) + ) %>% + tab_footnote( + footnote = "Average price for BMW and Audi.", + locations = cells_summary( + groups = c("BMW", "Audi"), + columns = vars(msrp), + rows = starts_with("me")) + ) %>% + tab_footnote( + footnote = "Maximum price across all cars.", + locations = cells_grand_summary( + columns = vars(msrp), + rows = starts_with("ma")) + ) %>% + tab_footnote( + footnote = "Minimum price across all cars.", + locations = cells_grand_summary( + columns = vars(msrp), + rows = starts_with("mi")) + ) + # Function to skip tests if Suggested packages not available on system check_suggests <- function() { skip_if_not_installed("rvest") @@ -509,5 +553,122 @@ test_that("the `tab_footnote()` function works correctly", { tbl_html %>% selection_text(selection = "[class='gt_footnote_glyph']") %>% expect_equal(rep(as.character(1:4), 2)) +}) + +test_that("the `apply_footnotes_to_output()` function works correctly", { + + # Build the `data_3` object (using the `html` context) + # and obtain the `built_data` list object + built_data <- build_data(data_3, context = "html") + + # Extract `footnotes_resolved` and `list_of_summaries` + footnotes_resolved <- built_data$footnotes_resolved + list_of_summaries <- built_data$list_of_summaries + + # Expect that the `footnotes_resolved` object inherits + # from `tbl_df` + expect_is(footnotes_resolved, "tbl_df") + + # Expect that there are specific column names in + # this tibble + expect_equal( + colnames(footnotes_resolved), + c("locname", "locnum", "grpname", "colname", "rownum", + "text", "colnum", "fs_id") + ) + + # Expect that there are 4 rows in this tibble + expect_equal(nrow(footnotes_resolved), 4) + + # Expect specific values to be in `footnotes_resolved` + expect_equal( + footnotes_resolved$locname, + c("summary_cells", "summary_cells", + "grand_summary_cells", "grand_summary_cells") + ) + expect_equal(footnotes_resolved$locnum, c(5, 5, 6, 6)) + expect_equal(footnotes_resolved$grpname, c("BMW", "Audi", NA, NA)) + expect_equal(footnotes_resolved$colname, rep("msrp", 4)) + expect_equal(footnotes_resolved$rownum, c(3.01, 6.01, 1.00, 2.00)) + expect_equal( + footnotes_resolved$text, + c("Average price for BMW and Audi.", "Average price for BMW and Audi.", + "Minimum price across all cars.", "Maximum price across all cars.") + ) + expect_equal(footnotes_resolved$colnum, rep(2, 4)) + expect_equal(footnotes_resolved$fs_id, c("1", "1", "2", "3")) + + # Expect that the list of summaries has length `2` + expect_equal(length(list_of_summaries), 2) + + # Expect specific names in the `list_of_summaries` list + expect_equal( + names(list_of_summaries), + c("summary_df_data_list", "summary_df_display_list") + ) + + # Expect three tibbles in the `summary_df_data_list` component + expect_equal(length(list_of_summaries$summary_df_data_list), 3) + + # Expect three tibbles in the `summary_df_display_list` component + expect_equal(length(list_of_summaries$summary_df_display_list), 3) + + # Expect specific names for the subcomponents of the + # `summary_df_data_list` and `summary_df_data_list` + # parent components + expect_equal( + names(list_of_summaries$summary_df_data_list), + c("BMW", "Audi", "::GRAND_SUMMARY") + ) + expect_equal( + names(list_of_summaries$summary_df_display_list), + c("::GRAND_SUMMARY", "Audi", "BMW") + ) + + # Expect formatted cell values with no HTML footnote markup + expect_equal( + list_of_summaries$summary_df_display_list$`::GRAND_SUMMARY`$msrp, + c("56,000.00", "140,700.00") + ) + + expect_equal( + list_of_summaries$summary_df_display_list$Audi$msrp, + c("113,233.33", "108,900.00") + ) + + expect_equal( + list_of_summaries$summary_df_display_list$BMW$msrp, + c("116,066.67", "94,100.00") + ) + + # Use the `apply_footnotes_to_summary()` function to modify + # the cell values in the `list_of_summaries$summary_df_display_list` + # subcomponent of `list_of_summaries` + applied_footnotes <- + apply_footnotes_to_summary(list_of_summaries, footnotes_resolved) + + # Expect no change in the `summary_df_data_list` subcomponent + # as a result of the transformation + expect_equivalent( + list_of_summaries$summary_df_data_list, + applied_footnotes$summary_df_data_list + ) + + # Expect formatted cell values with HTML footnote markup + expect_equal( + applied_footnotes$summary_df_display_list$`::GRAND_SUMMARY`$msrp, + c("56,000.002", + "140,700.003") + ) + + expect_equal( + applied_footnotes$summary_df_display_list$Audi$msrp, + c("113,233.331", "108,900.00") + ) + + expect_equal( + applied_footnotes$summary_df_display_list$BMW$msrp, + c("116,066.671", "94,100.00") + ) }) diff --git a/tests/testthat/test-table_parts.R b/tests/testthat/test-table_parts.R index ac05505871..74b4a7a4a7 100644 --- a/tests/testthat/test-table_parts.R +++ b/tests/testthat/test-table_parts.R @@ -286,6 +286,12 @@ test_that("a gt table contains custom styles at the correct locations", { ~mean(., na.rm = TRUE), ~sum(., na.rm = TRUE)) ) %>% + summary_rows( + columns = vars(hp, wt, qsec), + fns = list( + ~mean(., na.rm = TRUE), + ~sum(., na.rm = TRUE)) + ) %>% tab_style( style = cells_styles(bkgd_color = "lightgray"), locations = list( @@ -309,6 +315,10 @@ test_that("a gt table contains custom styles at the correct locations", { locations = cells_summary( groups = "Mercs", columns = "hp", rows = 2) ) %>% + tab_style( + style = cells_styles(bkgd_color = "purple", text_color = "white"), + locations = cells_grand_summary(columns = "hp", rows = 2) + ) %>% tab_style( style = cells_styles(bkgd_color = "lightgreen"), locations = cells_column_labels(groups = "gear_carb_cyl") @@ -354,6 +364,12 @@ test_that("a gt table contains custom styles at the correct locations", { rvest::html_text("[class='gt_row gt_summary_row gt_center']") %>% expect_equal("943.00") + # Expect that the grand summary cell (`sum`/`hp`) is styled + tbl_html %>% + rvest::html_nodes("[style='background-color:purple;color:white;']") %>% + rvest::html_text("[class='gt_row gt_grand_summary_row gt_center']") %>% + expect_equal("4,694.00") + # Expect that some column labels (e.g., `disp`, `wt`, etc.) are # styled with a lightgrey background (tbl_html %>% From 699661478be8e3944917362b3874d5a13120c0c5 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 14:30:30 -0400 Subject: [PATCH 77/92] Refactor the adding of summary location rows --- R/summary_rows.R | 146 +++++++++++++++++++++++++++++++++++++++++++++++ R/tab_footnote.R | 144 ++++------------------------------------------ R/tab_style.R | 144 ++++------------------------------------------ 3 files changed, 170 insertions(+), 264 deletions(-) diff --git a/R/summary_rows.R b/R/summary_rows.R index 961590e8e3..db345bc761 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -149,3 +149,149 @@ summary_rows <- function(data, data } + +add_summary_location_row <- function(loc, + data, + text, + df_type = "styles_df") { + + stub_df <- attr(data, "stub_df", exact = TRUE) + + row_groups <- + stub_df[, "groupname"] %>% + unique() + + summary_data <- attr(data, "summary", exact = TRUE) + + summary_data_summaries <- + vapply( + seq(summary_data), + function(x) !is.null(summary_data[[x]]$groups), + logical(1) + ) + + summary_data <- summary_data[summary_data_summaries] + + groups <- + row_groups[resolve_data_vals_idx( + var_expr = !!loc$groups, + data = NULL, + vals = row_groups + )] + + # Adding styles to intersections of group, row, and column; any + # that are missing at render time will be ignored + for (group in groups) { + + summary_labels <- + lapply( + summary_data, + function(summary_data_item) { + if (isTRUE(summary_data_item$groups)) { + summary_data_item$summary_labels + } else if (group %in% summary_data_item$groups){ + summary_data_item$summary_labels + } + } + ) %>% + unlist() %>% + unique() + + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data = NULL, + vals = summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } + + attr(data, df_type) <- + add_location_row( + data, + df_type = df_type, + locname = "summary_cells", + locnum = 5, + grpname = group, + colname = columns, + rownum = rows, + text = text + ) + } + + data +} + +add_grand_summary_location_row <- function(loc, + data, + text, + df_type = "styles_df") { + + summary_data <- attr(data, "summary", exact = TRUE) + + grand_summary_labels <- + lapply(summary_data, function(summary_data_item) { + if (is.null(summary_data_item$groups)) { + return(summary_data_item$summary_labels) + } + + NULL + }) %>% + unlist() %>% + unique() + + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data = NULL, + vals = grand_summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } + + attr(data, df_type) <- + add_location_row( + data, + df_type = df_type, + locname = "grand_summary_cells", + locnum = 6, + grpname = NA_character_, + colname = columns, + rownum = rows, + text = text + ) + + data +} diff --git a/R/tab_footnote.R b/R/tab_footnote.R index 2b2dc513d8..eaee3b47dd 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -200,142 +200,22 @@ set_footnote.cells_title <- function(loc, data, footnote) { set_footnote.cells_summary <- function(loc, data, footnote) { - stub_df <- attr(data, "stub_df", exact = TRUE) - - row_groups <- - stub_df[, "groupname"] %>% - unique() - - summary_data <- attr(data, "summary", exact = TRUE) - - summary_data_summaries <- - vapply( - seq(summary_data), - function(x) !is.null(summary_data[[x]]$groups), - logical(1) - ) - - summary_data <- summary_data[summary_data_summaries] - - groups <- - row_groups[resolve_data_vals_idx( - var_expr = !!loc$groups, - data = NULL, - vals = row_groups - )] - - # Adding footnotes to intersections of group, row, and column; any - # that are missing at render time will be ignored - for (group in groups) { - - summary_labels <- - lapply( - summary_data, - function(summary_data_item) { - if (isTRUE(summary_data_item$groups)) { - summary_data_item$summary_labels - } else if (group %in% summary_data_item$groups){ - summary_data_item$summary_labels - } - } - ) %>% - unlist() %>% - unique() - - columns <- - resolve_vars( - var_expr = !!loc$columns, - data = data - ) - - if (length(columns) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `columns`", - call. = FALSE) - } - - rows <- - resolve_data_vals_idx( - var_expr = !!loc$rows, - data = NULL, - vals = summary_labels - ) - - if (length(rows) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `rows`", - call. = FALSE) - } - - attr(data, "footnotes_df") <- - add_location_row( - data, - df_type = "footnotes_df", - locname = "summary_cells", - locnum = 5, - grpname = group, - colname = columns, - rownum = rows, - text = footnote - ) - } - - data + add_summary_location_row( + loc = loc, + data = data, + text = footnote, + df_type = "footnotes_df" + ) } set_footnote.cells_grand_summary <- function(loc, data, footnote) { - summary_data <- attr(data, "summary", exact = TRUE) - - grand_summary_labels <- - lapply(summary_data, function(summary_data_item) { - if (is.null(summary_data_item$groups)) { - return(summary_data_item$summary_labels) - } - - NULL - }) %>% - unlist() %>% - unique() - - columns <- - resolve_vars( - var_expr = !!loc$columns, - data = data - ) - - if (length(columns) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `columns`", - call. = FALSE) - } - - rows <- - resolve_data_vals_idx( - var_expr = !!loc$rows, - data = NULL, - vals = grand_summary_labels - ) - - if (length(rows) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `rows`", - call. = FALSE) - } - - attr(data, "footnotes_df") <- - add_location_row( - data, - df_type = "footnotes_df", - locname = "grand_summary_cells", - locnum = 6, - grpname = NA_character_, - colname = columns, - rownum = rows, - text = footnote - ) - - data + add_grand_summary_location_row( + loc = loc, + data = data, + text = footnote, + df_type = "footnotes_df" + ) } #' @importFrom dplyr bind_rows tibble distinct diff --git a/R/tab_style.R b/R/tab_style.R index e2c71512d0..f73ecea785 100644 --- a/R/tab_style.R +++ b/R/tab_style.R @@ -233,140 +233,20 @@ set_style.cells_title <- function(loc, data, style) { set_style.cells_summary <- function(loc, data, style) { - stub_df <- attr(data, "stub_df", exact = TRUE) - - row_groups <- - stub_df[, "groupname"] %>% - unique() - - summary_data <- attr(data, "summary", exact = TRUE) - - summary_data_summaries <- - vapply( - seq(summary_data), - function(x) !is.null(summary_data[[x]]$groups), - logical(1) - ) - - summary_data <- summary_data[summary_data_summaries] - - groups <- - row_groups[resolve_data_vals_idx( - var_expr = !!loc$groups, - data = NULL, - vals = row_groups - )] - - # Adding styles to intersections of group, row, and column; any - # that are missing at render time will be ignored - for (group in groups) { - - summary_labels <- - lapply( - summary_data, - function(summary_data_item) { - if (isTRUE(summary_data_item$groups)) { - summary_data_item$summary_labels - } else if (group %in% summary_data_item$groups){ - summary_data_item$summary_labels - } - } - ) %>% - unlist() %>% - unique() - - columns <- - resolve_vars( - var_expr = !!loc$columns, - data = data - ) - - if (length(columns) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `columns`", - call. = FALSE) - } - - rows <- - resolve_data_vals_idx( - var_expr = !!loc$rows, - data = NULL, - vals = summary_labels - ) - - if (length(rows) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `rows`", - call. = FALSE) - } - - attr(data, "styles_df") <- - add_location_row( - data, - df_type = "styles_df", - locname = "summary_cells", - locnum = 5, - grpname = group, - colname = columns, - rownum = rows, - text = style - ) - } - - data + add_summary_location_row( + loc = loc, + data = data, + text = style, + df_type = "styles_df" + ) } set_style.cells_grand_summary <- function(loc, data, style) { - summary_data <- attr(data, "summary", exact = TRUE) - - grand_summary_labels <- - lapply(summary_data, function(summary_data_item) { - if (is.null(summary_data_item$groups)) { - return(summary_data_item$summary_labels) - } - - NULL - }) %>% - unlist() %>% - unique() - - columns <- - resolve_vars( - var_expr = !!loc$columns, - data = data - ) - - if (length(columns) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `columns`", - call. = FALSE) - } - - rows <- - resolve_data_vals_idx( - var_expr = !!loc$rows, - data = NULL, - vals = grand_summary_labels - ) - - if (length(rows) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `rows`", - call. = FALSE) - } - - attr(data, "styles_df") <- - add_location_row( - data, - df_type = "styles_df", - locname = "grand_summary_cells", - locnum = 6, - grpname = NA_character_, - colname = columns, - rownum = rows, - text = style - ) - - data + add_grand_summary_location_row( + loc = loc, + data = data, + text = style, + df_type = "styles_df" + ) } From 1b3a8a11ef73fc21f30997827c51aaf1ae3e8915 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:44:17 -0400 Subject: [PATCH 78/92] Add the `tidy_sub()` util function --- R/utils.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/utils.R b/R/utils.R index db4ce37e92..74c7178599 100644 --- a/R/utils.R +++ b/R/utils.R @@ -829,6 +829,10 @@ tidy_gsub <- function(x, pattern, replacement, fixed = FALSE) { gsub(pattern, replacement, x, fixed = fixed) } +tidy_sub <- function(x, pattern, replacement, fixed = FALSE) { + + sub(pattern, replacement, x, fixed = fixed) +} #' An options setter for the `opts_df` data frame #' From b5610b010976648efc80148896333bd2e397e7e2 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:44:40 -0400 Subject: [PATCH 79/92] Add the `context_missing_text()` util function --- R/utils_formatters.R | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/R/utils_formatters.R b/R/utils_formatters.R index 352ec85b03..635062983e 100644 --- a/R/utils_formatters.R +++ b/R/utils_formatters.R @@ -262,6 +262,43 @@ to_latex_math_mode <- function(x, } } +#' Obtain the contextually correct minus mark +#' +#' @param context The output context. +#' @noRd +context_missing_text <- function(missing_text = NULL, + context) { + + if (is.null(missing_text)) { + return("") + } + + missing_text <- process_text(missing_text, context) + switch(context, + html = + { + if (missing_text == "---") { + "—" + } else if (missing_text == "--") { + "–" + } else { + missing_text + } + }, + latex = missing_text, + { + if (missing_text == "---") { + "\u2014" + } else if (missing_text == "--") { + "\u2013" + } else { + missing_text + } + }) +} +context_dash_mark <- context_missing_text + + #' Obtain the contextually correct minus mark #' #' @param context The output context. From 835ec9d9d029d641561b4a451e15ae9c7b9cf74c Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:45:12 -0400 Subject: [PATCH 80/92] Refactor the `cols_merge_range()` function --- R/modify_columns.R | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/R/modify_columns.R b/R/modify_columns.R index 1bf79c7711..51c51fefa9 100644 --- a/R/modify_columns.R +++ b/R/modify_columns.R @@ -767,6 +767,7 @@ cols_merge <- function(data, attr(data, "col_merge") <- list( pattern = pattern, + sep = NULL, col_1 = col_1) } @@ -885,6 +886,7 @@ cols_merge_uncert <- function(data, attr(data, "col_merge") <- list( pattern = pattern, + sep = NULL, col_1 = col_val) } @@ -962,10 +964,11 @@ cols_merge_uncert <- function(data, #' @export cols_merge_range <- function(data, col_begin, - col_end) { + col_end, + sep = "---") { # Set the formatting pattern - pattern <- "{1} \u2014 {2}" + pattern <- "{1} {sep} {2}" col_begin <- enquo(col_begin) col_end <- enquo(col_end) @@ -991,6 +994,9 @@ cols_merge_range <- function(data, attr(data, "col_merge")[["pattern"]] <- c(attr(data, "col_merge")[["pattern"]], pattern) + attr(data, "col_merge")[["sep"]] <- + c(attr(data, "col_merge")[["sep"]], sep) + attr(data, "col_merge")[["col_1"]] <- c(attr(data, "col_merge")[["col_1"]], col_begin) @@ -999,6 +1005,7 @@ cols_merge_range <- function(data, attr(data, "col_merge") <- list( pattern = pattern, + sep = sep, col_1 = col_begin) } From 11d52455d853fd9d7193769bf0f28a35da7dfe41 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:45:34 -0400 Subject: [PATCH 81/92] Use the `context_dash_mark()` function --- R/utils_render_common.R | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 345d05da82..e55cac6a11 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -241,7 +241,8 @@ perform_col_merge <- function(col_merge, data_df, output_df, boxh_df, - columns_df) { + columns_df, + context) { if (length(col_merge) == 0) { return( @@ -254,7 +255,13 @@ perform_col_merge <- function(col_merge, for (i in seq(col_merge[[1]])) { - pattern <- col_merge[["pattern"]][i] + sep <- col_merge[["sep"]][i] %>% context_dash_mark(context = context) + + pattern <- + col_merge[["pattern"]][i] %>% + tidy_sub("\\{sep\\}", sep) + + value_1_col <- col_merge[["col_1"]][i] %>% unname() value_2_col <- col_merge[["col_1"]][i] %>% names() @@ -344,11 +351,8 @@ create_summary_dfs <- function(summary_list, labels <- summary_attrs$summary_labels # Resolve the `missing_text` - if (missing_text == "---") { - missing_text <- "\u2014" - } else if (missing_text == "--") { - missing_text <- "\u2013" - } + missing_text <- + context_missing_text(missing_text = missing_text, context = context) assert_rowgroups <- function() { @@ -782,11 +786,6 @@ create_summary_rows <- function(n_rows, body_content_summary <- as.vector(t(summary_df)) - if (context == "latex") { - body_content_summary <- body_content_summary %>% - tidy_gsub("\u2014", "---") - } - row_splits_summary <- split_body_content( body_content = body_content_summary, From 895b38fd341001425643441ae9cfb01484414fca Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:45:52 -0400 Subject: [PATCH 82/92] Use the `context_missing_text()` function --- R/format_data.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/format_data.R b/R/format_data.R index 9ff58d01ed..828388f595 100644 --- a/R/format_data.R +++ b/R/format_data.R @@ -1294,11 +1294,11 @@ fmt_missing <- function(data, fns = list( html = function(x) { - if (missing_text == "---") { - missing_text <- "\u2014" - } else if (missing_text == "--") { - missing_text <- "\u2013" - } + missing_text <- + context_missing_text( + missing_text = missing_text, + context = "html" + ) # Any values of `x` that are `NA` get # `missing_text` as output; any values that From 98587709ac4145996fe30cb4d121bef37b46be01 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:46:09 -0400 Subject: [PATCH 83/92] Modify the `perform_col_merge()` fcn call --- R/as_rtf.R | 4 +++- R/build_data.R | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/R/as_rtf.R b/R/as_rtf.R index dfcbe0f6dd..74377f58c9 100644 --- a/R/as_rtf.R +++ b/R/as_rtf.R @@ -179,7 +179,9 @@ as_rtf <- function(data) { # Perform any necessary column merge operations col_merge_output <- - perform_col_merge(col_merge, data_df, output_df, boxh_df, columns_df) + perform_col_merge( + col_merge, data_df, output_df, boxh_df, columns_df, context + ) # Rewrite `output_df`, `boxh_df`, and `columns_df` as a result of merging output_df <- col_merge_output$output_df diff --git a/R/build_data.R b/R/build_data.R index 81b8ff4da9..d10263b023 100644 --- a/R/build_data.R +++ b/R/build_data.R @@ -156,7 +156,9 @@ build_data <- function(data, context) { # Perform any necessary column merge operations col_merge_output <- - perform_col_merge(col_merge, data_df, output_df, boxh_df, columns_df) + perform_col_merge( + col_merge, data_df, output_df, boxh_df, columns_df, context + ) # Rewrite `output_df`, `boxh_df`, and `columns_df` as a result of merging output_df <- col_merge_output$output_df From 81d3978364a97fa334ac383fdee0154fbf960285 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 15:46:25 -0400 Subject: [PATCH 84/92] Make corrections to several testthat tests --- tests/testthat/test-cols_merge.R | 14 +++++-- tests/testthat/test-conditional_fmt.R | 2 +- tests/testthat/test-fmt_missing.R | 10 ++--- tests/testthat/test-l_cols_merge.R | 60 +++++++++++++-------------- 4 files changed, 46 insertions(+), 40 deletions(-) diff --git a/tests/testthat/test-cols_merge.R b/tests/testthat/test-cols_merge.R index ac1c724510..96a928e71a 100644 --- a/tests/testthat/test-cols_merge.R +++ b/tests/testthat/test-cols_merge.R @@ -203,7 +203,7 @@ test_that("the `cols_merge_range()` function works correctly", { # Expect that merging statements are stored in `col_merge` attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% - expect_equal("{1} — {2}") + expect_equal("{1} {sep} {2}") attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% names() %>% @@ -223,7 +223,7 @@ test_that("the `cols_merge_range()` function works correctly", { # Expect that merging statements are stored in `col_merge` attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% - expect_equal("{1} — {2}") + expect_equal("{1} {sep} {2}") attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% names() %>% @@ -246,7 +246,10 @@ test_that("the `cols_merge_range()` function works correctly", { # Expect that merging statements are stored in `col_merge` attr(tbl_html, "col_merge", exact = TRUE)$pattern[[1]] %>% - expect_equal("{1} — {2}") + expect_equal("{1} {sep} {2}") + + attr(tbl_html, "col_merge", exact = TRUE)$sep[[1]] %>% + expect_equal("---") attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% names() %>% @@ -257,7 +260,10 @@ test_that("the `cols_merge_range()` function works correctly", { expect_equal("col_1") attr(tbl_html, "col_merge", exact = TRUE)$pattern[[2]] %>% - expect_equal("{1} — {2}") + expect_equal("{1} {sep} {2}") + + attr(tbl_html, "col_merge", exact = TRUE)$sep[[2]] %>% + expect_equal("---") attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% names() %>% diff --git a/tests/testthat/test-conditional_fmt.R b/tests/testthat/test-conditional_fmt.R index fb865d5731..89b95c4e31 100644 --- a/tests/testthat/test-conditional_fmt.R +++ b/tests/testthat/test-conditional_fmt.R @@ -234,7 +234,7 @@ test_that("the `fmt_missing()` function works with conditional `rows`", { columns = vars(num_2), rows = num_1 <= 0) %>% render_formats_test(context = "html"))[["num_2"]], - c("34", "74", "23", "NA", "35", rep("—", 2)) + c("34", "74", "23", "NA", "35", rep("—", 2)) ) }) diff --git a/tests/testthat/test-fmt_missing.R b/tests/testthat/test-fmt_missing.R index 004665734d..9108374732 100644 --- a/tests/testthat/test-fmt_missing.R +++ b/tests/testthat/test-fmt_missing.R @@ -54,13 +54,13 @@ test_that("the `fmt_missing()` function works correctly", { (tab %>% fmt_missing(columns = "num_1") %>% render_formats_test(context = "html"))[["num_1"]], - c("—", "74", "—", "93", "—", "76", "—")) + c("—", "74", "—", "93", "—", "76", "—")) expect_equal( (tab %>% fmt_missing(columns = "num_1", missing_text = "--") %>% render_formats_test(context = "html"))[["num_1"]], - c("–", "74", "–", "93", "–", "76", "–")) + c("–", "74", "–", "93", "–", "76", "–")) expect_equal( (tab %>% @@ -84,7 +84,7 @@ test_that("the `fmt_missing()` function works correctly", { (tab %>% fmt_missing(columns = "num_1", rows = num_2 < 50) %>% render_formats_test(context = "html"))[["num_1"]], - c("—", "74", "—", "93", "—", "76", "NA")) + c("—", "74", "—", "93", "—", "76", "NA")) # Format columns with `fmt_number()` then use # `fmt_missing()` on all columns (the two functions @@ -97,7 +97,7 @@ test_that("the `fmt_missing()` function works correctly", { ) %>% fmt_missing(columns = TRUE) %>% render_formats_test(context = "html"))[["num_1"]], - c("—", "74.000", "—", "93.000", "—", "76.000", "—")) + c("—", "74.000", "—", "93.000", "—", "76.000", "—")) # Reverse the ordering: use `fmt_missing()` first # then `fmt_number()`; expect the same output as before @@ -109,5 +109,5 @@ test_that("the `fmt_missing()` function works correctly", { decimals = 3 ) %>% render_formats_test(context = "html"))[["num_1"]], - c("—", "74.000", "—", "93.000", "—", "76.000", "—")) + c("—", "74.000", "—", "93.000", "—", "76.000", "—")) }) diff --git a/tests/testthat/test-l_cols_merge.R b/tests/testthat/test-l_cols_merge.R index 6ad98ee5d6..3ba26209b6 100644 --- a/tests/testthat/test-l_cols_merge.R +++ b/tests/testthat/test-l_cols_merge.R @@ -182,16 +182,16 @@ test_that("the `cols_merge_range()` function works correctly", { # Expect a characteristic pattern grepl( paste0( - ".*767.6 — 928.1 & 382.0 & 674.5", - ".*403.3 — 461.5 & 15.1 & 242.8", - ".*686.4 — 54.1 & 282.7 & 56.3", - ".*662.6 — 148.8 & 984.6 & 928.1", - ".*198.5 — 65.1 & 127.4 & 219.3", - ".*132.1 — 118.1 & 91.2 & 874.3", - ".*349.7 — 307.1 & 566.7 & 542.9", - ".*63.7 — 504.3 & 152.0 & 724.5", - ".*105.4 — 729.8 & 962.4 & 336.4", - ".*924.2 — 424.6 & 740.8 & 104.2.*"), + ".*767.6 --- 928.1 & 382.0 & 674.5", + ".*403.3 --- 461.5 & 15.1 & 242.8", + ".*686.4 --- 54.1 & 282.7 & 56.3", + ".*662.6 --- 148.8 & 984.6 & 928.1", + ".*198.5 --- 65.1 & 127.4 & 219.3", + ".*132.1 --- 118.1 & 91.2 & 874.3", + ".*349.7 --- 307.1 & 566.7 & 542.9", + ".*63.7 --- 504.3 & 152.0 & 724.5", + ".*105.4 --- 729.8 & 962.4 & 336.4", + ".*924.2 --- 424.6 & 740.8 & 104.2.*"), tbl_latex %>% as_latex() %>% as.character()) %>% expect_true() @@ -207,16 +207,16 @@ test_that("the `cols_merge_range()` function works correctly", { # Expect a characteristic pattern grepl( paste0( - ".*767.6 — 928.1 & 382.0 & 674.5", - ".*403.3 — 461.5 & 15.1 & 242.8", - ".*686.4 — 54.1 & 282.7 & 56.3", - ".*662.6 — 148.8 & 984.6 & 928.1", - ".*198.5 — 65.1 & 127.4 & 219.3", - ".*132.1 — 118.1 & 91.2 & 874.3", - ".*349.7 — 307.1 & 566.7 & 542.9", - ".*63.7 — 504.3 & 152.0 & 724.5", - ".*105.4 — 729.8 & 962.4 & 336.4", - ".*924.2 — 424.6 & 740.8 & 104.2.*"), + ".*767.6 --- 928.1 & 382.0 & 674.5", + ".*403.3 --- 461.5 & 15.1 & 242.8", + ".*686.4 --- 54.1 & 282.7 & 56.3", + ".*662.6 --- 148.8 & 984.6 & 928.1", + ".*198.5 --- 65.1 & 127.4 & 219.3", + ".*132.1 --- 118.1 & 91.2 & 874.3", + ".*349.7 --- 307.1 & 566.7 & 542.9", + ".*63.7 --- 504.3 & 152.0 & 724.5", + ".*105.4 --- 729.8 & 962.4 & 336.4", + ".*924.2 --- 424.6 & 740.8 & 104.2.*"), tbl_latex %>% as_latex() %>% as.character()) %>% expect_true() @@ -235,16 +235,16 @@ test_that("the `cols_merge_range()` function works correctly", { # Expect a characteristic pattern grepl( paste0( - ".*767.6 — 928.1 & 382.0 — 674.5", - ".*403.3 — 461.5 & 15.1 — 242.8", - ".*686.4 — 54.1 & 282.7 — 56.3", - ".*662.6 — 148.8 & 984.6 — 928.1", - ".*198.5 — 65.1 & 127.4 — 219.3", - ".*132.1 — 118.1 & 91.2 — 874.3", - ".*349.7 — 307.1 & 566.7 — 542.9", - ".*63.7 — 504.3 & 152.0 — 724.5", - ".*105.4 — 729.8 & 962.4 — 336.4", - ".*924.2 — 424.6 & 740.8 — 104.2.*"), + ".*767.6 --- 928.1 & 382.0 --- 674.5", + ".*403.3 --- 461.5 & 15.1 --- 242.8", + ".*686.4 --- 54.1 & 282.7 --- 56.3", + ".*662.6 --- 148.8 & 984.6 --- 928.1", + ".*198.5 --- 65.1 & 127.4 --- 219.3", + ".*132.1 --- 118.1 & 91.2 --- 874.3", + ".*349.7 --- 307.1 & 566.7 --- 542.9", + ".*63.7 --- 504.3 & 152.0 --- 724.5", + ".*105.4 --- 729.8 & 962.4 --- 336.4", + ".*924.2 --- 424.6 & 740.8 --- 104.2.*"), tbl_latex %>% as_latex() %>% as.character()) %>% expect_true() From 0838ad2551f1ca2e7b5ede86ef3899f771a75707 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:29:55 -0400 Subject: [PATCH 85/92] Ensure sep is an empty string --- R/modify_columns.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/modify_columns.R b/R/modify_columns.R index 51c51fefa9..d89a97c4a5 100644 --- a/R/modify_columns.R +++ b/R/modify_columns.R @@ -767,7 +767,7 @@ cols_merge <- function(data, attr(data, "col_merge") <- list( pattern = pattern, - sep = NULL, + sep = "", col_1 = col_1) } @@ -886,7 +886,7 @@ cols_merge_uncert <- function(data, attr(data, "col_merge") <- list( pattern = pattern, - sep = NULL, + sep = "", col_1 = col_val) } From 42a240f2b3283b535d78ded795b9ebe3d8181430 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:30:10 -0400 Subject: [PATCH 86/92] Remove unneeded conditional statement --- R/utils_formatters.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/R/utils_formatters.R b/R/utils_formatters.R index 635062983e..8c5034e680 100644 --- a/R/utils_formatters.R +++ b/R/utils_formatters.R @@ -266,14 +266,11 @@ to_latex_math_mode <- function(x, #' #' @param context The output context. #' @noRd -context_missing_text <- function(missing_text = NULL, +context_missing_text <- function(missing_text, context) { - if (is.null(missing_text)) { - return("") - } - missing_text <- process_text(missing_text, context) + switch(context, html = { From 1fea5092b3c735af51456ee4453a90a474db9cb6 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:30:28 -0400 Subject: [PATCH 87/92] Create `grand_summary_col` variable --- R/utils_render_common.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index e55cac6a11..17a41f6f59 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -1,3 +1,6 @@ + +grand_summary_col <- "::GRAND_SUMMARY" + # Utility function to generate column numbers from column names; # used in: `resolve_footnotes_styles()` colname_to_colnum <- function(boxh_df, From 2b837a759bda29124d5b39e772655e32c9a3df7a Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:31:23 -0400 Subject: [PATCH 88/92] Modify position of check for labels (earlier) --- R/utils_render_common.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 17a41f6f59..7520f6d719 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -353,6 +353,15 @@ create_summary_dfs <- function(summary_list, formatter_options <- summary_attrs$formatter_options labels <- summary_attrs$summary_labels + if (length(labels) != length(unique(labels))) { + + stop("All summary labels must be unique:\n", + " * Review the names provided in `fns`\n", + " * These labels are in conflict: ", + paste0(labels, collapse = ", "), ".", + call. = FALSE) + } + # Resolve the `missing_text` missing_text <- context_missing_text(missing_text = missing_text, context = context) @@ -430,15 +439,6 @@ create_summary_dfs <- function(summary_list, # Get the registered function calls agg_funs <- fns %>% lapply(rlang::as_closure) - if (length(labels) != length(unique(labels))) { - - stop("All summary labels must be unique:\n", - " * Review the names provided in `fns`\n", - " * These labels are in conflict: ", - paste0(labels, collapse = ", "), ".", - call. = FALSE) - } - # Initialize an empty tibble to bind to summary_dfs_data <- dplyr::tibble() From 982150ae55b1b76624ba3798f394bacf7d6442b3 Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:31:52 -0400 Subject: [PATCH 89/92] Clean up logic of checks for groups --- R/utils_render_common.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 7520f6d719..515b5d9616 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -418,21 +418,21 @@ create_summary_dfs <- function(summary_list, # Combine `groupname` with the table body data in order to # process data by groups - if (groups[1] != grand_summary_col) { + if (identical(groups, grand_summary_col)) { select_data_df <- cbind( stub_df[c("groupname", "rowname")], data_df)[, -2] %>% + dplyr::mutate(groupname = grand_summary_col) %>% dplyr::select(groupname, columns) - } else if (identical(groups, grand_summary_col)) { + } else { select_data_df <- cbind( stub_df[c("groupname", "rowname")], data_df)[, -2] %>% - dplyr::mutate(groupname = grand_summary_col) %>% dplyr::select(groupname, columns) } From 92cdb2aeaebd57657d5d509a98f93ecf3f14abae Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:32:25 -0400 Subject: [PATCH 90/92] Use `lapply()` statement in refactor --- R/utils_render_common.R | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 515b5d9616..13aae0ba39 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -439,15 +439,9 @@ create_summary_dfs <- function(summary_list, # Get the registered function calls agg_funs <- fns %>% lapply(rlang::as_closure) - # Initialize an empty tibble to bind to - summary_dfs_data <- dplyr::tibble() - - for (j in seq(agg_funs)) { - - # Get aggregation rows for each of the `agg_funs` - summary_dfs_data <- - dplyr::bind_rows( - summary_dfs_data, + summary_dfs_data <- + lapply( + seq(agg_funs), function(j) { select_data_df %>% dplyr::filter(groupname %in% groups) %>% dplyr::group_by(groupname) %>% @@ -455,8 +449,9 @@ create_summary_dfs <- function(summary_list, dplyr::ungroup() %>% dplyr::mutate(rowname = labels[j]) %>% dplyr::select(groupname, rowname, dplyr::everything()) - ) - } + } + ) %>% + dplyr::bind_rows() # Add those columns that were not part of # the aggregation, filling those with NA values From d3cc19dddccc37aab99b89c1d94bf97a387bfe9a Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:32:44 -0400 Subject: [PATCH 91/92] Do not hardcode HTML formatter --- R/utils_render_common.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 13aae0ba39..cf3f94ecdc 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -477,12 +477,8 @@ create_summary_dfs <- function(summary_list, summary_attrs$formatter_options)) formatter <- attr(format_data, "formats")[[1]]$func - - if ("html" %in% names(formatter)) { - formatter$html(x) - } else { - formatter$default(x) - } + fmt <- formatter[[context]] %||% formatter$default + fmt(x) } ) %>% dplyr::mutate_at( From 1a7072fa69de34acf785534ca618110fafafc90b Mon Sep 17 00:00:00 2001 From: Richard Iannone Date: Wed, 24 Apr 2019 17:33:07 -0400 Subject: [PATCH 92/92] Use `grand_summary_col` variable --- R/utils_render_common.R | 1 - R/utils_render_footnotes.R | 8 ++++---- R/utils_render_html.R | 5 ++--- 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/R/utils_render_common.R b/R/utils_render_common.R index cf3f94ecdc..69a02f6d40 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -339,7 +339,6 @@ create_summary_dfs <- function(summary_list, # purposes summary_df_display_list <- list() summary_df_data_list <- list() - grand_summary_col <- "::GRAND_SUMMARY" for (i in seq(summary_list)) { diff --git a/R/utils_render_footnotes.R b/R/utils_render_footnotes.R index 292d8cf7ef..210caae634 100644 --- a/R/utils_render_footnotes.R +++ b/R/utils_render_footnotes.R @@ -614,18 +614,18 @@ apply_footnotes_to_summary <- function(list_of_summaries, for (i in seq(nrow(footnotes_data_glpyhs))) { text <- - summary_df_list$`::GRAND_SUMMARY`[[ + summary_df_list[[grand_summary_col]][[ footnotes_data_glpyhs$rownum[i], footnotes_data_glpyhs$colname[i]]] text <- paste0(text, footnote_glyph_to_html(footnotes_data_glpyhs$fs_id_coalesced[i])) - summary_df_list$`::GRAND_SUMMARY`[[ + summary_df_list[[grand_summary_col]][[ footnotes_data_glpyhs$rownum[i], footnotes_data_glpyhs$colname[i]]] <- text } - list_of_summaries$summary_df_display_list$`::GRAND_SUMMARY` <- - summary_df_list$`::GRAND_SUMMARY` + list_of_summaries$summary_df_display_list[[grand_summary_col]] <- + summary_df_list[[grand_summary_col]] } list_of_summaries diff --git a/R/utils_render_html.R b/R/utils_render_html.R index 41c28928da..f3314ce51a 100644 --- a/R/utils_render_html.R +++ b/R/utils_render_html.R @@ -139,7 +139,6 @@ apply_styles_to_summary_output <- function(summary_df, styles_summary_df <- summary_df styles_summary_df[] <- NA_character_ - styles_tbl_summary <- styles_resolved %>% dplyr::filter(locname %in% "summary_cells") %>% @@ -823,10 +822,10 @@ create_body_component_h <- function(row_splits_body, # If there is a grand summary, include that at the end if (summaries_present && - "::GRAND_SUMMARY" %in% names(list_of_summaries$summary_df_display_list)) { + grand_summary_col %in% names(list_of_summaries$summary_df_display_list)) { grand_summary_df <- - list_of_summaries$summary_df_display_list$`::GRAND_SUMMARY` %>% + list_of_summaries$summary_df_display_list[[grand_summary_col]] %>% as.data.frame(stringsAsFactors = FALSE) row_splits_summary_styles <-