Nothing
R/utils_render_common.R
In gt: Easily Create Presentation-Ready Display Tables
Defines functions
summary_row_side
get_body_component_cell_matrix
get_stub_layout
get_effective_number_of_columns
get_number_of_visible_data_columns
stub_group_names_has_column
stub_rownames_has_column
last_non_na
replace_na_groups_rows_df
replace_na_groups_df
perform_col_merge
resolve_secondary_pattern
reorder_styles
reorder_footnotes
get_row_reorder_df
perform_text_transforms
migrate_unformatted_to_output
render_substitutions
is_compatible_formatter
render_formats
rownum_translation
colname_to_colnum
validate_contexts
#------------------------------------------------------------------------------#
#
# /$$
# | $$
# /$$$$$$ /$$$$$$
# /$$__ $$|_ $$_/
# | $$ \ $$ | $$
# | $$ | $$ | $$ /$$
# | $$$$$$$ | $$$$/
# \____ $$ \___/
# /$$ \ $$
# | $$$$$$/
# \______/
#
# This file is part of the 'rstudio/gt' project.
#
# Copyright (c) 2018-2023 gt authors
#
# For full copyright and license information, please look at
# https://gt.rstudio.com/LICENSE.html
#
#------------------------------------------------------------------------------#
# Define the contexts
all_contexts <- c("html", "latex", "rtf", "word", "default")
missing_val_token <- "::missing_val::"
validate_contexts <- function(contexts) {
if (!all(contexts %in% all_contexts)) {
invalid_contexts <- base::setdiff(contexts, all_contexts)
cli::cli_abort(c(
"All output contexts must be in the set of supported contexts.",
"*" = "Supported: {paste0(all_contexts, collapse = ', ')}",
"*" = "Invalid: {paste0(invalid_contexts, collapse = ', ')}"
))
}
}
# Utility function to generate column numbers from column names;
# used in: `resolve_footnotes_styles()`
colname_to_colnum <- function(
data,
colname,
missing_is_zero = FALSE
) {
vars_default <- dt_boxhead_get_vars_default(data = data)
result <- match(colname, vars_default)
if (missing_is_zero) {
result[is.na(result)] <- 0L
}
result
}
# Utility function to generate finalized row numbers;
# used in: `resolve_footnotes_styles()`
rownum_translation <- function(body, rownum_start) {
rownum_final <- c()
for (rownum_s in rownum_start) {
rownum_final <-
c(
rownum_final,
which(as.numeric(rownames(body)) == rownum_s)
)
}
rownum_final
}
#' Render any formatting directives available in the `formats` list
#'
#' @noRd
render_formats <- function(data, context) {
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
formats <- dt_formats_get(data = data)
# Render input data to output data where formatting is specified
for (fmt in formats) {
# Determine if the formatting function has a function relevant to
# the context; if not, use the `default` function (which should
# always be present)
if (context %in% names(fmt$func)) {
eval_func <- context
} else {
eval_func <- "default"
}
# Obtain compatibility information for the formatting function
compat <- fmt$compat
# Get the rows to which the formatting should be constrained
rows <- fmt$rows
for (col in fmt[["cols"]]) {
# Perform rendering but only do so if the column is present
if (
col %in% colnames(data_tbl) &&
is_compatible_formatter(
table = data_tbl,
column = col,
rows = rows,
compat = compat
)
) {
# Omit rows that are not present in the `data_tbl` object
rows <- base::intersect(seq_len(nrow(data_tbl)), rows)
result <- fmt$func[[eval_func]](data_tbl[[col]][rows])
# If any of the resulting output is `NA`, that means we want
# to NOT make changes to those particular cells' output
# (i.e. inherit the results of the previous formatter).
body[[col]][rows][!is.na(result)] <- stats::na.omit(result)
}
}
}
dt_body_set(data = data, body = body)
}
is_compatible_formatter <- function(table, column, rows, compat) {
if (is.null(compat)) {
return(TRUE)
}
inherits(table[[column]][rows], compat)
}
#' Render any formatting directives available in the `substitutions` list
#'
#' @noRd
render_substitutions <- function(
data,
context
) {
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
substitutions <- dt_substitutions_get(data = data)
# Render input data to output data where formatting
# is specified
for (subst in substitutions) {
# Determine if the formatter has a function relevant
# to the context; if not, use the `default` function
# (which should always be present)
if (context %in% names(subst$func)) {
eval_func <- context
} else {
eval_func <- "default"
}
for (col in subst[["cols"]]) {
# Perform rendering but only do so if the column is present
if (col %in% colnames(data_tbl)) {
result <- subst$func[[eval_func]](data_tbl[[col]][subst$rows])
# If any of the resulting output is `NA`, that
# means we want to NOT make changes to those
# particular cells' output (i.e. inherit the
# results of the previous substitution).
body[[col]][subst$rows][!is.na(result)] <- stats::na.omit(result)
}
}
}
data <- dt_body_set(data = data, body = body)
data
}
# Move input data cells to `body` that didn't have any rendering applied
# during the `render_formats()` call
migrate_unformatted_to_output <- function(data, context) {
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
for (colname in colnames(body)) {
row_index <- is.na(body[[colname]])
if (inherits(data_tbl[[colname]], "list")) {
# Use `lapply()` so that all values could be treated independently
body[[colname]][row_index] <-
lapply(
data_tbl[[colname]][row_index],
FUN = function(x) {
if (is.numeric(x)) {
x <-
format(
x,
drop0trailing = FALSE,
trim = TRUE,
justify = "none"
)
}
x <- tidy_gsub(x, "\\s+$", "")
x <- process_text(x, context = context)
x <- paste(x, collapse = ", ")
x
}
)
} else {
# No `lapply()` used: all values will be treated cohesively
vals <- data_tbl[[colname]][row_index]
if (is.numeric(vals)) {
vals <-
format(
vals,
drop0trailing = FALSE,
trim = TRUE,
justify = "none"
)
}
if (is.factor(vals)) {
vals <- as.character(vals)
}
body[[colname]][row_index] <- process_text(text = vals, context = context)
}
}
dt_body_set(data = data, body = body)
}
#' Perform any text transformations
#'
#' @noRd
perform_text_transforms <- function(data) {
transforms <- dt_transforms_get(data = data)
for (transform in transforms) {
data <-
text_transform_at_location(
loc = transform$resolved,
data = data,
fn = transform$fn
)
}
data
}
#' Obtain a reordering df for the data rows
#'
#' @noRd
get_row_reorder_df <- function(groups, stub_df) {
# If there are no group, there there is no reordering
# so just return a data frame where the starting row
# indices match the final row indices
if (length(groups) == 0) {
indices <- seq_len(nrow(stub_df))
return(
dplyr::tibble(
rownum_start = indices,
rownum_final = indices
)
)
}
indices <- lapply(stub_df$group_id, `%in%`, x = groups)
indices <- lapply(indices, which)
indices <- unlist(indices)
indices <- order(indices)
dplyr::tibble(
rownum_start = seq_along(indices),
rownum_final = indices
)
}
# Function to recode the `rownum` value in the footnotes table
reorder_footnotes <- function(data) {
stub_df <- dt_stub_df_get(data = data)
footnotes_tbl <- dt_footnotes_get(data = data)
rownum_final <- as.numeric(stub_df$rownum_i)
for (i in seq_len(nrow(footnotes_tbl))) {
if (
!is.na(footnotes_tbl[i, ][["rownum"]]) &&
footnotes_tbl[i, ][["locname"]] %in% c("data", "stub")
) {
footnotes_tbl[i, ][["rownum"]] <-
which(rownum_final == footnotes_tbl[i, ][["rownum"]])
}
}
dt_footnotes_set(data = data, footnotes = footnotes_tbl)
}
# Function to recode the `rownum` value in the styles table
reorder_styles <- function(data) {
stub_df <- dt_stub_df_get(data = data)
styles_tbl <- dt_styles_get(data = data)
rownum_final <- as.numeric(stub_df[, "rownum_i", drop = TRUE])
sz <- nrow(styles_tbl)
tmp_rownum <- vector("integer", sz)
tmp_mask <- vector("logical", sz)
for (i in seq_len(sz)) {
if (
!is.na(styles_tbl$rownum[i]) &&
!grepl("summary_cells", styles_tbl$locname[i])
) {
tmp_mask[i] <- TRUE
tmp_rownum[i] <- which(rownum_final == styles_tbl$rownum[i])
}
}
final_rownum <- styles_tbl$rownum
final_rownum[tmp_mask] <- tmp_rownum[tmp_mask]
styles_tbl$rownum <- final_rownum
dt_styles_set(data = data, styles = styles_tbl)
}
resolve_secondary_pattern <- function(x) {
#
# Preprocessing
#
x <- gsub("<br>", "[[br]]", x, fixed = TRUE)
while (grepl("<<.*?>>", x)) {
m <- gregexpr("<<[^<]*?>>", x, perl = TRUE)
matched <- unlist(regmatches(x, m))[1]
m_start <- as.integer(m[[1]])
m_length <- attr(m[[1]], "match.length")
if (grepl(missing_val_token, matched)) {
# Remove `matched` text from `x`
x <-
paste0(
substr(x, 0, m_start - 1L),
substr(x, m_start + m_length, 100000)
)
} else {
# Remove `<<` and `>>` from `matched` and insert back into `x`
matched_trimmed <- gsub("^<<|>>$", "", matched)
x <-
paste0(
substr(x, 0, m_start - 1L),
matched_trimmed,
substr(x, m_start + m_length, 100000)
)
}
}
#
# Postprocessing
#
x <- gsub("[[br]]", "<br>", x, fixed = TRUE)
x
}
#' Perform merging of column contents
#'
#' This merges column content together with a pattern and possibly with a `type`
#' that specifies additional operations
#'
#' @noRd
perform_col_merge <- function(data, context) {
col_merge <- dt_col_merge_get(data = data)
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
if (length(col_merge) == 0) {
return(data)
}
for (i in seq_along(col_merge)) {
type <- col_merge[[i]]$type
if (!(type %in% c("merge", "merge_range", "merge_uncert", "merge_n_pct"))) {
cli::cli_abort("Unknown `type` supplied.")
}
if (type == "merge") {
#
# The `cols_merge()` formatting case
#
mutated_column <- col_merge[[i]]$vars[1]
columns <- col_merge[[i]][["vars"]]
rows <- col_merge[[i]][["rows"]]
pattern <- col_merge[[i]][["pattern"]]
glue_src_na_data <- lapply(as.list(data_tbl[rows, columns]), FUN = is.na)
glue_src_data <- as.list(body[rows, columns])
glue_src_data <-
lapply(
seq_along(glue_src_data),
FUN = function(x) {
# The source data (and 'source data' here means data that's already
# been formatted and converted to `character`) having a character
# `"NA"` value signals that the value should *probably* be treated
# as missing (we are relatively certain it wasn't modified by
# `sub_missing()`, a case where we consider the value *not* to be
# missing because it was handled later) but we also want to
# corroborate that with the original data values (checking for true
# missing data there)
missing_cond <- glue_src_data[[x]] == "NA" & glue_src_na_data[[x]]
missing_cond[is.na(missing_cond)] <- TRUE
glue_src_data[[x]][missing_cond] <- missing_val_token
glue_src_data[[x]]
}
)
glue_src_data <- stats::setNames(glue_src_data, seq_len(length(glue_src_data)))
glued_cols <- as.character(glue_gt(glue_src_data, pattern))
if (grepl("<<.*?>>", pattern)) {
glued_cols <-
vapply(
glued_cols,
FUN.VALUE = character(1),
USE.NAMES = FALSE,
FUN = resolve_secondary_pattern
)
glued_cols <- gsub("<<|>>", "", glued_cols)
}
glued_cols <- gsub(missing_val_token, "NA", glued_cols, fixed = TRUE)
body[rows, mutated_column] <- glued_cols
} else if (type == "merge_n_pct") {
#
# The `cols_merge_n_pct()` formatting case
#
mutated_column <- col_merge[[i]][["vars"]][1]
second_column <- col_merge[[i]][["vars"]][2]
rows <- col_merge[[i]][["rows"]]
# This is a fixed pattern
pattern <- "{1} ({2})"
# Determine rows where NA values exist, and, those rows where
# `0` is the value in the `mutated_column` (we don't want to
# include a zero percentage value in parentheses)
na_1_rows <- is.na(data_tbl[[mutated_column]])
na_2_rows <- is.na(data_tbl[[second_column]])
zero_rows <- data_tbl[[mutated_column]] == 0
zero_rows[is.na(zero_rows)] <- FALSE
zero_rows_idx <- which(zero_rows)
# An `NA` value in either column should exclude that row from
# processing via `glue_gt()`
rows_to_format_idx <- which(!(na_1_rows | na_2_rows))
rows_to_format_idx <- base::setdiff(rows_to_format_idx, zero_rows_idx)
rows_to_format_idx <- base::intersect(rows_to_format_idx, rows)
body[rows_to_format_idx, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body[[mutated_column]][rows_to_format_idx],
"2" = body[[second_column]][rows_to_format_idx]
),
pattern
)
)
} else if (type == "merge_uncert" && length(col_merge[[i]]$vars) == 3) {
#
# The `cols_merge_uncert()` case where lower and upper certainties
# were provided as input columns
#
mutated_column <- col_merge[[i]][["vars"]][1]
lu_column <- col_merge[[i]][["vars"]][2]
uu_column <- col_merge[[i]][["vars"]][3]
rows <- col_merge[[i]][["rows"]]
pattern_equal <- col_merge[[i]][["pattern"]]
sep <- col_merge[[i]][["sep"]]
# Transform the separator text depending on specific
# inputs and the `context`
sep <- context_dash_mark(sep, context = context)
sep <- context_plusminus_mark(sep, context = context)
if (context == "html") {
pattern_unequal <-
paste0(
"<<1>><span style=\"",
"display:inline-block;",
"line-height:1em;",
"text-align:right;",
"font-size:60%;",
"vertical-align:-0.25em;",
"margin-left:0.1em;",
"\">",
"+<<3>><br>",
context_minus_mark(context = context), "<<2>>",
"</span>"
)
} else if (context == "latex") {
pattern_unequal <- "$<<1>>^{+<<3>>}_{-<<2>>}$"
} else if (context == "rtf") {
pattern_unequal <- "<<1>>(+<<3>>, -<<2>>)"
}
# Determine rows where NA values exist
na_1_rows <- is.na(data_tbl[[mutated_column]])
na_lu_rows <- is.na(data_tbl[[lu_column]])
na_uu_rows <- is.na(data_tbl[[uu_column]])
na_lu_or_uu <- na_lu_rows | na_uu_rows
na_lu_and_uu <- na_lu_rows & na_uu_rows
lu_equals_uu <- data_tbl[[lu_column]] == data_tbl[[uu_column]] & !na_lu_or_uu
rows_to_format_equal <- base::intersect(which(!na_1_rows & lu_equals_uu), rows)
rows_to_format_unequal <- base::intersect(which(!na_1_rows & !na_lu_and_uu & !lu_equals_uu), rows)
body[rows_to_format_equal, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body[[mutated_column]][rows_to_format_equal],
"2" = body[[lu_column]][rows_to_format_equal],
"sep" = sep
),
pattern_equal
)
)
body[rows_to_format_unequal, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body[[mutated_column]][rows_to_format_unequal],
"2" = body[[lu_column]][rows_to_format_unequal],
"3" = body[[uu_column]][rows_to_format_unequal]
),
pattern_unequal,
.open = "<<",
.close = ">>"
)
)
} else {
#
# The `cols_merge_range()` and `cols_merge_uncert()` (standard
# uncertainties) formatting cases
#
mutated_column <- col_merge[[i]][["vars"]][1]
second_column <- col_merge[[i]][["vars"]][2]
rows <- col_merge[[i]][["rows"]]
pattern <- col_merge[[i]][["pattern"]]
sep <- col_merge[[i]][["sep"]]
# Replace any fullwidth tilde characters (the range separator in
# the 'ja' locale) with standard `~` in the LaTeX rendering context
if (grepl("\UFF5E", sep) && context == "latex") {
sep <- gsub("\UFF5E", "~", sep)
}
# Transform the separator text depending on specific
# inputs and the `context`
sep <- context_dash_mark(sep, context = context)
sep <- context_plusminus_mark(sep, context = context)
# Determine rows where NA values exist
na_1_rows <- is.na(data_tbl[[mutated_column]])
na_2_rows <- is.na(data_tbl[[second_column]])
if (type == "merge_range") {
rows_to_format <- base::intersect(which(!(na_1_rows & na_2_rows)), rows)
} else if (type == "merge_uncert") {
rows_to_format <- base::intersect(which(!(na_1_rows | na_2_rows)), rows)
}
body_1_vals <- body[[mutated_column]][rows_to_format]
body_1_vals[body_1_vals == "<br />"] <- ""
body_2_vals <- body[[second_column]][rows_to_format]
body_2_vals[body_2_vals == "<br />"] <- ""
body[rows_to_format, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body_1_vals,
"2" = body_2_vals,
"sep" = sep
),
pattern
)
)
}
}
dt_body_set(data = data, body = body)
}
#' Suitably replace `NA` values in the `groups_df` data frame
#'
#' @param groups_df The `groups_df` data frame.
#' @param others_group The `others_group` vector.
#' @noRd
replace_na_groups_df <- function(groups_df, others_group) {
if (nrow(groups_df) > 0) {
groups_df[is.na(groups_df[, "group_id"]), "group_id"] <- others_group
}
groups_df
}
#' Suitably replace `NA` values in the `groups_rows_df` data frame
#'
#' @param groups_rows_df The `groups_rows_df` data frame.
#' @param others_group The `others_group` vector.
#' @noRd
replace_na_groups_rows_df <- function(groups_rows_df, others_group) {
if (nrow(groups_rows_df) > 0) {
groups_rows_df[
is.na(groups_rows_df[, "group"]),
c("group", "group_label")] <- others_group
}
groups_rows_df
}
last_non_na <- function(vect) {
# Retrieve last non-NA value
positions <- which(!is.na(vect))
if (length(positions) == 0) {
return(NA_character_)
} else {
return(as.character(vect[max(positions)]))
}
}
# Determine whether the table should have row labels
# set within a column in the stub
stub_rownames_has_column <- function(data) {
isTRUE("row_id" %in% dt_stub_components(data = data))
}
# Determine whether the table should have row group labels
# set within a column in the stub
stub_group_names_has_column <- function(data) {
# If there aren't any row groups then the result is always FALSE
if (nrow(dt_groups_rows_get(data = data)) < 1) {
return(FALSE)
}
# Given that there are row groups, we need to look at the option
# `row_group_as_column` to determine whether they populate a column
# located in the stub; if set as TRUE then that's the return value
dt_options_get_value(data = data, option = "row_group_as_column")
}
# Get the number of columns for the visible (not hidden) data; this
# excludes the number of columns required for the table stub
get_number_of_visible_data_columns <- function(data) {
length(dt_boxhead_get_vars_default(data = data))
}
get_effective_number_of_columns <- function(data) {
# Check if the table has been built, return an error if that's not the case
if (!dt_has_built(data = data)) {
cli::cli_abort(
"The `get_effective_number_of_columns()` function can only be used on
gt objects that have tables 'built'."
)
}
# Obtain the number of visible columns in the built table
n_data_cols <- get_number_of_visible_data_columns(data = data)
n_data_cols + length(get_stub_layout(data = data))
}
get_stub_layout <- function(data) {
# Determine which stub components are potentially present as columns
stub_rownames_is_column <- stub_rownames_has_column(data = data)
stub_groupnames_is_column <- stub_group_names_has_column(data = data)
# Get the potential total number of columns in the table stub
n_stub_cols <- stub_rownames_is_column + stub_groupnames_is_column
# Resolve the layout of the stub (i.e., the roles of columns if present)
if (n_stub_cols == 0) {
# If summary rows are present, we will use the `rowname` column
# for the summary row labels
if (dt_summary_exists(data = data)) {
return("rowname")
} else {
return(NULL)
}
} else {
c(
if (stub_groupnames_is_column) "group_label",
if (stub_rownames_is_column) "rowname"
)
}
}
# Get a matrix of all body cells
get_body_component_cell_matrix <- function(data) {
body <- dt_body_get(data = data)
stub_layout <- get_stub_layout(data = data)
default_vars <- dt_boxhead_get_vars_default(data = data)
body_matrix <- unname(as.matrix(body[, default_vars]))
if (length(stub_layout) == 0) {
return(body_matrix)
}
if ("rowname" %in% stub_layout) {
body_matrix <-
cbind(
unname(as.matrix(body[, dt_boxhead_get_var_stub(data = data)])),
body_matrix
)
}
if ("group_label" %in% stub_layout) {
groups_rows_df <-
dt_groups_rows_get(data = data) %>%
dplyr::select(group_id, group_label, row_start)
group_label_matrix <-
dt_stub_df_get(data = data) %>%
dplyr::select(-row_id, -group_label) %>%
dplyr::inner_join(groups_rows_df, by = "group_id") %>%
dplyr::mutate(
row = dplyr::row_number(),
built = dplyr::if_else(row_start != row, "", built_group_label)
) %>%
dplyr::select(built) %>%
as.matrix() %>%
unname()
body_matrix <- cbind(group_label_matrix, body_matrix)
}
body_matrix
}
summary_row_side <- function(data, group_id) {
# Check that `group_id` isn't NULL and that length is exactly 1
if (is.null(group_id) || length(group_id) != 1) {
cli::cli_abort("`group_id` cannot be `NULL` and must be of length 1.")
}
list_of_summaries <- dt_summary_df_get(data = data)
# Obtain the summary data table specific to the group ID and
# then get the "side" attribute value
summary_df <- list_of_summaries$summary_df_display_list[[group_id]]
unique(summary_df[["::side::"]])
}
Try the gt package in your browser
Any scripts or data that you put into this service are public.
gt documentation built on Oct. 7, 2023, 9:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions summary_row_side get_body_component_cell_matrix get_stub_layout get_effective_number_of_columns get_number_of_visible_data_columns stub_group_names_has_column stub_rownames_has_column last_non_na replace_na_groups_rows_df replace_na_groups_df perform_col_merge resolve_secondary_pattern reorder_styles reorder_footnotes get_row_reorder_df perform_text_transforms migrate_unformatted_to_output render_substitutions is_compatible_formatter render_formats rownum_translation colname_to_colnum validate_contexts
#------------------------------------------------------------------------------#
#
# /$$
# | $$
# /$$$$$$ /$$$$$$
# /$$__ $$|_ $$_/
# | $$ \ $$ | $$
# | $$ | $$ | $$ /$$
# | $$$$$$$ | $$$$/
# \____ $$ \___/
# /$$ \ $$
# | $$$$$$/
# \______/
#
# This file is part of the 'rstudio/gt' project.
#
# Copyright (c) 2018-2023 gt authors
#
# For full copyright and license information, please look at
# https://gt.rstudio.com/LICENSE.html
#
#------------------------------------------------------------------------------#
# Define the contexts
all_contexts <- c("html", "latex", "rtf", "word", "default")
missing_val_token <- "::missing_val::"
validate_contexts <- function(contexts) {
if (!all(contexts %in% all_contexts)) {
invalid_contexts <- base::setdiff(contexts, all_contexts)
cli::cli_abort(c(
"All output contexts must be in the set of supported contexts.",
"*" = "Supported: {paste0(all_contexts, collapse = ', ')}",
"*" = "Invalid: {paste0(invalid_contexts, collapse = ', ')}"
))
}
}
# Utility function to generate column numbers from column names;
# used in: `resolve_footnotes_styles()`
colname_to_colnum <- function(
data,
colname,
missing_is_zero = FALSE
) {
vars_default <- dt_boxhead_get_vars_default(data = data)
result <- match(colname, vars_default)
if (missing_is_zero) {
result[is.na(result)] <- 0L
}
result
}
# Utility function to generate finalized row numbers;
# used in: `resolve_footnotes_styles()`
rownum_translation <- function(body, rownum_start) {
rownum_final <- c()
for (rownum_s in rownum_start) {
rownum_final <-
c(
rownum_final,
which(as.numeric(rownames(body)) == rownum_s)
)
}
rownum_final
}
#' Render any formatting directives available in the `formats` list
#'
#' @noRd
render_formats <- function(data, context) {
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
formats <- dt_formats_get(data = data)
# Render input data to output data where formatting is specified
for (fmt in formats) {
# Determine if the formatting function has a function relevant to
# the context; if not, use the `default` function (which should
# always be present)
if (context %in% names(fmt$func)) {
eval_func <- context
} else {
eval_func <- "default"
}
# Obtain compatibility information for the formatting function
compat <- fmt$compat
# Get the rows to which the formatting should be constrained
rows <- fmt$rows
for (col in fmt[["cols"]]) {
# Perform rendering but only do so if the column is present
if (
col %in% colnames(data_tbl) &&
is_compatible_formatter(
table = data_tbl,
column = col,
rows = rows,
compat = compat
)
) {
# Omit rows that are not present in the `data_tbl` object
rows <- base::intersect(seq_len(nrow(data_tbl)), rows)
result <- fmt$func[[eval_func]](data_tbl[[col]][rows])
# If any of the resulting output is `NA`, that means we want
# to NOT make changes to those particular cells' output
# (i.e. inherit the results of the previous formatter).
body[[col]][rows][!is.na(result)] <- stats::na.omit(result)
}
}
}
dt_body_set(data = data, body = body)
}
is_compatible_formatter <- function(table, column, rows, compat) {
if (is.null(compat)) {
return(TRUE)
}
inherits(table[[column]][rows], compat)
}
#' Render any formatting directives available in the `substitutions` list
#'
#' @noRd
render_substitutions <- function(
data,
context
) {
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
substitutions <- dt_substitutions_get(data = data)
# Render input data to output data where formatting
# is specified
for (subst in substitutions) {
# Determine if the formatter has a function relevant
# to the context; if not, use the `default` function
# (which should always be present)
if (context %in% names(subst$func)) {
eval_func <- context
} else {
eval_func <- "default"
}
for (col in subst[["cols"]]) {
# Perform rendering but only do so if the column is present
if (col %in% colnames(data_tbl)) {
result <- subst$func[[eval_func]](data_tbl[[col]][subst$rows])
# If any of the resulting output is `NA`, that
# means we want to NOT make changes to those
# particular cells' output (i.e. inherit the
# results of the previous substitution).
body[[col]][subst$rows][!is.na(result)] <- stats::na.omit(result)
}
}
}
data <- dt_body_set(data = data, body = body)
data
}
# Move input data cells to `body` that didn't have any rendering applied
# during the `render_formats()` call
migrate_unformatted_to_output <- function(data, context) {
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
for (colname in colnames(body)) {
row_index <- is.na(body[[colname]])
if (inherits(data_tbl[[colname]], "list")) {
# Use `lapply()` so that all values could be treated independently
body[[colname]][row_index] <-
lapply(
data_tbl[[colname]][row_index],
FUN = function(x) {
if (is.numeric(x)) {
x <-
format(
x,
drop0trailing = FALSE,
trim = TRUE,
justify = "none"
)
}
x <- tidy_gsub(x, "\\s+$", "")
x <- process_text(x, context = context)
x <- paste(x, collapse = ", ")
x
}
)
} else {
# No `lapply()` used: all values will be treated cohesively
vals <- data_tbl[[colname]][row_index]
if (is.numeric(vals)) {
vals <-
format(
vals,
drop0trailing = FALSE,
trim = TRUE,
justify = "none"
)
}
if (is.factor(vals)) {
vals <- as.character(vals)
}
body[[colname]][row_index] <- process_text(text = vals, context = context)
}
}
dt_body_set(data = data, body = body)
}
#' Perform any text transformations
#'
#' @noRd
perform_text_transforms <- function(data) {
transforms <- dt_transforms_get(data = data)
for (transform in transforms) {
data <-
text_transform_at_location(
loc = transform$resolved,
data = data,
fn = transform$fn
)
}
data
}
#' Obtain a reordering df for the data rows
#'
#' @noRd
get_row_reorder_df <- function(groups, stub_df) {
# If there are no group, there there is no reordering
# so just return a data frame where the starting row
# indices match the final row indices
if (length(groups) == 0) {
indices <- seq_len(nrow(stub_df))
return(
dplyr::tibble(
rownum_start = indices,
rownum_final = indices
)
)
}
indices <- lapply(stub_df$group_id, `%in%`, x = groups)
indices <- lapply(indices, which)
indices <- unlist(indices)
indices <- order(indices)
dplyr::tibble(
rownum_start = seq_along(indices),
rownum_final = indices
)
}
# Function to recode the `rownum` value in the footnotes table
reorder_footnotes <- function(data) {
stub_df <- dt_stub_df_get(data = data)
footnotes_tbl <- dt_footnotes_get(data = data)
rownum_final <- as.numeric(stub_df$rownum_i)
for (i in seq_len(nrow(footnotes_tbl))) {
if (
!is.na(footnotes_tbl[i, ][["rownum"]]) &&
footnotes_tbl[i, ][["locname"]] %in% c("data", "stub")
) {
footnotes_tbl[i, ][["rownum"]] <-
which(rownum_final == footnotes_tbl[i, ][["rownum"]])
}
}
dt_footnotes_set(data = data, footnotes = footnotes_tbl)
}
# Function to recode the `rownum` value in the styles table
reorder_styles <- function(data) {
stub_df <- dt_stub_df_get(data = data)
styles_tbl <- dt_styles_get(data = data)
rownum_final <- as.numeric(stub_df[, "rownum_i", drop = TRUE])
sz <- nrow(styles_tbl)
tmp_rownum <- vector("integer", sz)
tmp_mask <- vector("logical", sz)
for (i in seq_len(sz)) {
if (
!is.na(styles_tbl$rownum[i]) &&
!grepl("summary_cells", styles_tbl$locname[i])
) {
tmp_mask[i] <- TRUE
tmp_rownum[i] <- which(rownum_final == styles_tbl$rownum[i])
}
}
final_rownum <- styles_tbl$rownum
final_rownum[tmp_mask] <- tmp_rownum[tmp_mask]
styles_tbl$rownum <- final_rownum
dt_styles_set(data = data, styles = styles_tbl)
}
resolve_secondary_pattern <- function(x) {
#
# Preprocessing
#
x <- gsub("<br>", "[[br]]", x, fixed = TRUE)
while (grepl("<<.*?>>", x)) {
m <- gregexpr("<<[^<]*?>>", x, perl = TRUE)
matched <- unlist(regmatches(x, m))[1]
m_start <- as.integer(m[[1]])
m_length <- attr(m[[1]], "match.length")
if (grepl(missing_val_token, matched)) {
# Remove `matched` text from `x`
x <-
paste0(
substr(x, 0, m_start - 1L),
substr(x, m_start + m_length, 100000)
)
} else {
# Remove `<<` and `>>` from `matched` and insert back into `x`
matched_trimmed <- gsub("^<<|>>$", "", matched)
x <-
paste0(
substr(x, 0, m_start - 1L),
matched_trimmed,
substr(x, m_start + m_length, 100000)
)
}
}
#
# Postprocessing
#
x <- gsub("[[br]]", "<br>", x, fixed = TRUE)
x
}
#' Perform merging of column contents
#'
#' This merges column content together with a pattern and possibly with a `type`
#' that specifies additional operations
#'
#' @noRd
perform_col_merge <- function(data, context) {
col_merge <- dt_col_merge_get(data = data)
body <- dt_body_get(data = data)
data_tbl <- dt_data_get(data = data)
if (length(col_merge) == 0) {
return(data)
}
for (i in seq_along(col_merge)) {
type <- col_merge[[i]]$type
if (!(type %in% c("merge", "merge_range", "merge_uncert", "merge_n_pct"))) {
cli::cli_abort("Unknown `type` supplied.")
}
if (type == "merge") {
#
# The `cols_merge()` formatting case
#
mutated_column <- col_merge[[i]]$vars[1]
columns <- col_merge[[i]][["vars"]]
rows <- col_merge[[i]][["rows"]]
pattern <- col_merge[[i]][["pattern"]]
glue_src_na_data <- lapply(as.list(data_tbl[rows, columns]), FUN = is.na)
glue_src_data <- as.list(body[rows, columns])
glue_src_data <-
lapply(
seq_along(glue_src_data),
FUN = function(x) {
# The source data (and 'source data' here means data that's already
# been formatted and converted to `character`) having a character
# `"NA"` value signals that the value should *probably* be treated
# as missing (we are relatively certain it wasn't modified by
# `sub_missing()`, a case where we consider the value *not* to be
# missing because it was handled later) but we also want to
# corroborate that with the original data values (checking for true
# missing data there)
missing_cond <- glue_src_data[[x]] == "NA" & glue_src_na_data[[x]]
missing_cond[is.na(missing_cond)] <- TRUE
glue_src_data[[x]][missing_cond] <- missing_val_token
glue_src_data[[x]]
}
)
glue_src_data <- stats::setNames(glue_src_data, seq_len(length(glue_src_data)))
glued_cols <- as.character(glue_gt(glue_src_data, pattern))
if (grepl("<<.*?>>", pattern)) {
glued_cols <-
vapply(
glued_cols,
FUN.VALUE = character(1),
USE.NAMES = FALSE,
FUN = resolve_secondary_pattern
)
glued_cols <- gsub("<<|>>", "", glued_cols)
}
glued_cols <- gsub(missing_val_token, "NA", glued_cols, fixed = TRUE)
body[rows, mutated_column] <- glued_cols
} else if (type == "merge_n_pct") {
#
# The `cols_merge_n_pct()` formatting case
#
mutated_column <- col_merge[[i]][["vars"]][1]
second_column <- col_merge[[i]][["vars"]][2]
rows <- col_merge[[i]][["rows"]]
# This is a fixed pattern
pattern <- "{1} ({2})"
# Determine rows where NA values exist, and, those rows where
# `0` is the value in the `mutated_column` (we don't want to
# include a zero percentage value in parentheses)
na_1_rows <- is.na(data_tbl[[mutated_column]])
na_2_rows <- is.na(data_tbl[[second_column]])
zero_rows <- data_tbl[[mutated_column]] == 0
zero_rows[is.na(zero_rows)] <- FALSE
zero_rows_idx <- which(zero_rows)
# An `NA` value in either column should exclude that row from
# processing via `glue_gt()`
rows_to_format_idx <- which(!(na_1_rows | na_2_rows))
rows_to_format_idx <- base::setdiff(rows_to_format_idx, zero_rows_idx)
rows_to_format_idx <- base::intersect(rows_to_format_idx, rows)
body[rows_to_format_idx, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body[[mutated_column]][rows_to_format_idx],
"2" = body[[second_column]][rows_to_format_idx]
),
pattern
)
)
} else if (type == "merge_uncert" && length(col_merge[[i]]$vars) == 3) {
#
# The `cols_merge_uncert()` case where lower and upper certainties
# were provided as input columns
#
mutated_column <- col_merge[[i]][["vars"]][1]
lu_column <- col_merge[[i]][["vars"]][2]
uu_column <- col_merge[[i]][["vars"]][3]
rows <- col_merge[[i]][["rows"]]
pattern_equal <- col_merge[[i]][["pattern"]]
sep <- col_merge[[i]][["sep"]]
# Transform the separator text depending on specific
# inputs and the `context`
sep <- context_dash_mark(sep, context = context)
sep <- context_plusminus_mark(sep, context = context)
if (context == "html") {
pattern_unequal <-
paste0(
"<<1>><span style=\"",
"display:inline-block;",
"line-height:1em;",
"text-align:right;",
"font-size:60%;",
"vertical-align:-0.25em;",
"margin-left:0.1em;",
"\">",
"+<<3>><br>",
context_minus_mark(context = context), "<<2>>",
"</span>"
)
} else if (context == "latex") {
pattern_unequal <- "$<<1>>^{+<<3>>}_{-<<2>>}$"
} else if (context == "rtf") {
pattern_unequal <- "<<1>>(+<<3>>, -<<2>>)"
}
# Determine rows where NA values exist
na_1_rows <- is.na(data_tbl[[mutated_column]])
na_lu_rows <- is.na(data_tbl[[lu_column]])
na_uu_rows <- is.na(data_tbl[[uu_column]])
na_lu_or_uu <- na_lu_rows | na_uu_rows
na_lu_and_uu <- na_lu_rows & na_uu_rows
lu_equals_uu <- data_tbl[[lu_column]] == data_tbl[[uu_column]] & !na_lu_or_uu
rows_to_format_equal <- base::intersect(which(!na_1_rows & lu_equals_uu), rows)
rows_to_format_unequal <- base::intersect(which(!na_1_rows & !na_lu_and_uu & !lu_equals_uu), rows)
body[rows_to_format_equal, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body[[mutated_column]][rows_to_format_equal],
"2" = body[[lu_column]][rows_to_format_equal],
"sep" = sep
),
pattern_equal
)
)
body[rows_to_format_unequal, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body[[mutated_column]][rows_to_format_unequal],
"2" = body[[lu_column]][rows_to_format_unequal],
"3" = body[[uu_column]][rows_to_format_unequal]
),
pattern_unequal,
.open = "<<",
.close = ">>"
)
)
} else {
#
# The `cols_merge_range()` and `cols_merge_uncert()` (standard
# uncertainties) formatting cases
#
mutated_column <- col_merge[[i]][["vars"]][1]
second_column <- col_merge[[i]][["vars"]][2]
rows <- col_merge[[i]][["rows"]]
pattern <- col_merge[[i]][["pattern"]]
sep <- col_merge[[i]][["sep"]]
# Replace any fullwidth tilde characters (the range separator in
# the 'ja' locale) with standard `~` in the LaTeX rendering context
if (grepl("\UFF5E", sep) && context == "latex") {
sep <- gsub("\UFF5E", "~", sep)
}
# Transform the separator text depending on specific
# inputs and the `context`
sep <- context_dash_mark(sep, context = context)
sep <- context_plusminus_mark(sep, context = context)
# Determine rows where NA values exist
na_1_rows <- is.na(data_tbl[[mutated_column]])
na_2_rows <- is.na(data_tbl[[second_column]])
if (type == "merge_range") {
rows_to_format <- base::intersect(which(!(na_1_rows & na_2_rows)), rows)
} else if (type == "merge_uncert") {
rows_to_format <- base::intersect(which(!(na_1_rows | na_2_rows)), rows)
}
body_1_vals <- body[[mutated_column]][rows_to_format]
body_1_vals[body_1_vals == "<br />"] <- ""
body_2_vals <- body[[second_column]][rows_to_format]
body_2_vals[body_2_vals == "<br />"] <- ""
body[rows_to_format, mutated_column] <-
as.character(
glue_gt(
list(
"1" = body_1_vals,
"2" = body_2_vals,
"sep" = sep
),
pattern
)
)
}
}
dt_body_set(data = data, body = body)
}
#' Suitably replace `NA` values in the `groups_df` data frame
#'
#' @param groups_df The `groups_df` data frame.
#' @param others_group The `others_group` vector.
#' @noRd
replace_na_groups_df <- function(groups_df, others_group) {
if (nrow(groups_df) > 0) {
groups_df[is.na(groups_df[, "group_id"]), "group_id"] <- others_group
}
groups_df
}
#' Suitably replace `NA` values in the `groups_rows_df` data frame
#'
#' @param groups_rows_df The `groups_rows_df` data frame.
#' @param others_group The `others_group` vector.
#' @noRd
replace_na_groups_rows_df <- function(groups_rows_df, others_group) {
if (nrow(groups_rows_df) > 0) {
groups_rows_df[
is.na(groups_rows_df[, "group"]),
c("group", "group_label")] <- others_group
}
groups_rows_df
}
last_non_na <- function(vect) {
# Retrieve last non-NA value
positions <- which(!is.na(vect))
if (length(positions) == 0) {
return(NA_character_)
} else {
return(as.character(vect[max(positions)]))
}
}
# Determine whether the table should have row labels
# set within a column in the stub
stub_rownames_has_column <- function(data) {
isTRUE("row_id" %in% dt_stub_components(data = data))
}
# Determine whether the table should have row group labels
# set within a column in the stub
stub_group_names_has_column <- function(data) {
# If there aren't any row groups then the result is always FALSE
if (nrow(dt_groups_rows_get(data = data)) < 1) {
return(FALSE)
}
# Given that there are row groups, we need to look at the option
# `row_group_as_column` to determine whether they populate a column
# located in the stub; if set as TRUE then that's the return value
dt_options_get_value(data = data, option = "row_group_as_column")
}
# Get the number of columns for the visible (not hidden) data; this
# excludes the number of columns required for the table stub
get_number_of_visible_data_columns <- function(data) {
length(dt_boxhead_get_vars_default(data = data))
}
get_effective_number_of_columns <- function(data) {
# Check if the table has been built, return an error if that's not the case
if (!dt_has_built(data = data)) {
cli::cli_abort(
"The `get_effective_number_of_columns()` function can only be used on
gt objects that have tables 'built'."
)
}
# Obtain the number of visible columns in the built table
n_data_cols <- get_number_of_visible_data_columns(data = data)
n_data_cols + length(get_stub_layout(data = data))
}
get_stub_layout <- function(data) {
# Determine which stub components are potentially present as columns
stub_rownames_is_column <- stub_rownames_has_column(data = data)
stub_groupnames_is_column <- stub_group_names_has_column(data = data)
# Get the potential total number of columns in the table stub
n_stub_cols <- stub_rownames_is_column + stub_groupnames_is_column
# Resolve the layout of the stub (i.e., the roles of columns if present)
if (n_stub_cols == 0) {
# If summary rows are present, we will use the `rowname` column
# for the summary row labels
if (dt_summary_exists(data = data)) {
return("rowname")
} else {
return(NULL)
}
} else {
c(
if (stub_groupnames_is_column) "group_label",
if (stub_rownames_is_column) "rowname"
)
}
}
# Get a matrix of all body cells
get_body_component_cell_matrix <- function(data) {
body <- dt_body_get(data = data)
stub_layout <- get_stub_layout(data = data)
default_vars <- dt_boxhead_get_vars_default(data = data)
body_matrix <- unname(as.matrix(body[, default_vars]))
if (length(stub_layout) == 0) {
return(body_matrix)
}
if ("rowname" %in% stub_layout) {
body_matrix <-
cbind(
unname(as.matrix(body[, dt_boxhead_get_var_stub(data = data)])),
body_matrix
)
}
if ("group_label" %in% stub_layout) {
groups_rows_df <-
dt_groups_rows_get(data = data) %>%
dplyr::select(group_id, group_label, row_start)
group_label_matrix <-
dt_stub_df_get(data = data) %>%
dplyr::select(-row_id, -group_label) %>%
dplyr::inner_join(groups_rows_df, by = "group_id") %>%
dplyr::mutate(
row = dplyr::row_number(),
built = dplyr::if_else(row_start != row, "", built_group_label)
) %>%
dplyr::select(built) %>%
as.matrix() %>%
unname()
body_matrix <- cbind(group_label_matrix, body_matrix)
}
body_matrix
}
summary_row_side <- function(data, group_id) {
# Check that `group_id` isn't NULL and that length is exactly 1
if (is.null(group_id) || length(group_id) != 1) {
cli::cli_abort("`group_id` cannot be `NULL` and must be of length 1.")
}
list_of_summaries <- dt_summary_df_get(data = data)
# Obtain the summary data table specific to the group ID and
# then get the "side" attribute value
summary_df <- list_of_summaries$summary_df_display_list[[group_id]]
unique(summary_df[["::side::"]])
}
Try the gt package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.