Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1695 lines (1509 sloc) 55.7 KB
#' Add a table header
#'
#' We can add a table header to the **gt** table with a title and even a
#' subtitle. A table header is an optional table part that is positioned above
#' the column labels. We have the flexibility to use Markdown formatting for the
#' header's title and subtitle. Furthermore, if the table is intended for HTML
#' output, we can use HTML in either of the title or subtitle.
#'
#' @inheritParams fmt_number
#' @param title,subtitle Text to be used in the table title and, optionally, for
#' the table subtitle. We can elect to use the [md()] and [html()] helper
#' functions to style the text as Markdown or to retain HTML elements in the
#' text.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `gtcars` to create a gt table;
#' # add a header part to contain a title
#' # and subtitle
#' tab_1 <-
#' gtcars %>%
#' dplyr::select(mfr, model, msrp) %>%
#' dplyr::slice(1:5) %>%
#' gt() %>%
#' tab_header(
#' title = md("Data listing from **gtcars**"),
#' subtitle = md("`gtcars` is an R dataset")
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_header_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-1
#'
#' @export
tab_header <- function(data,
title,
subtitle = NULL) {
# Perform input object validation
stop_if_not_gt(data = data)
data %>% dt_heading_title_subtitle(title = title, subtitle = subtitle)
}
#' Add a spanner column label
#'
#' Set a spanner column label by mapping it to columns already in the table.
#' This label is placed above one or more column labels, spanning the width of
#' those columns and column labels.
#'
#' @inheritParams fmt_number
#' @param label The text to use for the spanner column label.
#' @param columns The columns to be components of the spanner heading.
#' @param gather An option to move the specified `columns` such that they are
#' unified under the spanner column label. Ordering of the moved-into-place
#' columns will be preserved in all cases.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `gtcars` to create a gt table;
#' # Group several columns related to car
#' # performance under a spanner column
#' # with the label `performance`
#' tab_1 <-
#' gtcars %>%
#' dplyr::select(
#' -mfr, -trim, bdy_style, drivetrain,
#' -drivetrain, -trsmn, -ctry_origin
#' ) %>%
#' dplyr::slice(1:8) %>%
#' gt(rowname_col = "model") %>%
#' tab_spanner(
#' label = "performance",
#' columns = vars(
#' hp, hp_rpm, trq, trq_rpm,
#' mpg_c, mpg_h)
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_spanner_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-2
#'
#' @export
tab_spanner <- function(data,
label,
columns,
gather = TRUE) {
# Perform input object validation
stop_if_not_gt(data = data)
checkmate::assert_character(
label, len = 1, any.missing = FALSE, null.ok = FALSE)
columns <- enquo(columns)
# Get the columns supplied in `columns` as a character vector
column_names <- resolve_vars(var_expr = !!columns, data = data)
data <-
dt_spanners_add(
data = data,
vars = column_names,
spanner_label = label,
gather = gather
)
if (isTRUE(gather) && length(column_names) >= 1) {
# Move columns into place
data <-
data %>%
cols_move(
columns = column_names,
after = column_names[1]
)
}
data
}
#' Create column labels and spanners via delimited names
#'
#' This function will split selected delimited column names such that the first
#' components (LHS) are promoted to being spanner column labels, and the
#' secondary components (RHS) will become the column labels. Please note that
#' reference to individual columns must continue to be the column names from the
#' input table data (which are unique by necessity).
#'
#' If we look to the column names in the `iris` dataset as an example of how
#' `tab_spanner_delim()` might be useful, we find the names `Sepal.Length`,
#' `Sepal.Width`, `Petal.Length`, `Petal.Width`. From this naming system, it's
#' easy to see that the `Sepal` and `Petal` can group together the repeated
#' common `Length` and `Width` values. In your own datasets, we can avoid a
#' lengthy relabeling with [cols_label()] if column names can be fashioned
#' beforehand to contain both the spanner column label and the column label. An
#' additional advantage is that the column names in the input table data remain
#' unique even though there may eventually be repeated column labels in the
#' rendered output table).
#'
#' @inheritParams cols_align
#' @inheritParams tab_spanner
#' @param delim The delimiter to use to split an input column name. The
#' delimiter supplied will be autoescaped for the internal splitting
#' procedure. The first component of the split will become the group name and
#' the second component will be the column label.
#' @param columns An optional vector of column names that this operation should
#' be limited to. The default is to consider all columns in the table.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `iris` to create a gt table; split
#' # any columns that are dot-separated
#' # between column spanner labels (first
#' # part) and column labels (second part)
#' tab_1 <-
#' iris %>%
#' dplyr::group_by(Species) %>%
#' dplyr::slice(1:4) %>%
#' gt() %>%
#' tab_spanner_delim(delim = ".")
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_spanner_delim_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-3
#'
#' @export
tab_spanner_delim <- function(data,
delim,
columns = NULL,
gather = TRUE) {
# Perform input object validation
stop_if_not_gt(data = data)
columns <- enquo(columns)
# Get all of the columns in the dataset
all_cols <- data %>% dt_boxhead_get_vars()
# Get the columns supplied in `columns` as a character vector
columns <- resolve_vars(var_expr = !!columns, data = data)
if (!is.null(columns)) {
colnames <- base::intersect(all_cols, columns)
} else {
colnames <- all_cols
}
if (length(colnames) == 0) {
return(data)
}
colnames_has_delim <- grepl(pattern = delim, x = colnames, fixed = TRUE)
if (any(colnames_has_delim)) {
colnames_with_delim <- colnames[colnames_has_delim]
split_colnames <- strsplit(colnames_with_delim, delim, fixed = TRUE)
spanners <- vapply(split_colnames, `[[`, character(1), 1)
new_labels <-
lapply(split_colnames, `[[`, -1) %>%
vapply(paste0, FUN.VALUE = character(1), collapse = delim)
for (i in seq_along(split_colnames)) {
spanners_i <- spanners[i]
new_labels_i <- new_labels[i]
var_i <- colnames_with_delim[i]
data <-
data %>%
dt_boxhead_edit(var = var_i, column_label = new_labels_i)
}
spanner_var_list <- split(colnames_with_delim, spanners)
for (spanner_label in names(spanner_var_list)) {
data <-
data %>%
dt_spanners_add(
vars = spanner_var_list[[spanner_label]],
spanner_label = spanner_label,
gather = gather
)
}
}
data
}
#' Add a row group to a **gt** table
#'
#' Create a row group with a collection of rows. This requires specification of
#' the rows to be included, either by supplying row labels, row indices, or
#' through use of a select helper function like `starts_with()`.
#'
#' @inheritParams fmt_number
#' @param group The name of the row group. This text will also serve as the row
#' group label.
#' @param rows The rows to be made components of the row group. Can either be a
#' vector of row captions provided in `c()`, a vector of row indices, or a
#' helper function focused on selections. The select helper functions are:
#' [starts_with()], [ends_with()], [contains()], [matches()], [one_of()], and
#' [everything()].
#' @param others An option to set a default row group label for any rows not
#' formally placed in a row group named by `group` in any call of
#' `tab_row_group()`. A separate call to `tab_row_group()` with only a value
#' to `others` is possible and makes explicit that the call is meant to
#' provide a default row group label. If this is not set and there are rows
#' that haven't been placed into a row group (where one or more row groups
#' already exist), those rows will be automatically placed into a row group
#' without a label.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `gtcars` to create a gt table and
#' # add two row groups with the labels:
#' # `numbered` and `NA` (a group without
#' # a title, or, the rest)
#' tab_1 <-
#' gtcars %>%
#' dplyr::select(model, year, hp, trq) %>%
#' dplyr::slice(1:8) %>%
#' gt(rowname_col = "model") %>%
#' tab_row_group(
#' group = "numbered",
#' rows = matches("^[0-9]")
#' )
#'
#' # Use `gtcars` to create a gt table;
#' # add two row groups with the labels
#' # `powerful` and `super powerful`: the
#' # distinction being `hp` lesser or
#' # greater than `600`
#' tab_2 <-
#' gtcars %>%
#' dplyr::select(model, year, hp, trq) %>%
#' dplyr::slice(1:8) %>%
#' gt(rowname_col = "model") %>%
#' tab_row_group(
#' group = "powerful",
#' rows = hp <= 600
#' ) %>%
#' tab_row_group(
#' group = "super powerful",
#' rows = hp > 600
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_row_group_1.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_row_group_2.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-4
#'
#' @import rlang
#' @export
tab_row_group <- function(data,
group = NULL,
rows = NULL,
others = NULL) {
# Perform input object validation
stop_if_not_gt(data = data)
arrange_groups_vars <- dt_row_groups_get(data = data)
# Capture the `rows` expression
row_expr <- rlang::enquo(rows)
# Create a row group if a `group` is provided
if (!is.null(group)) {
# Get the `stub_df` data frame from `data`
stub_df <- dt_stub_df_get(data = data)
data_tbl <- dt_data_get(data = data)
# Resolve the row numbers using the `resolve_vars` function
resolved_rows_idx <-
resolve_data_vals_idx(
var_expr = !!row_expr,
data_tbl = data_tbl,
vals = stub_df$rowname
)
# Place the `group` label in the `groupname` column `stub_df`
stub_df <- dt_stub_df_get(data = data)
stub_df[resolved_rows_idx, "groupname"] <- process_text(group[1])
data <- dt_stub_df_set(data = data, stub_df = stub_df)
if (dt_stub_groupname_has_na(data = data)) {
data <-
dt_row_groups_set(
data = data,
row_groups = c(
process_text(group[1]),
arrange_groups_vars,
NA_character_
) %>%
unique()
)
} else {
data <-
dt_row_groups_set(
data = data,
row_groups = c(
process_text(group[1]),
arrange_groups_vars
) %>%
unique()
)
}
}
# Set a name for the `others` group if a
# name is provided
if (!is.null(others)) {
data <-
dt_stub_others_set(
data = data,
stub_others = others[1] %>% process_text()
)
}
data
}
#' Add label text to the stubhead
#'
#' Add a label to the stubhead of a **gt** table. The stubhead is the lone
#' element that is positioned left of the column labels, and above the stub. If
#' a stub does not exist, then there is no stubhead (so no change will be made
#' when using this function in that case). We have the flexibility to use
#' Markdown formatting for the stubhead label. Furthermore, if the table is
#' intended for HTML output, we can use HTML for the stubhead label.
#'
#' @inheritParams fmt_number
#' @param label The text to be used as the stubhead label We can optionally use
#' the [md()] and [html()] functions to style the text as Markdown or to
#' retain HTML elements in the text.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `gtcars` to create a gt table; add
#' # a stubhead label to describe what is
#' # in the stub
#' tab_1 <-
#' gtcars %>%
#' dplyr::select(model, year, hp, trq) %>%
#' dplyr::slice(1:5) %>%
#' gt(rowname_col = "model") %>%
#' tab_stubhead(label = "car")
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_stubhead_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-5
#'
#' @export
tab_stubhead <- function(data,
label) {
# Perform input object validation
stop_if_not_gt(data = data)
data %>% dt_stubhead_label(label = label)
}
#' Add a table footnote
#'
#' The `tab_footnote()` function can make it a painless process to add a
#' footnote to a **gt** table. There are two components to a footnote: (1) a
#' footnote mark that is attached to the targeted cell text, and (2) the
#' footnote text (that starts with the corresponding footnote mark) that is
#' placed in the table's footer area. Each call of `tab_footnote()` will add a
#' different note, and one or more cells can be targeted via the location helper
#' functions (e.g., [cells_body()], [cells_column_labels()], etc.).
#'
#' The formatting of the footnotes can be controlled through the use of various
#' parameters in the [tab_options()] function:
#'
#' \itemize{
#' \item `footnotes.sep`: allows for a choice of the separator between
#' consecutive footnotes in the table footer. By default, this is set to a
#' linebreak.
#' \item `footnotes.marks`: the set of sequential characters or numbers used
#' to identify the footnotes.
#' \item `footnotes.font.size`: the size of the font used in the footnote
#' section.
#' \item `footnotes.padding`: the amount of padding to apply between the
#' footnote and source note sections in the table footer.
#' }
#'
#' @inheritParams fmt_number
#' @param footnote The text to be used in the footnote. We can optionally use
#' the [md()] and [html()] functions to style the text as Markdown or to
#' retain HTML elements in the footnote text.
#' @param locations The cell or set of cells to be associated with the footnote.
#' Supplying any of the `cells_*()` helper functions is a useful way to target
#' the location cells that are associated with the footnote text. These helper
#' functions are: [cells_title()], [cells_stubhead()],
#' [cells_column_spanners()], [cells_column_labels()], [cells_row_groups()],
#' [cells_stub()], [cells_body()], [cells_summary()], and
#' [cells_grand_summary()]. Additionally, we can enclose several `cells_*()`
#' calls within a `list()` if we wish to link the footnote text to different
#' types of locations (e.g., body cells, row group labels, the table title,
#' etc.).
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `sza` to create a gt table; color
#' # the `sza` column using the `data_color()`
#' # function, then, add a footnote to the
#' # `sza` column label explaining what the
#' # color scale signifies
#' tab_1 <-
#' sza %>%
#' dplyr::filter(
#' latitude == 20 &
#' month == "jan" &
#' !is.na(sza)
#' ) %>%
#' dplyr::select(-latitude, -month) %>%
#' gt() %>%
#' data_color(
#' columns = vars(sza),
#' colors = scales::col_numeric(
#' palette = c("white", "yellow", "navyblue"),
#' domain = c(0, 90))
#' ) %>%
#' tab_footnote(
#' footnote = "Color indicates height of sun.",
#' locations = cells_column_labels(
#' columns = vars(sza))
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_footnote_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-6
#'
#' @export
tab_footnote <- function(data,
footnote,
locations) {
# Perform input object validation
stop_if_not_gt(data = data)
# Resolve into a list of locations
locations <- as_locations(locations)
# Resolve the locations of the targeted data cells and append
# the footnotes
for (loc in locations) {
data <- set_footnote(loc = loc, data = data, footnote = process_text(footnote))
}
data
}
set_footnote <- function(loc, data, footnote) {
UseMethod("set_footnote")
}
set_footnote.cells_title <- function(loc, data, footnote) {
if ((loc$groups %>% rlang::eval_tidy()) == "title") {
data <-
dt_footnotes_add(
data = data,
locname = "title",
grpname = NA_character_,
colname = NA_character_,
locnum = 1,
rownum = NA_integer_,
footnotes = footnote
)
} else if ((loc$groups %>% rlang::eval_tidy()) == "subtitle") {
data <-
dt_footnotes_add(
data = data,
locname = "subtitle",
grpname = NA_character_,
colname = NA_character_,
locnum = 2,
rownum = NA_integer_,
footnotes = footnote
)
}
data
}
set_footnote.cells_stubhead <- function(loc, data, footnote) {
data <-
dt_footnotes_add(
data = data,
locname = loc$groups,
grpname = NA_character_,
colname = NA_character_,
locnum = 2.5,
rownum = NA_integer_,
footnotes = footnote
)
data
}
set_footnote.cells_column_labels <- function(loc, data, footnote) {
resolved <- resolve_cells_column_labels(data = data, object = loc)
cols <- resolved$columns
colnames <- dt_boxhead_get_vars_default(data = data)[cols]
data <-
dt_footnotes_add(
data = data,
locname = "columns_columns",
grpname = NA_character_,
colname = colnames,
locnum = 4,
rownum = NA_integer_,
footnotes = footnote
)
data
}
set_footnote.cells_column_spanners <- function(loc, data, footnote) {
resolved <- resolve_cells_column_spanners(data = data, object = loc)
groups <- resolved$spanners
data <-
dt_footnotes_add(
data = data,
locname = "columns_groups",
grpname = groups,
colname = NA_character_,
locnum = 3,
rownum = NA_integer_,
footnotes = footnote
)
data
}
set_footnote.cells_row_groups <- function(loc, data, footnote) {
row_groups <- dt_row_groups_get(data = data)
# Resolve row groups
resolved_row_groups_idx <-
resolve_data_vals_idx(
var_expr = !!loc$groups,
data_tbl = NULL,
vals = row_groups
)
groups <- row_groups[resolved_row_groups_idx]
data <-
dt_footnotes_add(
data = data,
locname = "row_groups",
grpname = groups,
colname = NA_character_,
locnum = 5,
rownum = NA_integer_,
footnotes = footnote
)
data
}
set_footnote.cells_body <- function(loc, data, footnote) {
resolved <- resolve_cells_body(data = data, object = loc)
cols <- resolved$columns
rows <- resolved$rows
colnames <- resolved$colnames
data <-
dt_footnotes_add(
data = data,
locname = "data",
grpname = NA_character_,
colname = colnames,
locnum = 5,
rownum = rows,
footnotes = footnote
)
data
}
set_footnote.cells_stub <- function(loc, data, footnote) {
resolved <- resolve_cells_stub(data = data, object = loc)
rows <- resolved$rows
data <-
dt_footnotes_add(
data = data,
locname = "stub",
grpname = NA_character_,
colname = NA_character_,
locnum = 5,
rownum = rows,
footnotes = footnote
)
data
}
set_footnote.cells_summary <- function(loc, data, footnote) {
add_summary_location_row(
loc = loc,
data = data,
style = footnote,
df_type = "footnotes_df"
)
}
set_footnote.cells_grand_summary <- function(loc, data, footnote) {
add_grand_summary_location_row(
loc = loc,
data = data,
style = footnote,
df_type = "footnotes_df"
)
}
#' Add a source note citation
#'
#' Add a source note to the footer part of the **gt** table. A source note is
#' useful for citing the data included in the table. Several can be added to the
#' footer, simply use multiple calls of `tab_source_note()` and they will be
#' inserted in the order provided. We can use Markdown formatting for the note,
#' or, if the table is intended for HTML output, we can include HTML formatting.
#'
#' @inheritParams fmt_number
#' @param source_note Text to be used in the source note. We can optionally use
#' the [md()] and [html()] functions to style the text as Markdown or to
#' retain HTML elements in the text.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `gtcars` to create a gt table;
#' # add a source note to the table
#' # footer that cites the data source
#' tab_1 <-
#' gtcars %>%
#' dplyr::select(mfr, model, msrp) %>%
#' dplyr::slice(1:5) %>%
#' gt() %>%
#' tab_source_note(
#' source_note = "From edmunds.com"
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_source_note_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-7
#'
#' @export
tab_source_note <- function(data,
source_note) {
# Perform input object validation
stop_if_not_gt(data = data)
data %>% dt_source_notes_add(source_note = source_note)
}
#' Add custom styles to one or more cells
#'
#' With the `tab_style()` function we can target specific cells and apply styles
#' to them. This is best done in conjunction with the helper functions
#' [cell_text()], [cell_fill()], and [cell_borders()]. At present this function
#' is focused on the application of styles for HTML output only (as such, other
#' output formats will ignore all `tab_style()` calls). Using the aforementioned
#' helper functions, here are some of the styles we can apply:
#' \itemize{
#' \item the background color of the cell ([cell_fill()]: `color`)
#' \item the cell's text color, font, and size ([cell_text()]: `color`, `font`,
#' `size`)
#' \item the text style ([cell_text()]: `style`), enabling the use of italics or
#' oblique text.
#' \item the text weight ([cell_text()]: `weight`), allowing the use of thin to
#' bold text (the degree of choice is greater with variable fonts)
#' \item the alignment and indentation of text ([cell_text()]: `align` and
#' `indent`)
#' \item the cell borders ([cell_borders()])
#' }
#'
#' @inheritParams fmt_number
#' @param style a vector of styles to use. The [cell_text()], [cell_fill()], and
#' [cell_borders()] helper functions can be used here to more easily generate
#' valid styles. If using more than one helper function to define styles, all
#' calls must be enclosed in a [list()].
#' @param locations the cell or set of cells to be associated with the style.
#' Supplying any of the `cells_*()` helper functions is a useful way to target
#' the location cells that are associated with the styling. These helper
#' functions are: [cells_title()], [cells_stubhead()],
#' [cells_column_spanners()], [cells_column_labels()], [cells_row_groups()],
#' [cells_stub()], [cells_body()], [cells_summary()], and
#' [cells_grand_summary()]. Additionally, we can enclose several `cells_*()`
#' calls within a `list()` if we wish to apply styling to different types of
#' locations (e.g., body cells, row group labels, the table title, etc.).
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `exibble` to create a gt table;
#' # add styles that are to be applied
#' # to data cells that satisfy a
#' # condition (using `tab_style()`)
#' tab_1 <-
#' exibble %>%
#' dplyr::select(num, currency) %>%
#' gt() %>%
#' fmt_number(
#' columns = vars(num, currency),
#' decimals = 1
#' ) %>%
#' tab_style(
#' style = list(
#' cell_fill(color = "lightcyan"),
#' cell_text(weight = "bold")
#' ),
#' locations = cells_body(
#' columns = vars(num),
#' rows = num >= 5000)
#' ) %>%
#' tab_style(
#' style = list(
#' cell_fill(color = "#F9E3D6"),
#' cell_text(style = "italic")
#' ),
#' locations = cells_body(
#' columns = vars(currency),
#' rows = currency < 100)
#' )
#'
#' # Use `sp500` to create a gt table;
#' # color entire rows of cells based
#' # on values in a particular column
#' tab_2 <-
#' sp500 %>%
#' dplyr::filter(
#' date >= "2015-12-01" &
#' date <= "2015-12-15"
#' ) %>%
#' dplyr::select(-c(adj_close, volume)) %>%
#' gt() %>%
#' tab_style(
#' style = cell_fill(color = "lightgreen"),
#' locations = cells_body(
#' rows = close > open)
#' ) %>%
#' tab_style(
#' style = list(
#' cell_fill(color = "red"),
#' cell_text(color = "white")
#' ),
#' locations = cells_body(
#' rows = open > close)
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_style_1.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_style_2.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-8
#'
#' @seealso [cell_text()], [cell_fill()], and [cell_borders()] as helpers for
#' defining custom styles and [cells_body()] as one of many useful helper
#' functions for targeting the locations to be styled.
#'
#' @export
tab_style <- function(data,
style,
locations) {
# Perform input object validation
stop_if_not_gt(data = data)
# Resolve into a list of locations
locations <- as_locations(locations)
style <- as_style(style)
# Resolve the locations of the targeted data cells and append
# the format directives
for (loc in locations) {
data <-
set_style(
loc = loc,
data = data,
style = style
)
}
data
}
as_style <- function(style) {
# If style rules are part of a list, paste each of the list
# components together
if (!inherits(style, "cell_styles")) {
if (!inherits(style, "list")) {
stop("Styles should be provided exclusively by the stylizing ",
"helper functions:",
" * `cell_text()\n",
" * `cell_fill()\n",
" * `cell_borders()`",
call. = FALSE)
}
# Initialize an empty list that will be
# populated with normalized style declarations
final_style <- list()
for (i in seq(style)) {
style_item <- style[[i]]
if (!inherits(style_item, "cell_styles")) {
stop("All provided styles should be generated by stylizing ",
"helper functions. Style with index `", i, "` is invalid.",
call. = FALSE)
}
final_style <- utils::modifyList(final_style, style_item)
}
class(final_style) <- "cell_styles"
style <- final_style
}
# Check for class of `cell_style` in upgraded `style` list
lapply(style, function(x) checkmate::assert_class(x = x, classes = "cell_style"))
style
}
set_style <- function(loc, data, style) {
UseMethod("set_style")
}
set_style.cells_title <- function(loc, data, style) {
if ((loc$groups %>% rlang::eval_tidy()) == "title") {
data <-
dt_styles_add(
data = data,
locname = "title",
grpname = NA_character_,
colname = NA_character_,
locnum = 1,
rownum = NA_integer_,
styles = style
)
} else if ((loc$groups %>% rlang::eval_tidy()) == "subtitle") {
data <-
dt_styles_add(
data = data,
locname = "subtitle",
grpname = NA_character_,
colname = NA_character_,
locnum = 2,
rownum = NA_integer_,
styles = style
)
}
data
}
set_style.cells_stubhead <- function(loc, data, style) {
data <-
dt_styles_add(
data = data,
locname = loc$groups,
grpname = NA_character_,
colname = NA_character_,
locnum = 2.5,
rownum = NA_integer_,
styles = style
)
data
}
set_style.cells_column_labels <- function(loc, data, style) {
resolved <- resolve_cells_column_labels(data = data, object = loc)
cols <- resolved$columns
colnames <- dt_boxhead_get_vars_default(data = data)[cols]
data <-
dt_styles_add(
data = data,
locname = "columns_columns",
grpname = NA_character_,
colname = colnames,
locnum = 4,
rownum = NA_integer_,
styles = style
)
data
}
set_style.cells_column_spanners <- function(loc, data, style) {
resolved <- resolve_cells_column_spanners(data = data, object = loc)
groups <- resolved$spanners
data <-
dt_styles_add(
data = data,
locname = "columns_groups",
grpname = groups,
colname = NA_character_,
locnum = 3,
rownum = NA_integer_,
styles = style
)
data
}
set_style.cells_row_groups <- function(loc, data, style) {
row_groups <- dt_row_groups_get(data = data)
# Resolve row groups
resolved_row_groups_idx <-
resolve_data_vals_idx(
var_expr = !!loc$groups,
data_tbl = NULL,
vals = row_groups
)
groups <- row_groups[resolved_row_groups_idx]
data <-
dt_styles_add(
data = data,
locname = "row_groups",
grpname = groups,
colname = NA_character_,
locnum = 5,
rownum = NA_integer_,
styles = style
)
data
}
set_style.cells_body <- function(loc, data, style) {
resolved <- resolve_cells_body(data = data, object = loc)
cols <- resolved$columns
rows <- resolved$rows
colnames <- resolved$colnames
data <-
dt_styles_add(
data = data,
locname = "data",
grpname = NA_character_,
colname = colnames,
locnum = 5,
rownum = rows,
styles = style
)
data
}
set_style.cells_stub <- function(loc, data, style) {
resolved <- resolve_cells_stub(data = data, object = loc)
rows <- resolved$rows
data <-
dt_styles_add(
data = data,
locname = "stub",
grpname = NA_character_,
colname = NA_character_,
locnum = 5,
rownum = rows,
styles = style
)
data
}
set_style.cells_summary <- function(loc, data, style) {
add_summary_location_row(
loc = loc,
data = data,
style = style,
df_type = "styles_df"
)
}
set_style.cells_grand_summary <- function(loc, data, style) {
add_grand_summary_location_row(
loc = loc,
data = data,
style = style,
df_type = "styles_df"
)
}
#' Modify the table output options
#'
#' Modify the options available in a table. These options are named by the
#' components, the subcomponents, and the element that can adjusted.
#'
#' @inheritParams fmt_number
#' @param container.width,container.height The width and height of the table's
#' container. Can be specified as a single-length character with units of
#' pixels or as a percentage. If provided as a single-length numeric vector,
#' it is assumed that the value is given in units of pixels. The [px()] and
#' [pct()] helper functions can also be used to pass in numeric values and
#' obtain values as pixel or percent units.
#' @param container.overflow.x,container.overflow.y Options to enable scrolling
#' in the horizontal and vertical directions when the table content overflows
#' the container dimensions. Using `TRUE` (the default for both) means that
#' horizontal or vertical scrolling is enabled to view the entire table in
#' those directions. With `FALSE`, the table may be clipped if the table width
#' or height exceeds the `container.width` or `container.height`.
#' @param table.width The width of the table. Can be specified as a
#' single-length character with units of pixels or as a percentage. If
#' provided as a single-length numeric vector, it is assumed that the value is
#' given in units of pixels. The [px()] and [pct()] helper functions can also
#' be used to pass in numeric values and obtain values as pixel or percent
#' units.
#' @param table.align The horizontal alignment of the table in its container. By
#' default, this is `"center"`. Other options are `"left"` and `"right"`. This
#' will automatically set `table.margin.left` and `table.margin.right` to the
#' appropriate values.
#' @param table.margin.left,table.margin.right The size of the margins on the
#' left and right of the table within the container. Can be specified as a
#' single-length character with units of pixels or as a percentage. If
#' provided as a single-length numeric vector, it is assumed that the value is
#' given in units of pixels. The [px()] and [pct()] helper functions can also
#' be used to pass in numeric values and obtain values as pixel or percent
#' units. Using `table.margin.left` or `table.margin.right` will overwrite any
#' values set by `table.align`.
#' @param table.background.color,heading.background.color,column_labels.background.color,row_group.background.color,stub.background.color,summary_row.background.color,grand_summary_row.background.color,footnotes.background.color,source_notes.background.color
#' Background colors for the parent element `table` and the following child
#' elements: `heading`, `column_labels`, `row_group`, `stub`, `summary_row`,
#' `grand_summary_row`, `footnotes`, and `source_notes`. A color name or a
#' hexadecimal color code should be provided.
#' @param table.font.color,table.font.color.light
#' The text color used throughout the table. There are two variants:
#' `table.font.color` is for text overlaid on lighter background colors, and
#' `table.font.color.light` is automatically used when text needs to be
#' overlaid on darker background colors. A color name or a hexadecimal color
#' code should be provided.
#' @param table.font.size,heading.title.font.size,heading.subtitle.font.size,column_labels.font.size,row_group.font.size,footnotes.font.size,source_notes.font.size
#' The font sizes for the parent text element `table` and the following child
#' elements: `heading.title`, `heading.subtitle`, `column_labels`,
#' `row_group`, `footnotes`, and `source_notes`. Can be specified as a
#' single-length character vector with units of pixels (e.g., `12px`) or as a
#' percentage (e.g., `80\%`). If provided as a single-length numeric vector,
#' it is assumed that the value is given in units of pixels. The [px()] and
#' [pct()] helper functions can also be used to pass in numeric values and
#' obtain values as pixel or percentage units.
#' @param heading.title.font.weight,heading.subtitle.font.weight,column_labels.font.weight,row_group.font.weight,stub.font.weight
#' The font weights of the `heading.title`, `heading.subtitle`,
#' `column_labels`, `row_group`, and `stub` text elements. Can be a text-based
#' keyword such as `"normal"`, `"bold"`, `"lighter"`, `"bolder"`, or, a
#' numeric value between `1` and `1000`, inclusive. Note that only variable
#' fonts may support the numeric mapping of weight.
#' @param column_labels.text_transform,row_group.text_transform,stub.text_transform,summary_row.text_transform,grand_summary_row.text_transform
#' Options to apply text transformations to the `column_labels`, `row_group`,
#' `stub`, `summary_row`, and `grand_summary_row` text elements. Either of the
#' `"uppercase"`, `"lowercase"`, or `"capitalize"` keywords can be used.
#' @param data_row.padding,row_group.padding,summary_row.padding,grand_summary_row.padding,footnotes.padding,source_notes.padding
#' The amount of vertical padding to incorporate in the `data_row`,
#' `row_group`, `summary_row`, `grand_summary_row`, `footnotes`, and
#' `source_notes` locations.
#' @param table.border.top.style,table.border.top.width,table.border.top.color,table.border.bottom.style,table.border.bottom.width,table.border.bottom.color
#' The style, width, and color properties of the table's absolute top and
#' absolute bottom borders.
#' @param heading.border.bottom.style,heading.border.bottom.width,heading.border.bottom.color
#' The style, width, and color properties of the header's bottom border. This
#' border shares space with that of the `column_labels` location. If the
#' `width` of this border is larger, then it will be the visible border.
#' @param heading.border.lr.style,heading.border.lr.width,heading.border.lr.color
#' The style, width, and color properties for the left and right borders of
#' the `heading` location.
#' @param column_labels.border.top.style,column_labels.border.top.width,column_labels.border.top.color
#' The style, width, and color properties for the top border of the
#' `column_labels` location. This border shares space with that of the
#' `heading` location. If dthe `width` of this border is larger, then it will
#' be the visible border.
#' @param column_labels.border.bottom.style,column_labels.border.bottom.width,column_labels.border.bottom.color
#' The style, width, and color properties for the bottom border of the
#' `column_labels` location.
#' @param column_labels.border.lr.style,column_labels.border.lr.width,column_labels.border.lr.color
#' The style, width, and color properties for the left and right borders of
#' the `column_labels` location.
#' @param column_labels.hidden An option to hide the column labels. If providing
#' `TRUE` then the entire `column_labels` location won't be seen and the table
#' header (if present) will collapse downward.
#' @param row_group.border.top.style,row_group.border.top.width,row_group.border.top.color,row_group.border.bottom.style,row_group.border.bottom.width,row_group.border.bottom.color,row_group.border.left.style,row_group.border.left.width,row_group.border.left.color,row_group.border.right.style,row_group.border.right.width,row_group.border.right.color
#' The style, width, and color properties for all top, bottom, left, and right
#' borders of the `row_group` location.
#' @param table_body.hlines.style,table_body.hlines.width,table_body.hlines.color,table_body.vlines.style,table_body.vlines.width,table_body.vlines.color
#' The style, width, and color properties for all horizontal lines ('hlines')
#' and vertical lines ('vlines') in the `table_body`.
#' @param table_body.border.top.style,table_body.border.top.width,table_body.border.top.color,table_body.border.bottom.style,table_body.border.bottom.width,table_body.border.bottom.color
#' The style, width, and color properties for all top and bottom borders of
#' the `table_body` location.
#' @param stub.border.style,stub.border.width,stub.border.color
#' The style, width, and color properties for the vertical border of the table
#' stub.
#' @param summary_row.border.style,summary_row.border.width,summary_row.border.color
#' The style, width, and color properties for all horizontal borders of the
#' `summary_row` location.
#' @param grand_summary_row.border.style,grand_summary_row.border.width,grand_summary_row.border.color
#' The style, width, and color properties for the top borders of the
#' `grand_summary_row` location.
#' @param footnotes.border.bottom.style,footnotes.border.bottom.width,footnotes.border.bottom.color
#' The style, width, and color properties for the bottom border of the
#' `footnotes` location.
#' @param footnotes.border.lr.style,footnotes.border.lr.width,footnotes.border.lr.color
#' The style, width, and color properties for the left and right borders of
#' the `footnotes` location.
#' @param footnotes.sep The separating characters between adjacent footnotes in
#' the footnotes section. The default value produces a linebreak.
#' @param footnotes.marks The set of sequential marks used to reference and
#' identify each of the footnotes (same input as the [opt_footnote_marks()]
#' function. We can supply a vector that represents the series of footnote
#' marks. This vector is recycled when its usage goes beyond the length of the
#' set. At each cycle, the marks are simply combined (e.g., `*` -> `**` ->
#' `***`). The option exists for providing keywords for certain types of
#' footnote marks. The keyword `"numbers"` (the default, indicating that we
#' want to use numeric marks). We can use lowercase `"letters"` or uppercase
#' `"LETTERS"`. There is the option for using a traditional symbol set where
#' `"standard"` provides four symbols, and, `"extended"` adds two more
#' symbols, making six.
#' @param source_notes.border.bottom.style,source_notes.border.bottom.width,source_notes.border.bottom.color
#' The style, width, and color properties for the bottom border of the
#' `source_notes` location.
#' @param source_notes.border.lr.style,source_notes.border.lr.width,source_notes.border.lr.color
#' The style, width, and color properties for the left and right borders of
#' the `source_notes` location.
#' @param row.striping.background_color The background color for striped table
#' body rows. A color name or a hexadecimal color code should be provided.
#' @param row.striping.include_stub An option for whether to include the stub
#' when striping rows.
#' @param row.striping.include_table_body An option for whether to include the
#' table body when striping rows.
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `exibble` to create a gt table with
#' # all the main parts added; we can use this
#' # going forward to demo some `tab_options()`
#' tab_1 <-
#' exibble %>%
#' dplyr::select(
#' -c(fctr, date, time, datetime)
#' ) %>%
#' gt(
#' rowname_col = "row",
#' groupname_col = "group"
#' ) %>%
#' tab_header(
#' title = md("Data listing from **exibble**"),
#' subtitle = md("`exibble` is an R dataset")
#' ) %>%
#' fmt_number(columns = vars(num)) %>%
#' fmt_currency(columns = vars(currency)) %>%
#' tab_footnote(
#' footnote = "Using commas for separators.",
#' locations = cells_body(
#' columns = vars(num),
#' rows = num > 1000)
#' ) %>%
#' tab_footnote(
#' footnote = "Using commas for separators.",
#' locations = cells_body(
#' columns = vars(currency),
#' rows = currency > 1000)
#' ) %>%
#' tab_footnote(
#' footnote = "Alphabetical fruit.",
#' locations = cells_column_labels(
#' columns = vars(char))
#' )
#'
#' # Modify the table width to 100% (which
#' # spans the entire content width area)
#' tab_2 <-
#' tab_1 %>%
#' tab_options(
#' table.width = pct(100)
#' )
#'
#' # Modify the table's background color
#' # to be "lightcyan"
#' tab_3 <-
#' tab_1 %>%
#' tab_options(
#' table.background.color = "lightcyan"
#' )
#'
#' # Use letters as the marks for footnote
#' # references; also, separate footnotes in
#' # the footer by spaces instead of newlines
#' tab_4 <-
#' tab_1 %>%
#' tab_options(
#' footnotes.sep = " ",
#' footnotes.marks = letters
#' )
#'
#' # Change the padding of data rows to 5px
#' tab_5 <-
#' tab_1 %>%
#' tab_options(
#' data_row.padding = px(5)
#' )
#'
#' # Reduce the size of the title and the
#' # subtitle text
#' tab_6 <-
#' tab_1 %>%
#' tab_options(
#' heading.title.font.size = "small",
#' heading.subtitle.font.size = "small"
#' )
#'
#' @section Figures:
#' \if{html}{\figure{man_tab_options_1.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_options_2.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_options_3.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_options_4.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_options_5.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_tab_options_6.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-9
#'
#' @export
tab_options <- function(data,
container.width = NULL,
container.height = NULL,
container.overflow.x = NULL,
container.overflow.y = NULL,
table.width = NULL,
table.align = NULL,
table.margin.left = NULL,
table.margin.right = NULL,
table.background.color = NULL,
table.font.color = NULL,
table.font.color.light = NULL,
table.font.size = NULL,
table.border.top.style = NULL,
table.border.top.width = NULL,
table.border.top.color = NULL,
table.border.bottom.style = NULL,
table.border.bottom.width = NULL,
table.border.bottom.color = NULL,
heading.background.color = NULL,
heading.title.font.size = NULL,
heading.title.font.weight = NULL,
heading.subtitle.font.size = NULL,
heading.subtitle.font.weight = NULL,
heading.border.bottom.style = NULL,
heading.border.bottom.width = NULL,
heading.border.bottom.color = NULL,
heading.border.lr.style = NULL,
heading.border.lr.width = NULL,
heading.border.lr.color = NULL,
column_labels.background.color = NULL,
column_labels.font.size = NULL,
column_labels.font.weight = NULL,
column_labels.text_transform = NULL,
column_labels.border.top.style = NULL,
column_labels.border.top.width = NULL,
column_labels.border.top.color = NULL,
column_labels.border.bottom.style = NULL,
column_labels.border.bottom.width = NULL,
column_labels.border.bottom.color = NULL,
column_labels.border.lr.style = NULL,
column_labels.border.lr.width = NULL,
column_labels.border.lr.color = NULL,
column_labels.hidden = NULL,
row_group.background.color = NULL,
row_group.font.size = NULL,
row_group.font.weight = NULL,
row_group.text_transform = NULL,
row_group.padding = NULL,
row_group.border.top.style = NULL,
row_group.border.top.width = NULL,
row_group.border.top.color = NULL,
row_group.border.bottom.style = NULL,
row_group.border.bottom.width = NULL,
row_group.border.bottom.color = NULL,
row_group.border.left.style = NULL,
row_group.border.left.width = NULL,
row_group.border.left.color = NULL,
row_group.border.right.style = NULL,
row_group.border.right.width = NULL,
row_group.border.right.color = NULL,
table_body.hlines.style = NULL,
table_body.hlines.width = NULL,
table_body.hlines.color = NULL,
table_body.vlines.style = NULL,
table_body.vlines.width = NULL,
table_body.vlines.color = NULL,
table_body.border.top.style = NULL,
table_body.border.top.width = NULL,
table_body.border.top.color = NULL,
table_body.border.bottom.style = NULL,
table_body.border.bottom.width = NULL,
table_body.border.bottom.color = NULL,
stub.background.color = NULL,
stub.font.weight = NULL,
stub.text_transform = NULL,
stub.border.style = NULL,
stub.border.width = NULL,
stub.border.color = NULL,
data_row.padding = NULL,
summary_row.background.color = NULL,
summary_row.text_transform = NULL,
summary_row.padding = NULL,
summary_row.border.style = NULL,
summary_row.border.width = NULL,
summary_row.border.color = NULL,
grand_summary_row.background.color = NULL,
grand_summary_row.text_transform = NULL,
grand_summary_row.padding = NULL,
grand_summary_row.border.style = NULL,
grand_summary_row.border.width = NULL,
grand_summary_row.border.color = NULL,
footnotes.background.color = NULL,
footnotes.font.size = NULL,
footnotes.padding = NULL,
footnotes.border.bottom.style = NULL,
footnotes.border.bottom.width = NULL,
footnotes.border.bottom.color = NULL,
footnotes.border.lr.style = NULL,
footnotes.border.lr.width = NULL,
footnotes.border.lr.color = NULL,
footnotes.sep = NULL,
footnotes.marks = NULL,
source_notes.background.color = NULL,
source_notes.font.size = NULL,
source_notes.padding = NULL,
source_notes.border.bottom.style = NULL,
source_notes.border.bottom.width = NULL,
source_notes.border.bottom.color = NULL,
source_notes.border.lr.style = NULL,
source_notes.border.lr.width = NULL,
source_notes.border.lr.color = NULL,
row.striping.background_color = NULL,
row.striping.include_stub = NULL,
row.striping.include_table_body = NULL) {
# TODO: add helper functions to divide the options into those by location
# TODO: add helper functions to divide the options into those by parameter
# Perform input object validation
stop_if_not_gt(data = data)
# Extract the options table from `data`
opts_df <- dt_options_get(data = data)
arg_names <- formals(tab_options) %>% names() %>% base::setdiff("data")
arg_vals <- mget(arg_names)
arg_vals <- arg_vals[!vapply(arg_vals, FUN = is.null, FUN.VALUE = logical(1))]
arg_vals <- arg_vals %>% set_super_options()
new_df <-
dplyr::tibble(
parameter = names(arg_vals) %>% tidy_gsub(".", "_", fixed = TRUE),
value = unname(arg_vals)) %>%
dplyr::left_join(
opts_df %>% dplyr::select(parameter, type),
by = "parameter"
) %>%
dplyr::mutate(
value = mapply(
preprocess_tab_option,
option = value, var_name = parameter, type = type,
SIMPLIFY = FALSE)
) %>%
dplyr::select(-type)
# This rearranges the rows in the `opts_df` table, but this
# shouldn't be a problem
opts_df <-
dplyr::bind_rows(
new_df %>%
dplyr::inner_join(
opts_df %>% dplyr::select(-value),
by = "parameter"
),
opts_df %>%
dplyr::anti_join(new_df, by = "parameter")
)
# Write the modified options table back to `data`
data <- dt_options_set(data = data, options = opts_df)
data
}
#' Modify the set of footnote marks
#'
#' Alter the footnote marks for any footnotes that may be present in the table.
#' Either a vector of marks can be provided (including Unicode characters), or,
#' a specific keyword could be used to signify a preset sequence. This function
#' serves as a shortcut for using `tab_options(footnotes.marks = {marks})`
#'
#' We can supply a vector of that will represent the series of marks.
#' The series of footnote marks is recycled when its usage goes beyond the
#' length of the set. At each cycle, the marks are simply doubled, tripled, and
#' so on (e.g., `*` -> `**` -> `***`). The option exists for providing keywords
#' for certain types of footnote marks. The keywords are:
#'
#' \itemize{
#' \item `"numbers"`: numeric marks, they begin from 1 and these marks are not
#' subject to recycling behavior
#' \item `"letters"`: miniscule alphabetic marks, internally uses the `letters`
#' vector
#' which contains 26 lowercase letters of the Roman alphabet
#' \item `"LETTERS"`: majuscule alphabetic marks, using the `LETTERS` vector
#' which has 26 uppercase letters of the Roman alphabet
#' \item `"standard"`: symbolic marks, four symbols in total
#' \item `"extended"`: symbolic marks, extends the standard set by adding two
#' more symbols, making six
#' }
#'
#' @inheritParams fmt_number
#' @param marks Either a vector (that will represent the series of marks) or a
#' keyword that represents a preset sequence of marks. The valid keywords are:
#' `"numbers"` (for numeric marks), `"letters"` and `"LETTERS"` (for lowercase
#' and uppercase alphabetic marks), `"standard"` (for a traditional set of
#' four symbol marks), and `"extended"` (which adds two more symbols to the
#' standard set).
#'
#' @return An object of class `gt_tbl`.
#'
#' @examples
#' # Use `sza` to create a gt table,
#' # adding three footnotes; call
#' # `opt_footnote_marks()` to specify
#' # which footnote marks to use
#' tab_1 <-
#' sza %>%
#' dplyr::group_by(latitude, tst) %>%
#' dplyr::summarize(
#' SZA.Max = max(sza),
#' SZA.Min = min(sza, na.rm = TRUE)
#' ) %>%
#' dplyr::ungroup() %>%
#' dplyr::filter(latitude == 30, !is.infinite(SZA.Min)) %>%
#' dplyr::select(-latitude) %>%
#' gt(rowname_col = "tst") %>%
#' tab_spanner_delim(delim = ".") %>%
#' fmt_missing(
#' columns = everything(),
#' missing_text = "90+"
#' ) %>%
#' tab_stubhead("TST") %>%
#' tab_footnote(
#' footnote = "True solar time.",
#' locations = cells_stubhead()
#' ) %>%
#' tab_footnote(
#' footnote = "Solar zenith angle.",
#' locations = cells_column_spanners(spanners = "SZA")
#' ) %>%
#' tab_footnote(
#' footnote = "The Lowest SZA.",
#' locations = cells_stub(rows = "1200")
#' ) %>%
#' opt_footnote_marks(marks = "standard")
#'
#' @section Figures:
#' \if{html}{\figure{man_opt_footnote_marks_1.svg}{options: width=100\%}}
#'
#' @family Create or Modify Parts
#' @section Function ID:
#' 2-10
#'
#' @export
opt_footnote_marks <- function(data,
marks = NULL) {
# Perform input object validation
stop_if_not_gt(data = data)
if (!is.null(marks)) {
data <- data %>% tab_options(footnotes.marks = marks)
}
data
}
preprocess_tab_option <- function(option, var_name, type) {
# Perform pre-processing on the option depending on `type`
option <-
switch(type,
overflow = {
if (isTRUE(option)) {
"auto"
} else if (isFALSE(option)) {
"hidden"
} else {
option
}
},
px = {
if (is.numeric(option)) {
px(option)
} else {
option
}
},
option
)
# Perform checkmate assertions by `type`
switch(type,
logical = checkmate::assert_logical(
option, len = 1, any.missing = FALSE, .var.name = var_name),
overflow =,
px =,
value = checkmate::assert_character(
option, len = 1, any.missing = FALSE, .var.name = var_name),
values = checkmate::assert_character(
option, min.len = 1, any.missing = FALSE, .var.name = var_name)
)
option
}
set_super_options <- function(arg_vals) {
if ("table.align" %in% names(arg_vals)) {
table_align_val <- arg_vals$table.align
arg_vals$table.align <- NULL
if (!(table_align_val %in% c("left", "center", "right"))) {
stop("The chosen option for `table.align` (`", table_align_val, "`) is invalid\n",
" * We can use either of `left`, `center`, or `right`.",
call. = FALSE)
}
arg_vals$table.margin.left <- arg_vals$table.margin.left %||%
switch(table_align_val,
center = "auto",
left = "0",
right = "auto")
arg_vals$table.margin.right <- arg_vals$table.margin.right %||%
switch(table_align_val,
center = "auto",
left = "auto",
right = "0")
}
arg_vals
}
You can’t perform that action at this time.