diff --git a/.Rbuildignore b/.Rbuildignore index 152d4a7a6f..95513134c7 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -88,5 +88,6 @@ tests/testthat/test-text_transform.R tests/testthat/test-util_functions.R tests/testthat/test-utils_formatters.R tests/testthat/test-utils_render_html.R +tests/testthat/test-utils_units.R tests/testthat/test-utils.R tests/testthat/test-vec_fmt.R diff --git a/DESCRIPTION b/DESCRIPTION index 9c74646cf3..6c91835229 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -137,6 +137,7 @@ Collate: 'utils_render_latex.R' 'utils_render_rtf.R' 'utils_render_xml.R' + 'utils_units.R' 'z_utils_render_footnotes.R' 'zzz.R' Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index ea675f22bf..c95cb0df23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -40,12 +40,14 @@ export(cols_move) export(cols_move_to_end) export(cols_move_to_start) export(cols_unhide) +export(cols_units) export(cols_width) export(contains) export(css) export(currency) export(data_color) export(default_fonts) +export(define_units) export(ends_with) export(escape_latex) export(everything) @@ -75,6 +77,7 @@ export(fmt_roman) export(fmt_scientific) export(fmt_spelled_num) export(fmt_time) +export(fmt_units) export(fmt_url) export(ggplot_image) export(google_font) diff --git a/R/data_color.R b/R/data_color.R index 12b06d774b..ad77f33fbc 100644 --- a/R/data_color.R +++ b/R/data_color.R @@ -675,7 +675,7 @@ #' #' @family data formatting functions #' @section Function ID: -#' 3-30 +#' 3-31 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) diff --git a/R/datasets.R b/R/datasets.R index fd9742f741..1d045e8e2f 100644 --- a/R/datasets.R +++ b/R/datasets.R @@ -565,6 +565,146 @@ #' "metro" +#' The fundamental physical constants +#' +#' @description +#' +#' This dataset contains values for over 300 basic fundamental constants in +#' nature. The values originate from the 2018 adjustment which is based on the +#' latest relevant precision measurements and improvements of theoretical +#' calculations. Such work has been carried out under the authority of the +#' *Task Group on Fundamental Constants* (TGFC) of the +#' *Committee on Data of the International Science Council* (CODATA). These +#' updated values became available on May 20, 2019. They are published at +#' , a website of the +#' *Fundamental Constants Data Center* of the +#' *National Institute of Standards and Technology* (NIST), Gaithersburg, +#' Maryland, USA. +#' +#' @format A tibble with 354 rows and 4 variables: +#' \describe{ +#' \item{name}{The name of the constant.} +#' \item{value}{The value of the constant.} +#' \item{uncert}{The uncertainty associated with the value. If `NA` then the +#' value is seen as an 'exact' value (e.g., an electron volt has the exact value +#' of 1.602 176 634 e-19 J).} +#' \item{units}{The units associated with the constant.} +#' } +#' +#' @section Examples: +#' +#' Here is a glimpse at the data available in `constants`. +#' +#' ```{r} +#' dplyr::glimpse(constants) +#' ``` +#' +#' @family datasets +#' @section Dataset ID and Badge: +#' DATA-9 +#' +#' \if{html}{\out{ +#' `r data_get_image_tag(file = "dataset_constants.png")` +#' }} +#' +#' @section Dataset Introduced: +#' *In Development* +#' +"constants" + +#' Lab tests for one suffering from an illness +#' +#' @description +#' +#' A dataset with artificial daily lab data for a patient with Yellow Fever +#' (YF). The table comprises laboratory findings for the patient from day 3 of +#' illness onset until day 9 (after which the patient died). YF viral DNA was +#' found in serum samples from day 3, where the viral load reached 14,000 copies +#' per mL. Several medical interventions were taken to help the patient, +#' including the administration of fresh frozen plasma, platelets, red cells, +#' and coagulation factor VIII. The patient also received advanced support +#' treatment in the form of mechanical ventilation and plasmapheresis. Though +#' the patient's temperature remained stable during their illness, +#' unfortunately, the patient's condition did not improve. On days 7 and 8, the +#' patient's health declined further, with symptoms such as nosebleeds, +#' gastrointestinal bleeding, and hematoma. +#' +#' @details +#' +#' The various tests are identified in the `test` column. The following listing +#' provides full names for any of the abbreviations seen in that column. +#' +#' \itemize{ +#' \item `"WBC"`: white blood cells. +#' \item `"RBC"`: red blood cells. +#' \item `"Hb"`: hemoglobin. +#' \item `"PLT"`: platelets. +#' \item `"ALT"`: alanine aminotransferase. +#' \item `"AST"`: aspartate aminotransferase. +#' \item `"TBIL"`: total bilirubin. +#' \item `"DBIL"`: direct bilirubin. +#' \item `"NH3"`: hydrogen nitride. +#' \item `"PT"`: prothrombin time. +#' \item `"APTT"`: activated partial thromboplastin time. +#' \item `"PTA"`: prothrombin time activity. +#' \item `"DD"`: D-dimer. +#' \item `"FDP"`: fibrinogen degradation products. +#' \item `"LDH"`: lactate dehydrogenase. +#' \item `"HBDH"`: hydroxybutyrate dehydrogenase. +#' \item `"CK"`: creatine kinase. +#' \item `"CKMB"`: the MB fraction of creatine kinase. +#' \item `"BNP"`: B-type natriuetic peptide. +#' \item `"MYO"`: myohemoglobin. +#' \item `"TnI"`: troponin inhibitory. +#' \item `"CREA"`: creatinine. +#' \item `"BUN"`: blood urea nitrogen. +#' \item `"AMY"`: amylase. +#' \item `"LPS"`: lipase. +#' \item `"K"`: kalium. +#' \item `"Na"`: sodium. +#' \item `"Cl"`: chlorine. +#' \item `"Ca"`: calcium. +#' \item `"P"`: phosphorus. +#' \item `"Lac"`: lactate, blood. +#' \item `"CRP"`: c-reactive protein. +#' \item `"PCT"`: procalcitonin. +#' \item `"IL-6"`: interleukin-6. +#' \item `"CD3+CD4+"`: CD4+T lymphocytes. +#' \item `"CD3+CD8+"`: CD8+T lymphocytes. +#' } +#' +#' @format A tibble with 39 rows and 11 variables: +#' \describe{ +#' \item{test}{The name of the test.} +#' \item{units}{The measurement units for the test.} +#' \item{day_3,day_4,day_5,day_6,day_7,day_8,day_9}{Measurement values +#' associated with each test administered. If `NA` then the test either could +#' not be performed properly.)} +#' \item{norm_l,norm_u}{Lower and upper bounds for the normal range associated +#' with the test.} +#' } +#' +#' @section Examples: +#' +#' Here is a glimpse at the data available in `illness`. +#' +#' ```{r} +#' dplyr::glimpse(illness) +#' ``` +#' +#' @family datasets +#' @section Dataset ID and Badge: +#' DATA-10 +#' +#' \if{html}{\out{ +#' `r data_get_image_tag(file = "dataset_illness.png")` +#' }} +#' +#' @section Dataset Introduced: +#' *In Development* +#' +"illness" + #' An ADSL-flavored clinical trial toy dataset #' #' @description @@ -624,7 +764,7 @@ #' #' @family datasets #' @section Dataset ID and Badge: -#' DATA-9 +#' DATA-11 #' #' \if{html}{\out{ #' `r data_get_image_tag(file = "dataset_rx_adsl.png")` @@ -697,7 +837,7 @@ #' #' @family datasets #' @section Dataset ID and Badge: -#' DATA-10 +#' DATA-12 #' #' \if{html}{\out{ #' `r data_get_image_tag(file = "dataset_rx_addv.png")` diff --git a/R/dt_boxhead.R b/R/dt_boxhead.R index 5e33eaf375..89d2116ad5 100644 --- a/R/dt_boxhead.R +++ b/R/dt_boxhead.R @@ -55,22 +55,21 @@ dt_boxhead_init <- function(data) { # - `default` appears as a column with values below # - `stub` appears as part of a table stub, set to the left # and styled differently - # - `row_group` uses values as categoricals and groups rows + # - `row_group` uses categorical values and groups rows # under row group headings # - `hidden` hides this column from the final table render # but retains values to use in expressions # - `hidden_at_px` similar to hidden but takes a list of # screen widths (in px) whereby the column would be hidden type = "default", - # # The shared spanner label between columns, where column names - # # act as the keys - # spanner_label = empty_list, - # # The label for row groups, which is maintained as a list of - # # labels by render context (e.g., HTML, LaTeX, etc.) - # row_group_label = lapply(seq_along(names(data)), function(x) NULL), # The presentation label, which is a list of labels by # render context (e.g., HTML, LaTeX, etc.) column_label = as.list(column_labels), + # Units for the column label, written in a shorthand notation + column_units = NA_character_, + # A pattern to use when arranging the `column_label` and the + # `column_units` + column_pattern = NA_character_, # The alignment of the column ("left", "right", "center") column_align = "center", # The width of the column in `px` @@ -113,6 +112,8 @@ dt_boxhead_add_var <- function( var, type, column_label = list(var), + column_units = NA_character_, + column_pattern = NA_character_, column_align = "left", column_width = list(NULL), hidden_px = list(NULL), @@ -126,6 +127,8 @@ dt_boxhead_add_var <- function( var = var, type = type, column_label = column_label, + column_units = column_units, + column_pattern = column_pattern, column_align = column_align, column_width = column_width, hidden_px = hidden_px @@ -189,6 +192,24 @@ dt_boxhead_edit_column_label <- function(data, var, column_label) { ) } +dt_boxhead_edit_column_units <- function(data, var, column_units) { + + dt_boxhead_edit( + data = data, + var = var, + column_units = column_units + ) +} + +dt_boxhead_edit_column_pattern <- function(data, var, column_pattern) { + + dt_boxhead_edit( + data = data, + var = var, + column_pattern = column_pattern + ) +} + dt_boxhead_get_vars <- function(data) { dt_boxhead_get(data = data)$var } @@ -263,7 +284,8 @@ dt_boxhead_get_alignment_by_var <- function(data, var) { check_names_dt_boxhead_expr <- function(expr) { if (!all(names(expr) %in% c( - "type", "column_label", "column_align", "column_width", "hidden_px" + "type", "column_label", "column_units", "column_pattern", + "column_align", "column_width", "hidden_px" ))) { cli::cli_abort("Expressions must use names available in `dt_boxhead`.") } @@ -283,6 +305,54 @@ dt_boxhead_build <- function(data, context) { boxh$column_label <- lapply(boxh$column_label, function(label) process_text(label, context)) + # Merge column units into column labels + if (!all(is.na(boxh$column_units))) { + + for (i in seq_along(boxh$column_label)) { + + if (is.na(boxh[["column_units"]][i])) next + + column_label <- unlist(boxh[["column_label"]][i]) + + units <- boxh[["column_units"]][i] + column_pattern <- boxh[["column_pattern"]][i] + + units_built <- + render_units( + define_units(units_notation = units), + context = context + ) + + if (column_pattern == "" && grepl(units, column_label, fixed = TRUE)) { + + # With `column_pattern` equal to `""`, we can surmise that this was + # set automatically by `cols_label()`; the mechanism now is to replace + # the units text in the label with the 'built' units text + + column_label <- gsub(units, units_built, column_label, fixed = TRUE) + + } else { + + if (is.na(column_pattern)) { + + # Obtain the default `column_pattern` (which that is settable in the + # `column_labels.units_pattern` option of `tab_options()` + column_pattern <- + dt_options_get_value( + data = data, + option = "column_labels_units_pattern" + ) + } + + column_pattern <- gsub("{1}", column_label, column_pattern, fixed = TRUE) + column_pattern <- gsub("{2}", units_built, column_pattern, fixed = TRUE) + column_label <- column_pattern + } + + boxh$column_label[i] <- list(column_label) + } + } + dt_boxhead_set(data = data, boxh = boxh) } diff --git a/R/dt_options.R b/R/dt_options.R index 14ff35b89e..76fdc993e3 100644 --- a/R/dt_options.R +++ b/R/dt_options.R @@ -122,6 +122,7 @@ dt_options_tbl <- "column_labels_border_lr_width", TRUE, "column_labels", "px", "1px", "column_labels_border_lr_color", TRUE, "column_labels", "value", "#D3D3D3", "column_labels_hidden", FALSE, "column_labels", "logical", FALSE, + "column_labels_units_pattern", FALSE, "column_labels", "value", "{1}, {2}", "row_group_background_color", TRUE, "row_group", "value", NA_character_, "row_group_font_size", TRUE, "row_group", "px", "100%", "row_group_font_weight", TRUE, "row_group", "value", "initial", diff --git a/R/format_data.R b/R/format_data.R index 8b7d1508ab..b45c1f66f4 100644 --- a/R/format_data.R +++ b/R/format_data.R @@ -6700,6 +6700,252 @@ format_bins_by_context <- function(x, sep, fmt, context) { x_str } +#' Format measurement units +#' +#' @description +#' +#' The `fmt_units()` function lets you better format measurement units in the +#' table body. These must conform to **gt**'s specialized units notation (e.g., +#' `"J Hz^-1 mol^-1"` can be used to generate units for the +#' *molar Planck constant*) for the best conversion. The notation here provides +#' several conveniences for defining units, so as long as the values to be +#' formatted conform to this syntax, you'll obtain nicely-formatted units no +#' matter what the table output format might be (i.e., HTML, LaTeX, RTF, etc.). +#' Details pertaining to the units notation can be found in the section entitled +#' *How to use **gt**'s units notation*. +#' +#' @inheritParams fmt_number +#' +#' @return An object of class `gt_tbl`. +#' +#' @section Targeting cells with `columns` and `rows`: +#' +#' Targeting of values is done through `columns` and additionally by `rows` (if +#' nothing is provided for `rows` then entire columns are selected). The +#' `columns` argument allows us to target a subset of cells contained in the +#' resolved columns. We say resolved because aside from declaring column names +#' in `c()` (with bare column names or names in quotes) we can use +#' **tidyselect**-style expressions. This can be as basic as supplying a select +#' helper like `starts_with()`, or, providing a more complex incantation like +#' +#' `where(~ is.numeric(.x) && max(.x, na.rm = TRUE) > 1E6)` +#' +#' which targets numeric columns that have a maximum value greater than +#' 1,000,000 (excluding any `NA`s from consideration). +#' +#' By default all columns and rows are selected (with the `everything()` +#' defaults). Cell values that are incompatible with a given formatting function +#' will be skipped over, like `character` values and numeric `fmt_*()` +#' functions. So it's safe to select all columns with a particular formatting +#' function (only those values that can be formatted will be formatted), but, +#' you may not want that. One strategy is to format the bulk of cell values with +#' one formatting function and then constrain the columns for later passes with +#' other types of formatting (the last formatting done to a cell is what you get +#' in the final output). +#' +#' Once the columns are targeted, we may also target the `rows` within those +#' columns. This can be done in a variety of ways. If a stub is present, then we +#' potentially have row identifiers. Those can be used much like column names in +#' the `columns`-targeting scenario. We can use simpler **tidyselect**-style +#' expressions (the select helpers should work well here) and we can use quoted +#' row identifiers in `c()`. It's also possible to use row indices (e.g., +#' `c(3, 5, 6)`) though these index values must correspond to the row numbers of +#' the input data (the indices won't necessarily match those of rearranged rows +#' if row groups are present). One more type of expression is possible, an +#' expression that takes column values (can involve any of the available columns +#' in the table) and returns a logical vector. This is nice if you want to base +#' formatting on values in the column or another column, or, you'd like to use a +#' more complex predicate expression. +#' +#' @section How to use **gt**'s units notation: +#' +#' The units notation involves a shorthand of writing units that feels familiar +#' and is fine-tuned for the task at hand. Each unit is treated as a separate +#' entity (parentheses and other symbols included) and the addition of subscript +#' text and exponents is flexible and relatively easy to formulate. This is all +#' best shown with examples: +#' +#' - `"m/s"` and `"m / s"` both render as `"m/s"` +#' - `"m s^-1"` will appear with the `"-1"` exponent intact +#' - `"m \s"` gives the the same result, as `"\"` is equivalent to +#' `"^-1"` +#' - `"E_h"` will render an `"E"` with the `"h"` subscript +#' - `"t_i^2.5"` provides a `t` with an `"i"` subscript and a `"2.5"` exponent +#' - `"m[_0^2]"` will use overstriking to set both scripts vertically +#' - `"g/L %C6H12O6%"` uses a chemical formula (enclosed in a pair of `"%"` +#' characters) as a unit partial, and the formula will render correctly with +#' subscripted numbers +#' - Common units that are difficult to write using ASCII text may be implicitly +#' converted to the correct characters (e.g., the `"u"` in `"ug"`, `"um"`, +#' `"uL"`, and `"umol"` will be converted to the Greek *mu* symbol; `"degC"` +#' and `"degF"` will render a degree sign before the temperature unit) +#' - We can transform shorthand symbol/unit names enclosed in `":"` (e.g., +#' `":angstrom:"`, `":ohm:"`, etc.) into proper symbols +#' - The components of a unit (unit name, subscript, and exponent) can be +#' fully or partially italicized/emboldened by surrounding text with `"*"` or +#' `"**"` +#' +#' @section Examples: +#' +#' Let's use the [`illness`] dataset and create a new **gt** table. The `units` +#' column contains character values in **gt**'s specialized units notation +#' (e.g., `"x10^9 / L"`) so the `fmt_units()` function was used to better format +#' those units. +#' +#' ```r +#' illness |> +#' gt() |> +#' fmt_units(columns = units) |> +#' sub_missing(columns = -starts_with("norm")) |> +#' sub_missing(columns = c(starts_with("norm"), units), missing_text = "") |> +#' sub_large_vals(rows = test == "MYO", threshold = 1200) |> +#' fmt_number( +#' decimals = 2, +#' drop_trailing_zeros = TRUE +#' ) |> +#' tab_header(title = "Laboratory Findings for the YF Patient") |> +#' tab_spanner(label = "Day", columns = starts_with("day")) |> +#' cols_label_with(fn = ~ gsub("day_", "", .)) |> +#' cols_merge_range(col_begin = norm_l, col_end = norm_u) |> +#' cols_label( +#' starts_with("norm") ~ "Normal Range", +#' test ~ "Test", +#' units ~ "Units" +#' ) |> +#' cols_width( +#' starts_with("day") ~ px(80), +#' everything() ~ px(120) +#' ) |> +#' tab_style( +#' style = cell_text(align = "center"), +#' locations = cells_column_labels(columns = starts_with("day")) +#' ) |> +#' tab_style( +#' style = cell_fill(color = "aliceblue"), +#' locations = cells_body(columns = c(test, units)) +#' ) |> +#' opt_vertical_padding(scale = 0.4) |> +#' opt_align_table_header(align = "left") |> +#' tab_options(heading.padding = px(10)) +#' ``` +#' +#' \if{html}{\out{ +#' `r man_get_image_tag(file = "man_fmt_units_1.png")` +#' }} +#' +#' The [`constants`] dataset contains values for hundreds of fundamental +#' physical constants. We'll take a subset of values that have some molar basis +#' and generate a **gt** table from that. Like the [`illness`] dataset, this one +#' has a `units` column so, again, the `fmt_units()` function will be used to +#' format those units. Here, the preference preference in units typesetting +#' was for positive and negative exponents (e.g., not `" / "` +#' but rather `" ^-1"`). +#' +#' ```r +#' constants |> +#' dplyr::filter(grepl("molar", name)) |> +#' gt() |> +#' cols_hide(columns = uncert) |> +#' fmt_units(columns = units) |> +#' fmt_scientific(columns = value, decimals = 3) |> +#' tab_header(title = "Physical Constants Having a Molar Basis") |> +#' tab_options(column_labels.hidden = TRUE) +#' ``` +#' +#' \if{html}{\out{ +#' `r man_get_image_tag(file = "man_fmt_units_2.png")` +#' }} +#' +#' @family data formatting functions +#' @section Function ID: +#' 3-18 +#' +#' @section Function Introduced: +#' *In Development* +#' +#' @import rlang +#' @export +fmt_units <- function( + data, + columns = everything(), + rows = everything() +) { + + # Perform input object validation + stop_if_not_gt_tbl(data = data) + + # Declare formatting function compatibility + compat <- c("character", "factor") + + # In this case where strict mode is being used (with the option + # called "gt.strict_column_fmt"), stop the function if any of the + # resolved columns have data that is incompatible with this formatter + if ( + !column_classes_are_valid( + data = data, + columns = {{ columns }}, + valid_classes = compat + ) + ) { + if (isTRUE(getOption("gt.strict_column_fmt", TRUE))) { + cli::cli_abort( + "The `fmt_units()` function can only be used on `columns` + with character or factor data." + ) + } + } + + # Pass `data`, `columns`, `rows`, and the formatting + # functions as a function list to `fmt()` + fmt( + data = data, + columns = {{ columns }}, + rows = {{ rows }}, + fns = list( + html = function(x) { + format_units_by_context(x, context = "html") + }, + latex = function(x) { + format_units_by_context(x, context = "latex") + }, + rtf = function(x) { + format_units_by_context(x, context = "rtf") + }, + word = function(x) { + format_units_by_context(x, context = "word") + }, + default = function(x) { + format_units_by_context(x, context = "plain") + } + ) + ) +} + +format_units_by_context <- function(x, context = "html") { + + # Generate an vector of empty strings that will eventually + # contain all of the ranged value text + x_str <- character(length(x)) + + x_str_non_missing <- x[!is.na(x)] + + x_str_non_missing <- as.character(x_str_non_missing) + + x_str_non_missing <- + vapply( + seq_along(x_str_non_missing), + FUN.VALUE = character(1), + USE.NAMES = FALSE, + FUN = function(x) { + render_units(define_units(x_str_non_missing[x]), context = context) + } + ) + + x_str[!is.na(x)] <- x_str_non_missing + x_str[is.na(x)] <- as.character(NA_character_) + x_str +} + #' Format URLs to generate links #' #' @description @@ -6954,7 +7200,7 @@ format_bins_by_context <- function(x, sep, fmt, context) { #' #' @family data formatting functions #' @section Function ID: -#' 3-18 +#' 3-19 #' #' @section Function Introduced: #' `v0.9.0` (Mar 31, 2023) @@ -7378,7 +7624,7 @@ fmt_url <- function( #' #' @family data formatting functions #' @section Function ID: -#' 3-19 +#' 3-20 #' #' @section Function Introduced: #' `v0.9.0` (Mar 31, 2023) @@ -7708,7 +7954,7 @@ fmt_image <- function( #' #' @family data formatting functions #' @section Function ID: -#' 3-20 +#' 3-21 #' #' @section Function Introduced: #' `v0.9.0` (Mar 31, 2023) @@ -7970,7 +8216,7 @@ fmt_flag <- function( #' #' @family data formatting functions #' @section Function ID: -#' 3-21 +#' 3-22 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -8116,7 +8362,7 @@ fmt_markdown <- function( #' #' @family data formatting functions #' @section Function ID: -#' 3-22 +#' 3-23 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -8324,7 +8570,7 @@ fmt_passthrough <- function( #' #' @family data formatting functions #' @section Function ID: -#' 3-23 +#' 3-24 #' #' @section Function Introduced: #' `v0.9.0` (Mar 31, 2023) @@ -8643,7 +8889,7 @@ fmt_auto <- function( #' #' @family data formatting functions #' @section Function ID: -#' 3-24 +#' 3-25 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) diff --git a/R/gt_group.R b/R/gt_group.R index e0d5322300..7a9559d93d 100644 --- a/R/gt_group.R +++ b/R/gt_group.R @@ -675,6 +675,7 @@ grp_options <- function( column_labels.border.lr.width = NULL, column_labels.border.lr.color = NULL, column_labels.hidden = NULL, + column_labels.units_pattern = NULL, row_group.background.color = NULL, row_group.font.size = NULL, row_group.font.weight = NULL, diff --git a/R/helpers.R b/R/helpers.R index 405d42ce90..f2833ecd3e 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -26,11 +26,13 @@ #' #' @description #' -#' Markdown! It's a wonderful thing. We can use it in certain places (e.g., -#' footnotes, source notes, the table title, etc.) and expect it to render to -#' HTML as Markdown does. There is the [html()] helper that allows you to ferry -#' in HTML but this function `md()`... it's almost like a two-for-one deal (you -#' get to use Markdown plus any HTML fragments *at the same time*). +#' Markdown text can be used in certain places in a **gt** table, and this is +#' wherever new text is defined (e.g., footnotes, source notes, the table title, +#' etc.). Using Markdown is advantageous for styling text since it will be +#' rendered correctly to the the output format of the **gt** table. There is +#' also the [html()] helper that allows you use HTML exclusively (for tables +#' expressly meant for HTML output) but `md()` allows for both; you get to use +#' Markdown plus any HTML fragments at the same time. #' #' @param text *Markdown text* #' @@ -134,20 +136,6 @@ html <- function(text, ...) { htmltools::HTML(text, ...) } -#' Does an object have the `html` class? -#' -#' @noRd -is_html <- function(x) { - inherits(x, "html") && isTRUE(attr(x, "html")) -} - -#' Does an object have the `rtf_text` class? -#' -#' @noRd -is_rtf <- function(x) { - inherits(x, "rtf_text") -} - #' Helper for providing a numeric value as pixels value #' #' @description @@ -264,6 +252,460 @@ pct <- function(x) { paste0(x, "%") } +#' Supply a custom currency symbol to `fmt_currency()` +#' +#' @description +#' +#' The `currency()` helper function makes it easy to specify a context-aware +#' currency symbol to `currency` argument of [fmt_currency()]. Since **gt** can +#' render tables to several output formats, `currency()` allows for different +#' variations of the custom symbol based on the output context (which are +#' `html`, `latex`, `rtf`, and `default`). The number of decimal places for +#' the custom currency defaults to `2`, however, a value set for the `decimals` +#' argument of [fmt_currency()] will take precedence. +#' +#' @details +#' +#' We can use any combination of `html`, `latex`, `rtf`, and `default` as named +#' arguments for the currency text in each of the namesake contexts. The +#' `default` value is used as a fallback when there doesn't exist a dedicated +#' currency text value for a particular output context (e.g., when a table is +#' rendered as HTML and we use `currency(latex = "LTC", default = "ltc")`, the +#' currency symbol will be `"ltc"`. For convenience, if we provide only a single +#' string without a name, it will be taken as the `default` (i.e., +#' `currency("ltc")` is equivalent to `currency(default = "ltc")`). However, if +#' we were to specify currency strings for multiple output contexts, names are +#' required each and every context. +#' +#' @param ... *Currency symbols by output context* +#' +#' `` --- **required** (or, use `.list`) +#' +#' One or more named arguments using output contexts as the names and +#' currency symbol text as the values. +#' +#' @param .list *Alternative to `...`* +#' +#' `` --- **required** (or, use `...`) +#' +#' Allows for the use of a list as an input alternative to `...`. +#' +#' @return A list object of class `gt_currency`. +#' +#' @section Examples: +#' +#' Use the [`exibble`] dataset to create a **gt** table. Within the +#' [fmt_currency()] call, we'll format the `currency` column to have currency +#' values in guilder (a defunct Dutch currency). We can register this custom +#' currency with the `currency()` helper function, supplying the `"ƒ"` HTML +#' entity for `html` outputs and using `"f"` for any other type of **gt** +#' output. +#' +#' ```r +#' exibble |> +#' gt() |> +#' fmt_currency( +#' columns = currency, +#' currency = currency( +#' html = "ƒ", +#' default = "f" +#' ), +#' decimals = 2 +#' ) +#' ``` +#' +#' \if{html}{\out{ +#' `r man_get_image_tag(file = "man_currency_1.png")` +#' }} +#' +#' @family helper functions +#' @section Function ID: +#' 8-5 +#' +#' @section Function Introduced: +#' `v0.2.0.5` (March 31, 2020) +#' +#' @export +currency <- function( + ..., + .list = list2(...) +) { + + # Collect a named list of currencies + currency_list <- .list + + # Stop function if the currency list contains no values + if (length(currency_list) == 0) { + cli::cli_abort("The `currency()` function must be provided with currency symbols.") + } + + # If only a single string is provided, upgrade the `currency_list` + # to have that string be the `default` value + if (length(currency_list) == 1 && !rlang::is_named(currency_list)) { + currency_list <- list(default = currency_list[[1]]) + } + + # Stop function if `currency_list` isn't entirely named + if (!rlang::is_named(currency_list)) { + cli::cli_abort("Names must be provided for all output contexts.") + } + + # Stop function if all names are not part of the supported contexts + validate_contexts(contexts = names(currency_list)) + + # Stop function if there are duplicated names + if (!rlang::is_dictionaryish(currency_list)) { + cli::cli_abort("There cannot be any duplicate names for output contexts.") + } + + # Set the `gt_currency` class + class(currency_list) <- "gt_currency" + + currency_list +} + +#' Adjust the luminance for a palette of colors +#' +#' @description +#' +#' The `adjust_luminance()` function can brighten or darken a palette of colors +#' by an arbitrary number of steps, which is defined by a real number between +#' -2.0 and 2.0. The transformation of a palette by a fixed step in this +#' function will tend to apply greater darkening or lightening for those colors +#' in the midrange compared to any very dark or very light colors in the input +#' palette. +#' +#' @details +#' +#' This function can be useful when combined with the [data_color()] function's +#' `palette` argument, which can use a vector of colors or any of the `col_*` +#' functions from the **scales** package (all of which have a `palette` +#' argument). +#' +#' @param colors *Color vector* +#' +#' `vector` --- **required** +#' +#' This is the vector of colors that will undergo an adjustment in luminance. +#' Each color value provided must either be a color name (in the set of colors +#' provided by `grDevices::colors()`) or a hexadecimal string in the form of +#' "#RRGGBB" or "#RRGGBBAA". +#' +#' @param steps *Adjustment level* +#' +#' `scalar(-2>=val>=2)` --- **required** +#' +#' A positive or negative factor by which the luminance of colors in the +#' `colors` vector will be adjusted. Must be a number between `-2.0` and +#' `2.0`. +#' +#' @return A vector of color values. +#' +#' @section Examples: +#' +#' Get a palette of 8 pastel colors from the **RColorBrewer** package. +#' +#' ```r +#' pal <- RColorBrewer::brewer.pal(8, "Pastel2") +#' ``` +#' +#' Create lighter and darker variants of the base palette (one step lower, one +#' step higher). +#' +#' ```r +#' pal_darker <- pal |> adjust_luminance(-1.0) +#' pal_lighter <- pal |> adjust_luminance(+1.0) +#' ``` +#' +#' Create a tibble and make a **gt** table from it. Color each column in order +#' of increasingly darker palettes (with [data_color()]). +#' +#' ```r +#' dplyr::tibble(a = 1:8, b = 1:8, c = 1:8) |> +#' gt() |> +#' data_color( +#' columns = a, +#' colors = scales::col_numeric( +#' palette = pal_lighter, +#' domain = c(1, 8) +#' ) +#' ) |> +#' data_color( +#' columns = b, +#' colors = scales::col_numeric( +#' palette = pal, +#' domain = c(1, 8) +#' ) +#' ) |> +#' data_color( +#' columns = c, +#' colors = scales::col_numeric( +#' palette = pal_darker, +#' domain = c(1, 8) +#' ) +#' ) +#' ``` +#' +#' \if{html}{\out{ +#' `r man_get_image_tag(file = "man_adjust_luminance_1.png")` +#' }} +#' +#' @family helper functions +#' @section Function ID: +#' 8-6 +#' +#' @section Function Introduced: +#' `v0.2.0.5` (March 31, 2020) +#' +#' @export +adjust_luminance <- function( + colors, + steps +) { + + # Stop if steps is beyond an acceptable range + if (steps > 2.0 | steps < -2.0) { + cli::cli_abort( + "The value provided for `steps` (`{steps}`) must be between `-2.0` and `+2.0`." + ) + } + + # Get a matrix of values in the RGB color space + rgb_matrix <- t(grDevices::col2rgb(colors, alpha = TRUE)) / 255 + + # Obtain the alpha values + alpha <- rgb_matrix[, "alpha"] + + # Get a matrix of values in the Luv color space + luv_matrix <- grDevices::convertColor(rgb_matrix[, 1:3], "sRGB", "Luv") + + # Apply calculations to obtain values in the HCL color space + h <- atan2(luv_matrix[, "v"], luv_matrix[, "u"]) * 180 / pi + c <- sqrt(luv_matrix[, "u"]^2 + luv_matrix[, "v"]^2) + l <- luv_matrix[, "L"] + + # Scale luminance to occupy [0, 1] + y <- l / 100. + + # Obtain `x` positions of luminance values along a sigmoid function + x <- log(-(y / (y - 1))) + + # Calculate new luminance values based on a fixed step-change in `x` + y_2 <- 1 / (1 + exp(-(x + steps))) + + # Rescale the new luminance values to [0, 100] + l <- y_2 * 100. + + # Obtain hexadecimal colors from the modified HCL color values + grDevices::hcl(h, c, l, alpha = alpha) +} + +#' Define measurement units with **gt**'s units notation +#' +#' The `define_units()` function is available for working with text in **gt**'s +#' units notation. +#' +#' @param units_notation *Text in specialized units notation* +#' +#' `scalar` --- **required** +#' +#' A single string that defines the units (e.g., `"m/s"`) to be used. +#' +#' @return An object of class `units_definition`. +#' +#' @section How to use **gt**'s units notation: +#' +#' The units notation involves a shorthand of writing units that feels familiar +#' and is fine-tuned for the task at hand. Each unit is treated as a separate +#' entity (parentheses and other symbols included) and the addition of subscript +#' text and exponents is flexible and relatively easy to formulate. This is all +#' best shown with examples: +#' +#' - `"m/s"` and `"m / s"` both render as `"m/s"` +#' - `"m s^-1"` will appear with the `"-1"` exponent intact +#' - `"m \s"` gives the the same result, as `"\"` is equivalent to +#' `"^-1"` +#' - `"E_h"` will render an `"E"` with the `"h"` subscript +#' - `"t_i^2.5"` provides a `t` with an `"i"` subscript and a `"2.5"` exponent +#' - `"m[_0^2]"` will use overstriking to set both scripts vertically +#' - `"g/L %C6H12O6%"` uses a chemical formula (enclosed in a pair of `"%"` +#' characters) as a unit partial, and the formula will render correctly with +#' subscripted numbers +#' - Common units that are difficult to write using ASCII text may be implicitly +#' converted to the correct characters (e.g., the `"u"` in `"ug"`, `"um"`, +#' `"uL"`, and `"umol"` will be converted to the Greek *mu* symbol; `"degC"` +#' and `"degF"` will render a degree sign before the temperature unit) +#' - We can transform shorthand symbol/unit names enclosed in `":"` (e.g., +#' `":angstrom:"`, `":ohm:"`, etc.) into proper symbols +#' - The components of a unit (unit name, subscript, and exponent) can be +#' fully or partially italicized/emboldened by surrounding text with `"*"` or +#' `"**"` +#' +#' @family helper functions +#' @section Function ID: +#' 8-7 +#' +#' @section Function Introduced: +#' *In Development* +#' +#' @export +define_units <- function(units_notation) { + + # Trim any incoming `{{`/`}}` + input <- gsub("^\\{\\{\\s*|\\s*\\}\\}$", "", units_notation) + + # Get a vector of raw tokens + tokens_vec <- unlist(strsplit(input, split = " ")) + + # Remove any empty tokens + tokens_vec <- tokens_vec[tokens_vec != ""] + + # Replace any instances of `/` with `^-1` + tokens_vec <- + vapply( + tokens_vec, + FUN.VALUE = character(1), + USE.NAMES = FALSE, + FUN = function(x) { + if (grepl("^/", x) && nchar(x) > 1) { + x <- gsub("^/", "", x) + x <- paste0(x, "^-1") + } + x + } + ) + + units_list <- list() + + for (i in seq_along(tokens_vec)) { + + tokens_vec_i <- tokens_vec[i] + + unit_subscript <- NA_character_ + sub_super_overstrike <- FALSE + chemical_formula <- FALSE + exponent <- NULL + + if ( + grepl("^%", tokens_vec_i) && + grepl("%$", tokens_vec_i) && + nchar(tokens_vec_i) > 2 + ) { + # Case where the unit is marked as a chemical formula + + chemical_formula <- TRUE + + # Extract the formula w/o the surrounding `%` signs + unit <- gsub("^%|%$", "", tokens_vec_i) + + } else if (grepl(".+?\\[_.+?\\^.+?\\]", tokens_vec_i)) { + # Case where both a subscript and exponent are present and + # an overstrike arrangement is necessary + + sub_super_overstrike <- TRUE + + # Extract the unit w/o subscript from the string + unit <- gsub("(.+?)\\[_.+?\\^.+?\\]", "\\1", tokens_vec_i) + + # Obtain only the subscript/exponent of the string + sub_exponent <- gsub(".+?\\[(_.+?\\^.+?)\\]", "\\1", tokens_vec_i) + + # Extract the content after the underscore but terminate + # before any `^`; this is the subscript + unit_subscript <- gsub("^_(.+?)(\\^.+?)$", "\\1", sub_exponent) + + # Extract the content after the caret but terminate before + # any `_`; this is the exponent + exponent <- gsub("_.+?\\^(.+?)", "\\1", sub_exponent) + + } else if (grepl(".+?_.+?\\^.+?", tokens_vec_i)) { + # Case where both a subscript and exponent are present and + # the subscript is set before the exponent + + # Extract the unit w/o subscript from the string + unit <- gsub("^(.+?)_.+?\\^.+?$", "\\1", tokens_vec_i) + + # Obtain only the subscript/exponent portion of the string + sub_exponent <- gsub("^.+?(_.+?\\^.+?)$", "\\1", tokens_vec_i) + + # Extract the content after the underscore but terminate + # before any `^`; this is the subscript + unit_subscript <- gsub("^_(.+?)\\^.+?$", "\\1", sub_exponent) + + # Extract the content after the caret but terminate before + # any `_`; this is the exponent + exponent <- gsub("^_.+?\\^(.+?)$", "\\1", sub_exponent) + + } else if (grepl("^", tokens_vec_i, fixed = TRUE)) { + # Case where only an exponent is present + + tokens_vec_i_split <- unlist(strsplit(tokens_vec_i, "^", fixed = TRUE)) + + unit <- tokens_vec_i_split[1] + exponent <- tokens_vec_i_split[2] + + } else if (grepl("_", tokens_vec_i, fixed = TRUE)) { + # Case where only a subscript is present + + tokens_vec_i_split <- unlist(strsplit(tokens_vec_i, "_", fixed = TRUE)) + + unit <- tokens_vec_i_split[1] + unit_subscript <- tokens_vec_i_split[2] + + } else { + unit <- tokens_vec_i + } + + units_list[[length(units_list) + 1]] <- + units_list_item( + token = tokens_vec_i, + unit = unit, + unit_subscript = unit_subscript, + exponent = exponent, + chemical_formula = chemical_formula, + sub_super_overstrike = sub_super_overstrike + ) + } + + names(units_list) <- tokens_vec + class(units_list) <- "units_definition" + + units_list +} + +units_list_item <- function( + token, + unit, + unit_subscript = NULL, + exponent = NULL, + sub_super_overstrike = FALSE, + chemical_formula = FALSE +) { + + list_item <- + list( + token = token, + unit = unit, + unit_subscript = NA_character_, + exponent = NA_character_, + sub_super_overstrike = FALSE, + chemical_formula = FALSE + ) + + if (!is.null(exponent)) { + list_item[["exponent"]] <- exponent + } + + if (!is.null(unit_subscript)) { + list_item[["unit_subscript"]] <- unit_subscript + } + + list_item[["sub_super_overstrike"]] <- sub_super_overstrike + list_item[["chemical_formula"]] <- chemical_formula + + list_item +} + #' Select helper for targeting the stub column #' #' @description @@ -306,7 +748,7 @@ pct <- function(x) { #' #' @family helper functions #' @section Function ID: -#' 8-5 +#' 8-8 #' #' @section Function Introduced: #' `v0.8.0` (November 16, 2022) @@ -401,7 +843,7 @@ stub <- function() { #' #' @family helper functions #' @section Function ID: -#' 8-6 +#' 8-9 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -514,7 +956,7 @@ cells_title <- function(groups = c("title", "subtitle")) { #' #' @family helper functions #' @section Function ID: -#' 8-7 +#' 8-10 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -623,7 +1065,7 @@ cells_stubhead <- function() { #' #' @family helper functions #' @section Function ID: -#' 8-8 +#' 8-11 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -754,7 +1196,7 @@ cells_column_spanners <- function(spanners = everything()) { #' #' @family helper functions #' @section Function ID: -#' 8-9 +#' 8-12 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -877,7 +1319,7 @@ cells_column_labels <- function(columns = everything()) { #' #' @family helper functions #' @section Function ID: -#' 8-10 +#' 8-13 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -1018,7 +1460,7 @@ cells_group <- function(groups = everything()) { #' #' @family helper functions #' @section Function ID: -#' 8-11 +#' 8-14 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -1170,7 +1612,7 @@ cells_stub <- function(rows = everything()) { #' #' @family helper functions #' @section Function ID: -#' 8-12 +#' 8-15 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -1368,7 +1810,7 @@ cells_body <- function( #' #' @family helper functions #' @section Function ID: -#' 8-13 +#' 8-16 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -1538,7 +1980,7 @@ cells_summary <- function( #' #' @family helper functions #' @section Function ID: -#' 8-14 +#' 8-17 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -1704,7 +2146,7 @@ cells_grand_summary <- function( #' #' @family helper functions #' @section Function ID: -#' 8-15 +#' 8-18 #' #' @section Function Introduced: #' `v0.3.0` (May 12, 2021) @@ -1841,7 +2283,7 @@ cells_stub_summary <- function( #' #' @family helper functions #' @section Function ID: -#' 8-16 +#' 8-19 #' #' @section Function Introduced: #' `v0.3.0` (May 12, 2021) @@ -1960,7 +2402,7 @@ cells_stub_grand_summary <- function(rows = everything()) { #' #' @family helper functions #' @section Function ID: -#' 8-17 +#' 8-20 #' #' @section Function Introduced: #' `v0.3.0` (May 12, 2021) @@ -2001,194 +2443,82 @@ cells_footnotes <- function() { #' bottom of a table: #' #' - [cells_title()]: targets the table title or the table subtitle depending on -#' the value given to the `groups` argument (`"title"` or `"subtitle"`). -#' - [cells_stubhead()]: targets the stubhead location, a cell of which is only -#' available when there is a stub; a label in that location can be created by -#' using the [tab_stubhead()] function. -#' - [cells_column_spanners()]: targets the spanner column labels with the -#' `spanners` argument; spanner column labels appear above the column labels. -#' - [cells_column_labels()]: targets the column labels with its `columns` -#' argument. -#' - [cells_row_groups()]: targets the row group labels in any available row -#' groups using the `groups` argument. -#' - [cells_stub()]: targets row labels in the table stub using the `rows` -#' argument. -#' - [cells_body()]: targets data cells in the table body using intersections of -#' `columns` and `rows`. -#' - [cells_summary()]: targets summary cells in the table body using the -#' `groups` argument and intersections of `columns` and `rows`. -#' - [cells_grand_summary()]: targets cells of the table's grand summary using -#' intersections of `columns` and `rows` -#' - [cells_stub_summary()]: targets summary row labels in the table stub using -#' the `groups` and `rows` arguments. -#' - [cells_stub_grand_summary()]: targets grand summary row labels in the table -#' stub using the `rows` argument. -#' - [cells_footnotes()]: targets all footnotes in the table footer (cannot be -#' used with [tab_footnote()]). -#' - [cells_source_notes()]: targets all source notes in the table footer -#' (cannot be used with [tab_footnote()]). -#' -#' When using any of the location helper functions with an appropriate function -#' that has a `locations` argument (e.g., [tab_style()]), multiple locations -#' can be targeted by enclosing several `cells_*()` helper functions in a -#' `list()` (e.g., `list(cells_body(), cells_grand_summary())`). -#' -#' @section Examples: -#' -#' Let's use a subset of the [`gtcars`] dataset to create a **gt** table. Add a -#' source note (with [tab_source_note()]) and style the source notes section -#' inside the [tab_style()] call by using the `cells_source_notes()` helper -#' function for the targeting via the `locations` argument. -#' -#' ```r -#' gtcars |> -#' dplyr::select(mfr, model, msrp) |> -#' dplyr::slice(1:5) |> -#' gt() |> -#' tab_source_note(source_note = "From edmunds.com") |> -#' tab_style( -#' style = cell_text( -#' color = "#A9A9A9", -#' size = "small" -#' ), -#' locations = cells_source_notes() -#' ) -#' ``` -#' -#' \if{html}{\out{ -#' `r man_get_image_tag(file = "man_cells_source_notes_1.png")` -#' }} -#' -#' @family helper functions -#' @section Function ID: -#' 8-18 -#' -#' @section Function Introduced: -#' `v0.3.0` (May 12, 2021) -#' -#' @import rlang -#' @export -cells_source_notes <- function() { - - # Create the `cells` object - cells <- list(groups = "source_notes") - - # Apply the `cells_source_notes` and `location_cells` classes - class(cells) <- c("cells_source_notes", "location_cells") - - cells -} - -#' Supply a custom currency symbol to `fmt_currency()` -#' -#' @description -#' -#' The `currency()` helper function makes it easy to specify a context-aware -#' currency symbol to `currency` argument of [fmt_currency()]. Since **gt** can -#' render tables to several output formats, `currency()` allows for different -#' variations of the custom symbol based on the output context (which are -#' `html`, `latex`, `rtf`, and `default`). The number of decimal places for -#' the custom currency defaults to `2`, however, a value set for the `decimals` -#' argument of [fmt_currency()] will take precedence. -#' -#' @details -#' -#' We can use any combination of `html`, `latex`, `rtf`, and `default` as named -#' arguments for the currency text in each of the namesake contexts. The -#' `default` value is used as a fallback when there doesn't exist a dedicated -#' currency text value for a particular output context (e.g., when a table is -#' rendered as HTML and we use `currency(latex = "LTC", default = "ltc")`, the -#' currency symbol will be `"ltc"`. For convenience, if we provide only a single -#' string without a name, it will be taken as the `default` (i.e., -#' `currency("ltc")` is equivalent to `currency(default = "ltc")`). However, if -#' we were to specify currency strings for multiple output contexts, names are -#' required each and every context. -#' -#' @param ... *Currency symbols by output context* -#' -#' `` --- **required** (or, use `.list`) -#' -#' One or more named arguments using output contexts as the names and -#' currency symbol text as the values. -#' -#' @param .list *Alternative to `...`* -#' -#' `` --- **required** (or, use `...`) -#' -#' Allows for the use of a list as an input alternative to `...`. +#' the value given to the `groups` argument (`"title"` or `"subtitle"`). +#' - [cells_stubhead()]: targets the stubhead location, a cell of which is only +#' available when there is a stub; a label in that location can be created by +#' using the [tab_stubhead()] function. +#' - [cells_column_spanners()]: targets the spanner column labels with the +#' `spanners` argument; spanner column labels appear above the column labels. +#' - [cells_column_labels()]: targets the column labels with its `columns` +#' argument. +#' - [cells_row_groups()]: targets the row group labels in any available row +#' groups using the `groups` argument. +#' - [cells_stub()]: targets row labels in the table stub using the `rows` +#' argument. +#' - [cells_body()]: targets data cells in the table body using intersections of +#' `columns` and `rows`. +#' - [cells_summary()]: targets summary cells in the table body using the +#' `groups` argument and intersections of `columns` and `rows`. +#' - [cells_grand_summary()]: targets cells of the table's grand summary using +#' intersections of `columns` and `rows` +#' - [cells_stub_summary()]: targets summary row labels in the table stub using +#' the `groups` and `rows` arguments. +#' - [cells_stub_grand_summary()]: targets grand summary row labels in the table +#' stub using the `rows` argument. +#' - [cells_footnotes()]: targets all footnotes in the table footer (cannot be +#' used with [tab_footnote()]). +#' - [cells_source_notes()]: targets all source notes in the table footer +#' (cannot be used with [tab_footnote()]). #' -#' @return A list object of class `gt_currency`. +#' When using any of the location helper functions with an appropriate function +#' that has a `locations` argument (e.g., [tab_style()]), multiple locations +#' can be targeted by enclosing several `cells_*()` helper functions in a +#' `list()` (e.g., `list(cells_body(), cells_grand_summary())`). #' #' @section Examples: #' -#' Use the [`exibble`] dataset to create a **gt** table. Within the -#' [fmt_currency()] call, we'll format the `currency` column to have currency -#' values in guilder (a defunct Dutch currency). We can register this custom -#' currency with the `currency()` helper function, supplying the `"ƒ"` HTML -#' entity for `html` outputs and using `"f"` for any other type of **gt** -#' output. +#' Let's use a subset of the [`gtcars`] dataset to create a **gt** table. Add a +#' source note (with [tab_source_note()]) and style the source notes section +#' inside the [tab_style()] call by using the `cells_source_notes()` helper +#' function for the targeting via the `locations` argument. #' #' ```r -#' exibble |> +#' gtcars |> +#' dplyr::select(mfr, model, msrp) |> +#' dplyr::slice(1:5) |> #' gt() |> -#' fmt_currency( -#' columns = currency, -#' currency = currency( -#' html = "ƒ", -#' default = "f" +#' tab_source_note(source_note = "From edmunds.com") |> +#' tab_style( +#' style = cell_text( +#' color = "#A9A9A9", +#' size = "small" #' ), -#' decimals = 2 +#' locations = cells_source_notes() #' ) #' ``` #' #' \if{html}{\out{ -#' `r man_get_image_tag(file = "man_currency_1.png")` +#' `r man_get_image_tag(file = "man_cells_source_notes_1.png")` #' }} #' #' @family helper functions #' @section Function ID: -#' 8-19 +#' 8-21 #' #' @section Function Introduced: -#' `v0.2.0.5` (March 31, 2020) +#' `v0.3.0` (May 12, 2021) #' +#' @import rlang #' @export -currency <- function( - ..., - .list = list2(...) -) { - - # Collect a named list of currencies - currency_list <- .list - - # Stop function if the currency list contains no values - if (length(currency_list) == 0) { - cli::cli_abort("The `currency()` function must be provided with currency symbols.") - } - - # If only a single string is provided, upgrade the `currency_list` - # to have that string be the `default` value - if (length(currency_list) == 1 && !rlang::is_named(currency_list)) { - currency_list <- list(default = currency_list[[1]]) - } - - # Stop function if `currency_list` isn't entirely named - if (!rlang::is_named(currency_list)) { - cli::cli_abort("Names must be provided for all output contexts.") - } - - # Stop function if all names are not part of the supported contexts - validate_contexts(contexts = names(currency_list)) +cells_source_notes <- function() { - # Stop function if there are duplicated names - if (!rlang::is_dictionaryish(currency_list)) { - cli::cli_abort("There cannot be any duplicate names for output contexts.") - } + # Create the `cells` object + cells <- list(groups = "source_notes") - # Set the `gt_currency` class - class(currency_list) <- "gt_currency" + # Apply the `cells_source_notes` and `location_cells` classes + class(cells) <- c("cells_source_notes", "location_cells") - currency_list + cells } #' Helper for defining custom text styles for table cells @@ -2334,7 +2664,7 @@ currency <- function( #' #' @family helper functions #' @section Function ID: -#' 8-20 +#' 8-22 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -2523,7 +2853,7 @@ cell_style_to_html.cell_text <- function(style) { #' #' @family helper functions #' @section Function ID: -#' 8-21 +#' 8-23 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -2670,7 +3000,7 @@ cell_style_to_html.cell_fill <- function(style) { #' #' @family helper functions #' @section Function ID: -#' 8-22 +#' 8-24 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -2790,142 +3120,6 @@ cell_style_structure <- function(name, obj, subclass = name) { style_obj } -#' Adjust the luminance for a palette of colors -#' -#' @description -#' -#' The `adjust_luminance()` function can brighten or darken a palette of colors -#' by an arbitrary number of steps, which is defined by a real number between -#' -2.0 and 2.0. The transformation of a palette by a fixed step in this -#' function will tend to apply greater darkening or lightening for those colors -#' in the midrange compared to any very dark or very light colors in the input -#' palette. -#' -#' @details -#' -#' This function can be useful when combined with the [data_color()] function's -#' `palette` argument, which can use a vector of colors or any of the `col_*` -#' functions from the **scales** package (all of which have a `palette` -#' argument). -#' -#' @param colors *Color vector* -#' -#' `vector` --- **required** -#' -#' This is the vector of colors that will undergo an adjustment in luminance. -#' Each color value provided must either be a color name (in the set of colors -#' provided by `grDevices::colors()`) or a hexadecimal string in the form of -#' "#RRGGBB" or "#RRGGBBAA". -#' -#' @param steps *Adjustment level* -#' -#' `scalar(-2>=val>=2)` --- **required** -#' -#' A positive or negative factor by which the luminance of colors in the -#' `colors` vector will be adjusted. Must be a number between `-2.0` and -#' `2.0`. -#' -#' @return A vector of color values. -#' -#' @section Examples: -#' -#' Get a palette of 8 pastel colors from the **RColorBrewer** package. -#' -#' ```r -#' pal <- RColorBrewer::brewer.pal(8, "Pastel2") -#' ``` -#' -#' Create lighter and darker variants of the base palette (one step lower, one -#' step higher). -#' -#' ```r -#' pal_darker <- pal |> adjust_luminance(-1.0) -#' pal_lighter <- pal |> adjust_luminance(+1.0) -#' ``` -#' -#' Create a tibble and make a **gt** table from it. Color each column in order -#' of increasingly darker palettes (with [data_color()]). -#' -#' ```r -#' dplyr::tibble(a = 1:8, b = 1:8, c = 1:8) |> -#' gt() |> -#' data_color( -#' columns = a, -#' colors = scales::col_numeric( -#' palette = pal_lighter, -#' domain = c(1, 8) -#' ) -#' ) |> -#' data_color( -#' columns = b, -#' colors = scales::col_numeric( -#' palette = pal, -#' domain = c(1, 8) -#' ) -#' ) |> -#' data_color( -#' columns = c, -#' colors = scales::col_numeric( -#' palette = pal_darker, -#' domain = c(1, 8) -#' ) -#' ) -#' ``` -#' -#' \if{html}{\out{ -#' `r man_get_image_tag(file = "man_adjust_luminance_1.png")` -#' }} -#' -#' @family helper functions -#' @section Function ID: -#' 8-23 -#' -#' @section Function Introduced: -#' `v0.2.0.5` (March 31, 2020) -#' -#' @export -adjust_luminance <- function( - colors, - steps -) { - - # Stop if steps is beyond an acceptable range - if (steps > 2.0 | steps < -2.0) { - cli::cli_abort( - "The value provided for `steps` (`{steps}`) must be between `-2.0` and `+2.0`." - ) - } - - # Get a matrix of values in the RGB color space - rgb_matrix <- t(grDevices::col2rgb(colors, alpha = TRUE)) / 255 - - # Obtain the alpha values - alpha <- rgb_matrix[, "alpha"] - - # Get a matrix of values in the Luv color space - luv_matrix <- grDevices::convertColor(rgb_matrix[, 1:3], "sRGB", "Luv") - - # Apply calculations to obtain values in the HCL color space - h <- atan2(luv_matrix[, "v"], luv_matrix[, "u"]) * 180 / pi - c <- sqrt(luv_matrix[, "u"]^2 + luv_matrix[, "v"]^2) - l <- luv_matrix[, "L"] - - # Scale luminance to occupy [0, 1] - y <- l / 100. - - # Obtain `x` positions of luminance values along a sigmoid function - x <- log(-(y / (y - 1))) - - # Calculate new luminance values based on a fixed step-change in `x` - y_2 <- 1 / (1 + exp(-(x + steps))) - - # Rescale the new luminance values to [0, 100] - l <- y_2 * 100. - - # Obtain hexadecimal colors from the modified HCL color values - grDevices::hcl(h, c, l, alpha = alpha) -} - #' Helper for creating a random `id` for a **gt** table #' #' @description @@ -2945,7 +3139,7 @@ adjust_luminance <- function( #' #' @family helper functions #' @section Function ID: -#' 8-24 +#' 8-25 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -2987,7 +3181,7 @@ latex_special_chars <- c( #' #' @family helper functions #' @section Function ID: -#' 8-25 +#' 8-26 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -3061,7 +3255,7 @@ escape_latex <- function(text) { #' #' @family helper functions #' @section Function ID: -#' 8-26 +#' 8-27 #' #' @section Function Introduced: #' `v0.2.0.5` (March 31, 2020) @@ -3172,7 +3366,7 @@ gt_latex_dependencies <- function() { #' #' @family helper functions #' @section Function ID: -#' 8-27 +#' 8-28 #' #' @section Function Introduced: #' `v0.2.2` (August 5, 2020) @@ -3247,7 +3441,7 @@ google_font <- function(name) { #' #' @family helper functions #' @section Function ID: -#' 8-28 +#' 8-29 #' #' @section Function Introduced: #' `v0.2.2` (August 5, 2020) @@ -3487,7 +3681,7 @@ default_fonts <- function() { #' #' @family helper functions #' @section Function ID: -#' 8-29 +#' 8-30 #' #' @section Function Introduced: #' `v0.9.0` (Mar 31, 2023) diff --git a/R/modify_columns.R b/R/modify_columns.R index 3e2b28c5e9..2af01e2e93 100644 --- a/R/modify_columns.R +++ b/R/modify_columns.R @@ -619,10 +619,10 @@ cols_width <- function( #' columns from the input table data). When you create a **gt** table object #' using [gt()], column names effectively become the column labels. While this #' serves as a good first approximation, column names as label defaults aren't -#' often appealing as the alternative for custom column labels in a **gt** -#' output table. The `cols_label()` function provides the flexibility to relabel -#' one or more columns and we even have the option to use the [md()] or [html()] -#' helper functions for rendering column labels from Markdown or using HTML. +#' often as appealing in a **gt** table as the option for custom column labels. +#' The `cols_label()` function provides the flexibility to relabel one or more +#' columns and we even have the option to use the [md()] or [html()] helper +#' functions for rendering column labels from Markdown or using HTML. #' #' @param .data *The gt table data object* #' @@ -644,7 +644,7 @@ cols_width <- function( #' can be used in the LHS. Named arguments are also valid as input for simple #' mappings of column name to label text; they should be of the form ` =