Nothing
#------------------------------------------------------------------------------#
#
# /$$
# | $$
# /$$$$$$ /$$$$$$
# /$$__ $$|_ $$_/
# | $$ \ $$ | $$
# | $$ | $$ | $$ /$$
# | $$$$$$$ | $$$$/
# \____ $$ \___/
# /$$ \ $$
# | $$$$$$/
# \______/
#
# 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
#
#------------------------------------------------------------------------------#
# Create a simple LaTeX group by surrounding a statement with curly braces
latex_group <- function(...) {
paste0("{", ..., "}")
}
# Get a vector of LaTeX packages to use as table dependencies
latex_packages <- function() {
getOption("gt.latex_packages")
}
# Transform a footnote mark to a LaTeX representation as a superscript
footnote_mark_to_latex <- function(
data,
mark,
location = c("ref", "ftr")
) {
location <- match.arg(location)
if (length(mark) == 1 && is.na(mark)) {
return("")
}
spec <- get_footnote_spec_by_location(data = data, location = location)
if (is.null(spec)) {
spec <- "^i"
}
if (grepl("\\.", spec)) mark <- paste0(mark, ".")
if (grepl("b", spec)) mark <- paste0("\\textbf{", mark, "}")
if (grepl("i", spec)) mark <- paste0("\\textit{", mark, "}")
if (grepl("\\(|\\[", spec)) mark <- paste0("(", mark)
if (grepl("\\)|\\]", spec)) mark <- paste0(mark, ")")
if (grepl("\\^", spec)) {
mark <- paste0("\\textsuperscript{", mark, "}")
}
mark
}
#' @noRd
latex_body_row <- function(content, type) {
if (type == "row") {
return(paste(paste(content, collapse = " & "), "\\\\ \n"))
} else if (type == "group") {
return(paste(paste(content, collapse = " & "), "\\\\ \n"))
}
}
#' @noRd
latex_heading_row <- function(content) {
paste0(
paste(paste(content, collapse = " & "), "\\\\ \n"),
"\\midrule\\addlinespace[2.5pt]\n",
collapse = ""
)
}
#' @noRd
latex_group_row <- function(
group_name,
n_cols,
top_border = TRUE,
bottom_border = TRUE
) {
paste0(
ifelse(top_border, "\\midrule\\addlinespace[2.5pt]\n", ""),
"\\multicolumn{", n_cols, "}{l}{", group_name,
"} \\\\ \n",
ifelse(bottom_border, "\\midrule\\addlinespace[2.5pt]\n", ""),
collapse = ""
)
}
#' @noRd
create_table_start_l <- function(data) {
# Get vector representation of stub layout
stub_layout <- get_stub_layout(data = data)
boxh_df <- dt_boxhead_get(data = data)
# Get default alignments for body columns
col_alignment <- dt_boxhead_get_vars_align_default(data = data)
if (length(stub_layout) > 0) {
col_alignment <- c(rep("left", length(stub_layout)), col_alignment)
}
# Determine if there are any footnotes or source notes; if any,
# add a `\setlength` command that will pull up the minipage environment
# for the footnotes block
if (
nrow(dt_footnotes_get(data = data)) > 0 ||
length(dt_source_notes_get(data = data)) > 0
) {
longtable_post_length <- "\\setlength{\\LTpost}{0mm}\n"
} else {
longtable_post_length <- ""
}
# Obtain widths for each visible column label
col_widths <-
unlist(
dplyr::pull(
dplyr::arrange(
dplyr::filter(boxh_df, type %in% c("default", "stub")),
dplyr::desc(type)
),
column_width
)
)
# Generate the column definitions for visible columns
# these can either be simple `l`, `c`, `r` directive if a width isn't set
# for a column, or, use `p{<width>}` statements with leading `>{...}`
# specifiers that should have one of the following:
# - `>{\raggedright\arraybackslash}` <- left alignment
# - `>{\raggedleft\arraybackslash}` <- right alignment
# - `>{\centering\arraybackslash}` <- center alignment
# the `\arraybackslash` command is used to restore the behavior of the
# `\\` command in the table (all of this uses the CTAN `array` package)
if (!is.null(col_widths)) {
col_defs <- c()
# TODO: check that length of `col_widths` is equal to that
# of `col_alignment`
if ("group_label" %in% stub_layout) {
group_label_width <-
unlist(
dplyr::pull(dplyr::filter(boxh_df, type == "row_group"), column_width)
)
col_widths <- c(group_label_width, col_widths)
}
for (i in seq_along(col_widths)) {
if (col_widths[i] != "") {
align <-
switch(
col_alignment[i],
left = ">{\\raggedright\\arraybackslash}",
right = ">{\\raggedleft\\arraybackslash}",
center = ">{\\centering\\arraybackslash}",
">{\\raggedright\\arraybackslash}"
)
col_defs_i <- paste0(align, "p{", col_widths[i], "}")
} else {
col_defs_i <- substr(col_alignment[i], 1, 1)
}
col_defs <- c(col_defs, col_defs_i)
}
} else {
col_defs <- substr(col_alignment, 1, 1)
}
# Add borders to the right of any columns in the stub
if (length(stub_layout) > 0) {
col_defs[seq_along(stub_layout)] <-
paste0(col_defs[seq_along(stub_layout)], "|")
}
# Generate setup statements for table including default left
# alignments and vertical lines for any stub columns
paste0(
longtable_post_length,
"\\begin{longtable}{",
paste(col_defs, collapse = ""),
"}\n",
collapse = ""
)
}
#' Create the heading component of a table
#'
#' The table heading component contains the title and possibly a subtitle; if
#' there are no heading components defined this function will return an empty
#' string.
#'
#' @noRd
create_heading_component_l <- function(data) {
# If there is no title or heading component, then return an empty string
if (!dt_heading_has_title(data = data)) {
return("")
}
heading <- dt_heading_get(data = data)
footnotes_tbl <- dt_footnotes_get(data = data)
subtitle_defined <- dt_heading_has_subtitle(data = data)
# Get the footnote marks for the title
if ("title" %in% footnotes_tbl$locname) {
footnote_title_marks <-
coalesce_marks(
fn_tbl = footnotes_tbl,
locname = "title"
)
footnote_title_marks <-
footnote_mark_to_latex(
data = data,
mark = footnote_title_marks$fs_id_c
)
} else {
footnote_title_marks <- ""
}
# Get the footnote marks for the subtitle
if (subtitle_defined && "subtitle" %in% footnotes_tbl$locname) {
footnote_subtitle_marks <-
coalesce_marks(
fn_tbl = footnotes_tbl,
locname = "subtitle"
)
footnote_subtitle_marks <-
footnote_mark_to_latex(
data = data,
mark = footnote_subtitle_marks$fs_id_c
)
} else {
footnote_subtitle_marks <- ""
}
title_row <- latex_group("\\large ", heading$title, footnote_title_marks)
if (subtitle_defined) {
subtitle_row <-
paste0(
" \\\\ \n",
latex_group("\\small ", heading$subtitle, footnote_subtitle_marks)
)
} else {
subtitle_row <- ""
}
paste_between(
paste0(title_row, subtitle_row),
x_2 = c("\\caption*{\n", "\n} \\\\ \n")
)
}
#' Create the columns component of a table
#'
#' @noRd
create_columns_component_l <- function(data) {
# Get vector representation of stub layout
stub_layout <- get_stub_layout(data = data)
# Determine the finalized number of spanner rows
spanner_row_count <-
dt_spanners_matrix_height(
data = data,
omit_columns_row = TRUE
)
# Get the column headings
headings_vars <- dt_boxhead_get_vars_default(data = data)
headings_labels <- dt_boxhead_get_vars_labels_default(data = data)
# If there is a stub then modify the `headings_vars` and `headings_labels`
if (length(stub_layout) > 0) {
stubh <- dt_stubhead_get(data = data)
headings_vars <- prepend_vec(headings_vars, "::stub")
stub_label <- ifelse(length(stubh$label) > 0, stubh$label, "")
if (length(stub_layout) > 0) {
stub_label <-
paste0("\\multicolumn{", length(stub_layout), "}{l}{", stub_label, "}")
}
headings_labels <- prepend_vec(headings_labels, stub_label)
}
table_col_headings <-
paste0(latex_heading_row(content = headings_labels), collapse = "")
if (spanner_row_count > 0) {
table_col_spanners <- c()
spanners <-
dt_spanners_print_matrix(
data = data,
include_hidden = FALSE,
omit_columns_row = TRUE
)
spanner_ids <-
dt_spanners_print_matrix(
data = data,
include_hidden = FALSE,
ids = TRUE,
omit_columns_row = TRUE
)
if (length(stub_layout) > 0) {
stub_matrix <- matrix(nrow = nrow(spanners), ncol = length(stub_layout))
spanners <- cbind(stub_matrix, spanners)
spanner_ids <- cbind(stub_matrix, spanner_ids)
}
for (i in seq_len(nrow(spanners))) {
spanners_i <- spanners[i, ]
spanner_ids_i <- spanner_ids[i, ]
spanners_rle <- unclass(rle(spanner_ids_i))
# We need a parallel vector of spanner labels and this could
# be part of the `spanners_rle` list
spanners_rle$labels <- spanners_i[cumsum(spanners_rle$lengths)]
begins <- (cumsum(utils::head(c(0, spanners_rle$lengths), -1)) + 1)[!is.na(spanners_rle$values)]
ends <- cumsum(spanners_rle$lengths)[!is.na(spanners_rle$values)]
cmidrule <- paste0("\\cmidrule(lr){", begins, "-", ends, "}")
is_spanner_na <- is.na(spanners_rle$values)
is_spanner_single <- spanners_rle$lengths == 1
multicol <-
ifelse(
is_spanner_na, "",
ifelse(
is_spanner_single, spanners_rle$labels,
sprintf(
"\\multicolumn{%d}{c}{%s}", spanners_rle$lengths, spanners_rle$labels
)
)
)
# If there is a stub we need to tweak the spanners row with a blank
# multicolumn statement that's the same width as that in the columns
# row; this is to prevent the automatic vertical line that would otherwise
# appear here
if (length(stub_layout) > 0) {
multicol <-
c(
paste0("\\multicolumn{", length(stub_layout), "}{l}{}"),
multicol[-seq_along(stub_layout)]
)
}
multicol <- paste0(paste(multicol, collapse = " & "), " \\\\ \n")
cmidrule <- paste0(paste(cmidrule, collapse = " "), "\n")
col_spanners_i <- paste0(multicol, cmidrule, collapse = "")
table_col_spanners <- c(table_col_spanners, col_spanners_i)
}
} else {
table_col_spanners <- ""
}
paste0(
"\\toprule\n",
paste0(table_col_spanners, collapse = ""),
table_col_headings
)
}
#' @noRd
create_body_component_l <- function(data) {
summaries_present <- dt_summary_exists(data = data)
list_of_summaries <- dt_summary_df_get(data = data)
groups_rows_df <- dt_groups_rows_get(data = data)
stub_df <- dt_stub_df_get(data = data)
# Get vector representation of stub layout
stub_layout <- get_stub_layout(data = data)
# Determine if there is a stub column in `stub_layout` and whether we
# have a two-column stub (with the group label on the left side)
has_stub_column <- "rowname" %in% stub_layout
has_two_col_stub <- "group_label" %in% stub_layout
n_cols <- get_effective_number_of_columns(data = data)
# Get a matrix of body cells to render, split into a list of
# character vectors by row, and create a vector of LaTeX body rows
cell_matrix <- get_body_component_cell_matrix(data = data)
row_splits_body <- split_row_content(cell_matrix)
# Get the number of rows in the body
n_rows <- nrow(cell_matrix)
if ("group_label" %in% stub_layout) {
for (i in seq_len(nrow(groups_rows_df))) {
row_splits_body[[groups_rows_df$row_start[i]]][1] <-
groups_rows_df$group_label[i]
}
}
# Insert indentation where necessary
if (has_stub_column && any(!is.na(stub_df$indent))) {
stub_indent_length <-
dt_options_get_value(
data = data,
option = "stub_indent_length"
)
indent_length_px <- as.integer(gsub("px", "", stub_indent_length))
indent_length_pt <- indent_length_px * 0.75
row_label_col <- which(stub_layout == "rowname")
lapply(
seq_len(n_rows),
FUN = function(x) {
indent <- as.integer(stub_df[x, ][["indent"]])
if (!is.na(indent)) {
row_splits_body[[x]][row_label_col] <<-
paste0(
"\\hspace*{", indent_length_pt * indent, "px} ",
row_splits_body[[x]][row_label_col]
)
}
}
)
}
body_rows <-
create_body_rows_l(
data = data,
row_splits_body = row_splits_body
)
# Replace an NA group with a small amount of vertical space
if (any(is.na(groups_rows_df$group_label))) {
groups_rows_df <-
dplyr::mutate(
groups_rows_df,
group_label = ifelse(
is.na(group_label), "\\vspace*{-5mm}", group_label
)
)
}
current_group_id <- character(0)
body_rows <-
lapply(
seq_len(n_rows),
function(i) {
body_section <- list()
group_info <-
groups_rows_df[i >= groups_rows_df$row_start & i <= groups_rows_df$row_end, ]
if (nrow(group_info) == 0) {
group_info <- NULL
}
group_id <- group_info[["group_id"]]
group_label <- group_info[["group_label"]]
group_row_start <- group_info[["row_start"]]
group_row_end <- group_info[["row_end"]]
group_has_summary_rows <- group_info[["has_summary_rows"]]
group_summary_row_side <- group_info[["summary_row_side"]]
if (!is.null(group_id)) current_group_id <<- group_id
# Is there a group heading row (dedicated row w/ group label) at `i`?
group_heading_row_at_i <-
!is.null(group_id) &&
!has_two_col_stub &&
group_row_start == i
# Is this the first row of a group?
group_start <- !is.null(group_info) && group_row_start == i
# Insert a horizontal line if this is the beginning of a new row
# group and there is a two-column stub
if (group_start && has_two_col_stub && i != 1) {
body_section <-
append(body_section, "\\midrule\\addlinespace[2.5pt]\n")
}
#
# Create a group heading row
#
if (group_heading_row_at_i) {
group_heading_row <-
latex_group_row(
group_name = group_label,
n_cols = n_cols,
top_border = i != 1,
bottom_border = TRUE
)
body_section <- append(body_section, list(group_heading_row))
}
#
# Get groupwise summary rows (for either top or bottom of group)
#
if (
summaries_present &&
!is.null(group_has_summary_rows) &&
group_has_summary_rows &&
(
i %in% groups_rows_df$row_start &&
!is.null(group_summary_row_side) &&
!is.na(group_summary_row_side) &&
group_summary_row_side == "top"
) ||
(
i %in% groups_rows_df$row_end &&
!is.null(group_summary_row_side) &&
!is.na(group_summary_row_side) &&
group_summary_row_side == "bottom"
)
) {
summary_section <-
summary_rows_for_group_l(
data = data,
group_id = group_id,
side_group_summary = group_summary_row_side
)
} else {
summary_section <- NULL
}
body_row <- body_rows[i]
if (!is.null(summary_section) && group_summary_row_side == "top") {
if (!has_two_col_stub) {
summary_section <- paste0(summary_section, summary_h_border)
}
body_section <- append(body_section, summary_section)
}
body_section <- append(body_section, list(body_row))
if (!is.null(summary_section) && group_summary_row_side == "bottom") {
if (!(has_stub_column && has_two_col_stub)) {
summary_section <- paste0(summary_h_border, summary_section)
}
body_section <- append(body_section, summary_section)
}
# In a very particular case, we need to hoist the group label to the
# first row of summary labels (at the top of a row group where there
# is a two-column stub)
if (
has_stub_column &&
has_two_col_stub &&
group_row_start == i &&
!is.null(summary_section) &&
group_summary_row_side == "top" &&
length(body_section) > 1
) {
body_row_idx <- length(body_section)
summary_idx <- body_row_idx - 1
group_name_fragment <- gsub("(^.*? & ).*", "\\1", body_section[[body_row_idx]])
body_section[[summary_idx]] <- sub("^.*? & ", "", body_section[[summary_idx]])
body_section[[summary_idx]] <- paste0(group_name_fragment, body_section[[summary_idx]])
body_section[[body_row_idx]] <- sub("^.*? & ", " & ", body_section[[body_row_idx]])
}
body_section
}
)
body_rows <- unlist(body_rows)
#
# Add grand summary rows
#
if (
summaries_present &&
grand_summary_col %in% names(list_of_summaries$summary_df_display_list)
) {
side <- summary_row_side(data = data, group_id = grand_summary_col)
grand_summary_section <-
summary_rows_for_group_l(
data = data,
group_id = grand_summary_col,
side_grand_summary = side
)
if (side == "top") {
body_rows <- c(grand_summary_section, body_rows)
} else {
body_rows <- c(body_rows, grand_summary_section)
}
}
paste(body_rows, collapse = "")
}
summary_rows_for_group_l <- function(
data,
group_id,
side_group_summary = "bottom",
side_grand_summary = "bottom"
) {
# 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 all of the visible (`"default"`), non-stub column names
# for the table from the `boxh` object
default_vars <- dt_boxhead_get_vars_default(data = data)
stub_layout <- get_stub_layout(data = data)
stub_is_2 <- length(stub_layout) > 1
summary_row_lines <- list()
# In the below conditions
# - `grand_summary_col` is a global variable (`"::GRAND_SUMMARY"`, assigned
# in `dt_summary.R`)
# - `group_id` might be passed in as NA when there are unnamed groups (this
# can happen usually when using `tab_row_group()` to build these row groups)
# and you cannot create summary rows for unnamed groups
if (is.na(group_id)) {
return(summary_row_lines)
} else if (
group_id %in% names(list_of_summaries$summary_df_display_list) &&
group_id != grand_summary_col
) {
summary_row_type <- "group"
} else if (group_id == grand_summary_col) {
summary_row_type <- "grand"
} else {
return(summary_row_lines)
}
# Obtain the summary data table specific to the group ID and
# select the column named `rowname` and all of the visible columns
summary_df <-
dplyr::select(
list_of_summaries$summary_df_display_list[[group_id]],
dplyr::all_of(rowname_col_private),
dplyr::all_of(default_vars)
)
row_splits_summary <- split_row_content(summary_df)
if (stub_is_2) {
row_splits_summary <-
lapply(
row_splits_summary,
function(x) {
x <- c("", x)
x[1:2] <- paste0("\\multicolumn{1}{l|}{", x[1:2], "}")
x
}
)
}
summary_rows <-
paste0(
vapply(
row_splits_summary,
FUN.VALUE = character(1),
latex_body_row,
type = "row"
),
collapse = ""
)
if (summary_row_type != "grand") {
summary_rows <-
paste0(
if (side_group_summary == "top") summary_rows,
if ("group_label" %in% stub_layout && stub_is_2) {
paste0(
"\\cmidrule(l{-0.05em}r){2-",
ncol(summary_df) + 1,
"}\n"
)
},
if (side_group_summary == "bottom") summary_rows
)
}
if (summary_row_type == "grand") {
if (side_grand_summary == "top") {
summary_rows <- paste0(summary_rows, grand_summary_h_border)
} else {
summary_rows <- paste0(grand_summary_h_border, summary_rows)
}
}
summary_rows
}
#' @noRd
create_table_end_l <- function() {
paste0(
"\\bottomrule\n",
"\\end{longtable}\n",
collapse = ""
)
}
#' @noRd
create_footer_component_l <- function(data) {
footnotes_tbl <- dt_footnotes_get(data = data)
source_notes_vec <- dt_source_notes_get(data = data)
# If there are no footnotes or source notes, return an empty string
if (nrow(footnotes_tbl) == 0 && length(source_notes_vec) == 0) {
return("")
}
# Get the multiline and separator options for footnotes and source notes
footnotes_multiline <- dt_options_get_value(data = data, option = "footnotes_multiline")
footnotes_sep <- dt_options_get_value(data = data, option = "footnotes_sep")
source_notes_multiline <- dt_options_get_value(data = data, option = "source_notes_multiline")
source_notes_sep <- dt_options_get_value(data = data, option = "source_notes_sep")
# Create a formatted footnotes string
if (nrow(footnotes_tbl) > 0) {
footnotes_tbl <-
dplyr::distinct(dplyr::select(footnotes_tbl, fs_id, footnotes))
# Create a vector of formatted footnotes
footnotes <-
paste0(
footnote_mark_to_latex(
data = data,
mark = footnotes_tbl[["fs_id"]],
location = "ftr"
),
vapply(
footnotes_tbl[["footnotes"]],
FUN.VALUE = character(1),
FUN = process_text,
context = "latex"
)
)
if (footnotes_multiline) {
footnotes <- paste_right(paste(footnotes, collapse = "\\\\\n"), "\\\\\n")
} else {
footnotes <- paste_right(paste(footnotes, collapse = footnotes_sep), "\\\\\n")
}
} else {
footnotes <- ""
}
# Create a formatted source notes string
if (length(source_notes_vec) > 0) {
if (source_notes_multiline) {
source_notes <- paste_right(paste(source_notes_vec, collapse = "\\\\\n"), "\\\\\n")
} else {
source_notes <- paste_right(paste(source_notes_vec, collapse = source_notes_sep), "\\\\\n")
}
} else {
source_notes <- ""
}
# Create the footer block
paste0(
"\\begin{minipage}{\\linewidth}\n",
paste0(footnotes, source_notes),
"\\end{minipage}\n",
collapse = ""
)
}
# Function to build a vector of `body` rows
create_body_rows_l <- function(
data,
row_splits_body
) {
styles_tbl <- dt_styles_get(data = data)
styles_tbl <- dplyr::filter(styles_tbl, locname %in% c("stub", "data", "row_groups"))
# Obtain all of the visible (`"default"`), non-stub column names
# for the table from the `boxh` object
default_vars <- dt_boxhead_get_vars_default(data = data)
stub_layout <- get_stub_layout(data = data)
stub_is_2 <- length(stub_layout) > 1
if (is.null(stub_layout)) {
vars <- default_vars
} else if (!is.null(stub_layout) && !stub_is_2 && stub_layout == "rowname") {
vars <- c("::stub::", default_vars)
} else if (!is.null(stub_layout) && !stub_is_2 && stub_layout == "group_label") {
vars <- c("::group::", default_vars)
} else if (!is.null(stub_layout) && stub_is_2) {
vars <- c("::group::", "::stub::", default_vars)
}
if ("::group::" %in% vars) {
styles_tbl <- dplyr::mutate(styles_tbl, rownum = round(rownum))
}
body_rows <-
unname(
unlist(
lapply(
seq_len(length(row_splits_body)),
FUN = function(x) {
content <- row_splits_body[[x]]
content_length <- length(content)
styles_tbl_i <- dplyr::filter(styles_tbl, rownum == x)
if (nrow(styles_tbl_i) < 1) {
return(paste(paste(content, collapse = " & "), "\\\\ \n"))
}
for (i in seq_len(content_length)) {
colname_i <- vars[i]
if (
colname_i == "::group::" &&
"row_groups" %in% styles_tbl_i[["locname"]]
) {
styles_tbl_i_col <- dplyr::filter(styles_tbl_i, locname == "row_groups")
styles_i_col <- styles_tbl_i_col[["styles"]]
} else if (
colname_i == "::stub::" &&
"stub" %in% styles_tbl_i[["locname"]]
) {
styles_tbl_i_col <- dplyr::filter(styles_tbl_i, locname == "stub")
styles_i_col <- styles_tbl_i_col[["styles"]]
} else if (
"data" %in% styles_tbl_i[["locname"]] &&
colname_i %in% styles_tbl_i[["colname"]]
) {
styles_tbl_i_col <- dplyr::filter(styles_tbl_i, colname == colname_i)
styles_i_col <- styles_tbl_i_col[["styles"]]
} else {
styles_i_col <- NULL
}
if (!is.null(styles_i_col)) {
# TODO: this only considers the first entry; we need to iterate
# through them since there may be multiple styles set for each
# body cell and that might result in several rows in `styles_tbl_i_col`
# (i.e., length greater than 1 in `styles_i_col`)
styles_i_col_text_color <- styles_i_col[[1]][["cell_text"]][["color"]]
styles_i_col_cell_color <- styles_i_col[[1]][["cell_fill"]][["color"]]
if (
!is.null(styles_i_col[[1]][["cell_text"]][["weight"]]) &&
styles_i_col[[1]][["cell_text"]][["weight"]] == "bold"
) {
content[i] <- paste0("\\textbf{", content[i], "}")
}
if (!is.null(styles_i_col_text_color)) {
content[i] <-
paste0(
"\\textcolor[HTML]{",
gsub("#", "", styles_i_col_text_color, fixed = TRUE),
"}{", content[i], "}"
)
}
if (!is.null(styles_i_col_cell_color)) {
content[i] <-
paste0(
"\\cellcolor[HTML]{",
gsub("#", "", styles_i_col_cell_color, fixed = TRUE),
"}{", content[i], "}"
)
}
}
}
paste(paste(content, collapse = " & "), "\\\\ \n")
}
)
)
)
body_rows
}
# Function to build a vector of `summary` rows in the table body
create_summary_rows_l <- function(
data,
groups_rows_df,
n_rows
) {
list_of_summaries <- dt_summary_df_get(data = data)
if (length(list_of_summaries) < 1) {
return(rep_len("", n_rows))
}
# Get vector representation of stub layout
stub_layout <- get_stub_layout(data = data)
stub_width <- length(stub_layout)
# Obtain all of the visible (`"default"`), non-stub
# column names for the table
default_vars <- dt_boxhead_get_vars_default(data = data)
unname(
unlist(
lapply(
seq_len(n_rows),
FUN = function(x) {
# Determine if body row `x` has a group summary placed after
# it; if not, return an empty string
if (!(x %in% groups_rows_df$row_end)) {
return("")
}
# Obtain the group ID for the group of rows that ends at row `x`;
group_id <-
groups_rows_df[groups_rows_df$row_end == x, "group_id", drop = TRUE]
# Check whether this group has a corresponding entry in
# `list_of_summaries$summary_df_display_list` (i.e., are there
# summary rows for this group?); if not, return an empty string
if (!(group_id %in% names(list_of_summaries$summary_df_display_list))) {
return("")
}
# Obtain the summary data table specific to the group ID and
# select the column named `::rowname::` and all of the visible columns
summary_df <-
dplyr::select(
list_of_summaries$summary_df_display_list[[group_id]],
dplyr::all_of(rowname_col_private),
dplyr::all_of(default_vars)
)
row_splits_summary <- split_row_content(summary_df)
if (stub_width > 1) {
row_splits_summary <-
lapply(
row_splits_summary,
function(x) {
x <- c(rep("", stub_width - 1), x)
x[seq_len(stub_width)] <-
paste0("\\multicolumn{1}{l|}{", x[seq_len(stub_width)], "}")
x
}
)
}
summary_rows <-
paste0(
vapply(
row_splits_summary,
FUN.VALUE = character(1),
latex_body_row,
type = "row"
),
collapse = ""
)
paste0(
if ("group_label" %in% stub_layout && stub_width > 1) {
paste0(
"\\cmidrule(l{-0.05em}r){2-",
ncol(summary_df) + stub_width - 1,
"}"
)
} else {
summary_h_border
},
summary_rows
)
}
)
)
)
}
# Define horizontal border line types for
# summary rows and for grand summary rows
summary_h_border <- "\\midrule \n"
grand_summary_h_border <- "\\midrule \n\\midrule \n"
#' Split data frame or matrix row content into a list structure
#'
#' This function takes any data frame or matrix and creates a list
#' with every component representing a row, each containing a vector
#' with length corresponding to the total number of columns in the
#' finalized table
#'
#' @noRd
split_row_content <- function(x) {
row_content <- as.vector(t(x))
split(row_content, ceiling(seq_along(row_content) / ncol(x)))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.