R/opts.R

In gt: Easily Create Presentation-Ready Display Tables

#------------------------------------------------------------------------------#
#
#                /$$
#               | $$
#     /$$$$$$  /$$$$$$
#    /$$__  $$|_  $$_/
#   | $$  \ $$  | $$
#   | $$  | $$  | $$ /$$
#   |  $$$$$$$  |  $$$$/
#    \____  $$   \___/
#    /$$  \ $$
#   |  $$$$$$/
#    \______/
#
#  This file is part of the 'rstudio/gt' project.
#
#  Copyright (c) 2018-2023 gt authors
#
#  For full copyright and license information, please look at
#  https://gt.rstudio.com/LICENSE.html
#
#------------------------------------------------------------------------------#


#' Stylize your table with a colorful look
#'
#' @description
#'
#' With `opt_stylize()` you can quickly style your **gt** table with a carefully
#' curated set of background colors, line colors, and line styles. There are six
#' styles to choose from and they largely vary in the extent of coloring applied
#' to different table locations. Some have table borders applied, some apply
#' darker colors to the table stub and summary sections, and, some even have
#' vertical lines. In addition to choosing a `style` preset, there are six
#' `color` variations that each use a range of five color tints. Each of the
#' color tints have been fine-tuned to maximize the contrast between text and
#' its background. There are 36 combinations of `style` and `color` to choose
#' from.
#'
#' @inheritParams fmt_number
#'
#' @param style *Table style*
#'
#'   `scalar<numeric|integer>(1>=val>=6)` // *default:* `1`
#'
#'   Six numbered styles are available. Simply provide a number from `1` (the
#'   default) to `6` to choose a distinct look.
#'
#' @param color *Color variation*
#'
#'   `scalar<character>` // *default:* `"blue"`
#'
#'   There are six color variations: `"blue"`, `"cyan"`, `"pink"`, `"green"`,
#'   `"red"`, and `"gray"`.
#'
#' @param add_row_striping *Allow row striping*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   An option to enable row striping in the table body for the `style` chosen.
#'
#' @return an object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use `exibble` to create a **gt** table with a number of table parts added.
#' Then, use the `opt_stylize()` function to give the table some additional
#' style (using the `"cyan"` color variation and style number `6`).
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_stylize(style = 6, color = "cyan")
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_stylize_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-1
#'
#' @section Function Introduced:
#' `v0.7.0` (Aug 25, 2022)
#'
#' @export
opt_stylize <- function(
    data,
    style = 1,
    color = "blue",
    add_row_striping = TRUE
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  if (!(length(style) == 1 && style %in% 1:6)) {
    cli::cli_abort("The `style` value must be a number in the range of 1 to 6.")
  }

  if (!(length(color) == 1 && color %in% unique(styles_colors_params$color))) {
    cli::cli_abort(c(
      "The `color` value must be one of seven specific colors:",
      "*" = "\"blue\", \"cyan\", \"pink\", \"green\", \"red\", or \"gray\""
    ))
  }

  # Get the set of parameters based on the `style` and `color` values
  params <-
    get_colorized_params(
      styles_colors_params = styles_colors_params,
      style = style,
      color = color
    )

  tbl_colorized <-
    tab_options(
      data,
      table.border.top.color = params$table_hlines_color,
      table.border.bottom.color = params$table_hlines_color,
      heading.border.bottom.color = params$location_hlines_color,
      column_labels.border.top.color = params$location_hlines_color,
      column_labels.border.bottom.color = params$location_hlines_color,
      row_group.border.top.color = params$location_hlines_color,
      row_group.border.bottom.color = params$location_hlines_color,
      summary_row.border.color = params$location_hlines_color,
      grand_summary_row.border.color = params$location_hlines_color,
      column_labels.background.color = params$column_labels_background_color,
      stub.background.color = params$stub_background_color,
      stub.border.style = params$stub_border_style,
      stub.border.color = params$stub_border_color,
      table_body.border.top.color = params$location_hlines_color,
      table_body.border.bottom.color = params$location_hlines_color,
      table_body.hlines.style = params$data_hlines_style,
      table_body.hlines.color = params$data_hlines_color,
      table_body.vlines.style = params$data_vlines_style,
      table_body.vlines.color = params$data_vlines_color,
      summary_row.background.color = params$summary_row_background_color,
      grand_summary_row.background.color = params$grand_summary_row_background_color,
      row.striping.background_color = params$row_striping_background_color
    )

  if (!is.na(params$table_outline_color)) {

    tbl_colorized <-
      opt_table_outline(
        tbl_colorized,
        width = px(3),
        color = params$table_outline_color
      )
  }

  if (add_row_striping) {
    tbl_colorized <- opt_row_striping(tbl_colorized)
  }

  tbl_colorized
}

get_colorized_params <- function(
    styles_colors_params,
    style,
    color
) {

  style_filter <- style
  color_filter <- color

  as.list(
    dplyr::filter(
      styles_colors_params,
      style == style_filter,
      color == color_filter
    )
  )
}

#' Option to put interactive elements in an HTML table
#'
#' @description
#'
#' By default, a **gt** table rendered as HTML will essentially be a 'static'
#' table. However, we can make it 'interactive' and configure those interactive
#' HTML options through the `opt_interactive()` function. Making an HTML table
#' interactive entails the enabling of controls for pagination, global search,
#' filtering, sorting, and more.
#'
#' This function serves as a shortcut for setting the following options in
#' [tab_options()]:
#'
#' - `ihtml.active`
#' - `ihtml.use_pagination`
#' - `ihtml.use_pagination_info`
#' - `ihtml.use_sorting`
#' - `ihtml.use_search`
#' - `ihtml.use_filters`
#' - `ihtml.use_resizers`
#' - `ihtml.use_highlight`
#' - `ihtml.use_compact_mode`
#' - `ihtml.use_page_size_select`
#' - `ihtml.page_size_default`
#' - `ihtml.page_size_values`
#' - `ihtml.pagination_type`
#'
#' @inheritParams fmt_number
#'
#' @param active *Display interactive HTML table*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   The `active` option will either enable or disable interactive features for
#'   an HTML table. The individual features of an interactive HTML table are
#'   controlled by the other options.
#'
#' @param use_pagination *Display pagination controls*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   This is the option for using pagination controls (below the table body). By
#'   default, this is `TRUE` and it will allow the use to page through table
#'   content.
#'
#' @param use_pagination_info *Display pagination info*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   If `use_pagination` is `TRUE` then the `use_pagination_info` option can be
#'   used to display informational text regarding the current page view (this is
#'   set to `TRUE` by default).
#'
#' @param use_sorting *Provide column sorting controls*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   This option provides controls for sorting column values. By default, this
#'   is `TRUE`.
#'
#' @param use_search *Provide a global search field*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   The `use_search` option places a search field for globally filtering rows
#'   to the requested content. By default, this is `FALSE`.
#'
#' @param use_filters *Display filtering fields*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   The `use_filters` option places search fields below each column header and
#'   allows for filtering by column. By default, this is `FALSE`.
#'
#' @param use_resizers *Allow column resizing*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   This option allows for the interactive resizing of columns. By default,
#'   this is `FALSE`.
#'
#' @param use_highlight *Enable row highlighting on hover*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   The `use_highlight` option highlights individual rows upon hover. By
#'   default, this is `FALSE`.
#'
#' @param use_compact_mode *Use compact mode*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   To reduce vertical padding and thus make the table consume less vertical
#'   space the `use_compact_mode` option can be used. By default, this is
#'   `FALSE`.
#'
#' @param use_text_wrapping *Use text wrapping*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   The `use_text_wrapping` option controls whether text wrapping occurs
#'   throughout the table. This is `TRUE` by default and with that text will be
#'   wrapped to multiple lines. If `FALSE`, text will be truncated to a single
#'   line.
#'
#' @param use_page_size_select *Allow for page size selection*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   The `use_page_size_select` option lets us display a dropdown menu for the
#'   number of rows to show per page of data.
#'
#' @param page_size_default *Change the default page size*
#'
#'   `scalar<numeric|integer>` // *default:* `10`
#'
#'   The default page size (initially set as `10`) can be modified with
#'   `page_size_default` and this works whether or not `use_page_size_select` is
#'   set to `TRUE`.
#'
#' @param page_size_values *Set of page-size values*
#'
#'   `vector<numeric|integer>` // *default:* `c(10, 25, 50, 100)`
#'
#'   By default, this is the vector `c(10, 25, 50, 100)` which corresponds to
#'   options for `10`, `25`, `50`, and `100` rows of data per page. To modify
#'   these page-size options, provide a numeric vector to `page_size_values`.
#'
#' @param pagination_type *Change pagination mode*
#'
#'   `scalar<character>` // *default:* `"numbers"`
#'
#'   When using pagination the `pagination_type` option lets us select between
#'   one of three options for the layout of pagination controls. The default is
#'   `"numbers"`, where a series of page-number buttons is presented along with
#'   'previous' and 'next' buttons. The `"jump"` option provides an input field
#'   with a stepper for the page number. With `"simple"`, only the 'previous'
#'   and 'next' buttons are displayed.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use select columns from the [`towny`] dataset to create a **gt** table with a
#' header (through [tab_header()]) and a source note (through
#' [tab_source_note()]). Next, we will add interactive HTML features (and
#' otherwise activate interactive HTML mode) through `opt_interactive()`. It'll
#' just be the default set of interactive options.
#'
#' ```r
#' towny |>
#'   dplyr::select(name, census_div, starts_with("population")) |>
#'   gt() |>
#'   fmt_integer() |>
#'   cols_label_with(fn = function(x) sub("population_", "", x)) |>
#'   cols_width(
#'     name ~ px(200),
#'     census_div ~ px(200)
#'   ) |>
#'   tab_header(
#'     title = "Populations of Municipalities",
#'     subtitle = "Census values from 1996 to 2021."
#'   ) |>
#'   tab_source_note(source_note = md("Data taken from the `towny` dataset.")) |>
#'   opt_interactive()
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_interactive_1.png")`
#' }}
#'
#' Interactive tables can have styled body cells. Here, we use the [`gtcars`]
#' dataset to create an interactive **gt** table. Using [tab_style()] and
#' [data_color()] we can flexibly style body cells throughout the table.
#'
#' ```r
#' gtcars |>
#'   gt() |>
#'   cols_width(everything() ~ px(130)) |>
#'   tab_style(
#'     style = cell_fill(color = "gray95"),
#'     locations = cells_body(columns = c(mfr, model))
#'   ) |>
#'   data_color(
#'     columns = c(starts_with("hp"), starts_with("trq")),
#'     method = "numeric",
#'     palette = "viridis"
#'   ) |>
#'   cols_hide(columns = trim) |>
#'   opt_interactive()
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_interactive_2.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-2
#'
#' @section Function Introduced:
#' `v0.9.0` (Mar 31, 2023)
#'
#' @export
opt_interactive <- function(
    data,
    active = TRUE,
    use_pagination = TRUE,
    use_pagination_info = TRUE,
    use_sorting = TRUE,
    use_search = FALSE,
    use_filters = FALSE,
    use_resizers = FALSE,
    use_highlight = FALSE,
    use_compact_mode = FALSE,
    use_text_wrapping = TRUE,
    use_page_size_select = FALSE,
    page_size_default = 10,
    page_size_values = c(10, 25, 50, 100),
    pagination_type = c("numbers", "jump", "simple")
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  pagination_type <- rlang::arg_match(pagination_type)

  tab_options(
    data = data,
    ihtml.active = active,
    ihtml.use_pagination = use_pagination,
    ihtml.use_pagination_info = use_pagination_info,
    ihtml.use_sorting = use_sorting,
    ihtml.use_search = use_search,
    ihtml.use_filters = use_filters,
    ihtml.use_resizers = use_resizers,
    ihtml.use_highlight = use_highlight,
    ihtml.use_compact_mode = use_compact_mode,
    ihtml.use_text_wrapping = use_text_wrapping,
    ihtml.use_page_size_select = use_page_size_select,
    ihtml.page_size_default = page_size_default,
    ihtml.page_size_values = page_size_values,
    ihtml.pagination_type = pagination_type
  )
}

#' Option to modify the set of footnote marks
#'
#' @description
#'
#' 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})`
#'
#' @inheritParams fmt_number
#'
#' @param marks *Sequence of footnote marks*
#'
#'   `vector<character>` // *default:* `"numbers"`
#'
#'   Either a character vector of length greater than 1 (that will represent the
#'   series of marks) or a single 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`.
#'
#' @section Specification of footnote marks:
#'
#' We can supply a vector 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:
#'
#' - `"numbers"`: numeric marks, they begin from 1 and these marks are not
#' subject to recycling behavior
#' - `"letters"`: minuscule alphabetic marks, internally uses the `letters`
#' vector which contains 26 lowercase letters of the Roman alphabet
#' - `"LETTERS"`: majuscule alphabetic marks, using the `LETTERS` vector
#' which has 26 uppercase letters of the Roman alphabet
#' - `"standard"`: symbolic marks, four symbols in total
#' - `"extended"`: symbolic marks, extends the standard set by adding two
#' more symbols, making six
#'
#' The symbolic marks are the: (1) Asterisk, (2) Dagger, (3) Double Dagger,
#' (4) Section Sign, (5) Double Vertical Line, and (6) Paragraph Sign; the
#' `"standard"` set has the first four, `"extended"` contains all.
#'
#' @section Examples:
#'
#' Use a summarized version of the [`sza`] dataset to create a **gt** table,
#' adding three footnotes (with three calls of [tab_footnote()]). We can modify
#' the footnote marks to use with the `opt_footnote_marks()` function. With the
#' keyword `"standard"` we get four commonly-used typographic marks.
#'
#' ```r
#' sza |>
#'   dplyr::filter(latitude == 30) |>
#'   dplyr::group_by(tst) |>
#'   dplyr::summarize(
#'     SZA.Max = if (
#'       all(is.na(sza))) {
#'       NA
#'     } else {
#'       max(sza, na.rm = TRUE)
#'     },
#'     SZA.Min = if (
#'       all(is.na(sza))) {
#'       NA
#'     } else {
#'       min(sza, na.rm = TRUE)
#'     },
#'     .groups = "drop"
#'   ) |>
#'   gt(rowname_col = "tst") |>
#'   tab_spanner_delim(delim = ".") |>
#'   sub_missing(
#'     columns = everything(),
#'     missing_text = "90+"
#'   ) |>
#'   tab_stubhead(label = "TST") |>
#'   tab_footnote(
#'     footnote = "True solar time.",
#'     locations = cells_stubhead()
#'   ) |>
#'   tab_footnote(
#'     footnote = "Solar zenith angle.",
#'     locations = cells_column_spanners(
#'       spanners = "spanner-SZA.Max"
#'     )
#'   ) |>
#'   tab_footnote(
#'     footnote = "The Lowest SZA.",
#'     locations = cells_stub(rows = "1200")
#'   ) |>
#'   opt_footnote_marks(marks = "standard")
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_footnote_marks_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-3
#'
#' @section Function Introduced:
#' `v0.2.0.5` (March 31, 2020)
#'
#' @export
opt_footnote_marks <- function(
    data,
    marks = "numbers"
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  # Validate input for `marks`
  validate_marks(marks)

  tab_options(data = data, footnotes.marks = marks)
}

#' Option to specify the formatting of footnote marks
#'
#' @description
#'
#' Modify the way footnote marks are formatted. This can be performed for those
#' footnote marks that alight to the targeted text in cells in various locations
#' in the table or the footnote marks that appear in the table footer. A simple
#' specification string can be provided for either or both types of marks in
#' `opt_footnote_spec()` . This function serves as a shortcut for using either
#' of `tab_options(footnotes.spec_ref = {spec})` or
#' `tab_options(footnotes.spec_ftr = {spec})`.
#'
#' @inheritParams fmt_number
#'
#' @param spec_ref,spec_ftr *Specifications for formatting of footnote marks*
#'
#'   `scalar<character>` // *default:* `NULL` (`optional`)
#'
#'   Specification of the footnote marks when behaving as footnote references
#'   and as marks in the footer section of the table. This is a string
#'   containing spec characters. The default is the spec string `"^i"`, which is
#'   superscript text set in italics.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Specification rules for the formatting of footnote marks:
#'
#' A footnote spec consists of a string containing control characters for
#' formatting. Not every type of formatting makes sense for footnote marks so
#' the specification is purposefully constrained to the following:
#'
#' - as superscript text (with the `"^"` control character) or regular-sized
#' text residing on the baseline
#' - bold text (with `"b"`), italicized text (with `"i"`), or unstyled text
#' (don't use either of the `"b"` or `"i"` control characters)
#' - enclosure in parentheses (use `"("` / `")"`) or square brackets (with
#' `"["` / `"]"`)
#' - a period following the mark (using `"."`); this is most commonly used in
#' the table footer
#'
#' With the aforementioned control characters we could, for instance, format
#' the footnote marks to be superscript text in bold type with `"^b"`. We might
#' want the marks in the footer to be regular-sized text in parentheses, so the
#' spec could be either `"()"` or `"(x)"` (you can optionally use `"x"` as a
#' helpful placeholder for the marks).
#'
#' @section Examples:
#'
#' Use a modified version of [`sp500`] the dataset to create a **gt** table with
#' row labels. We'll add two footnotes using the `tab_footnote()` function. We
#' can call `opt_footnote_spec()` to specify that the marks of the footnote
#' reference should be superscripts in bold, and, the marks in the footer
#' section should be enclosed in parentheses.
#'
#' ```r
#' sp500 |>
#'   dplyr::filter(date >= "1987-10-14" & date <= "1987-10-25") |>
#'   dplyr::select(date, open, close, volume) |>
#'   dplyr::mutate(difference = close - open) |>
#'   dplyr::mutate(change = (close - open) / open) |>
#'   dplyr::mutate(day = vec_fmt_datetime(date, format = "E")) |>
#'   dplyr::arrange(-dplyr::row_number()) |>
#'   gt(rowname_col = "date") |>
#'   fmt_currency() |>
#'   fmt_number(columns = volume, suffixing = TRUE) |>
#'   fmt_percent(columns = change) |>
#'   cols_move_to_start(columns = day) |>
#'   cols_width(
#'     stub() ~ px(130),
#'     day ~ px(50),
#'     everything() ~ px(100)
#'   ) |>
#'   tab_footnote(
#'     footnote = "Commerce report on trade deficit.",
#'     locations = cells_stub(rows = 1)
#'   ) |>
#'   tab_footnote(
#'     footnote = "Black Monday market crash, representing the greatest
#'     one-day percentage decline in U.S. stock market history.",
#'     locations = cells_body(columns = change, rows = change < -0.15)
#'   ) |>
#'   opt_footnote_spec(spec_ref = "^xb", spec_ftr = "(x)")
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_footnote_spec_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-4
#'
#' @section Function Introduced:
#' `v0.9.0` (Mar 31, 2023)
#'
#' @export
opt_footnote_spec <- function(
    data,
    spec_ref = NULL,
    spec_ftr = NULL
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  if (!is.null(spec_ref)) {
    data <- tab_options(data = data, footnotes.spec_ref = spec_ref)
  }

  if (!is.null(spec_ftr)) {
    data <- tab_options(data = data, footnotes.spec_ftr = spec_ftr)
  }

  data
}

#' Option to add or remove row striping
#'
#' @description
#'
#' By default, a **gt** table does not have row striping enabled. However, this
#' function allows us to easily enable or disable striped rows in the table
#' body. This function serves as a convenient shortcut for
#' `<gt_tbl> |> tab_options(row.striping.include_table_body = TRUE|FALSE)`.
#'
#' @inheritParams fmt_number
#'
#' @param row_striping *Use alternating row stripes*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   A logical value to indicate whether row striping should be added or
#'   removed.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, we'll add row striping to every second row with
#' the `opt_row_striping()` function.
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_row_striping()
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_row_striping_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-5
#'
#' @section Function Introduced:
#' `v0.2.0.5` (March 31, 2020)
#'
#' @export
opt_row_striping <- function(
    data,
    row_striping = TRUE
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  tab_options(
    data = data,
    row.striping.include_table_body = row_striping
  )
}

#' Option to align the table header
#'
#' @description
#'
#' By default, a table header added to a **gt** table has center alignment
#' for both the title and the subtitle elements. This function allows us to
#' easily set the horizontal alignment of the title and subtitle to the left
#' or right by using the `"align"` argument. This function serves as a
#' convenient shortcut for `<gt_tbl> |> tab_options(heading.align = <align>)`.
#'
#' @inheritParams fmt_number
#'
#' @param align *Header alignment*
#'
#'   `singl-kw:[left|center|right]` // *default:* `"left"`
#'
#'   The alignment of the title and subtitle elements in the table header.
#'   Options are `"left"` (the default), `"center"`, or `"right"`.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, we'll align the header contents (consisting of the
#' title and the subtitle) to the left with the `opt_align_table_header()`
#' function.
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_align_table_header(align = "left")
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_align_table_header_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-6
#'
#' @section Function Introduced:
#' `v0.2.0.5` (March 31, 2020)
#'
#' @export
opt_align_table_header <- function(
    data,
    align = c("left", "center", "right")
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  align <- rlang::arg_match(align)

  tab_options(
    data = data,
    heading.align = align
  )
}

#' Option to expand or contract vertical padding
#'
#' @description
#'
#' Increase or decrease the vertical padding throughout all locations of a
#' **gt** table by use of a `scale` factor, which here is defined by a real
#' number between `0` and `3`. This function serves as a shortcut for setting
#' the following eight options in [tab_options()]:
#'
#' - `heading.padding`
#' - `column_labels.padding`
#' - `data_row.padding`
#' - `row_group.padding`
#' - `summary_row.padding`
#' - `grand_summary_row.padding`
#' - `footnotes.padding`
#' - `source_notes.padding`
#'
#' @inheritParams fmt_number
#'
#' @param scale *Scale factor*
#'
#'   `scalar<numeric|integer>(0>=val>=3)` // *default:* `1`
#'
#'   A scale factor by which the vertical padding will be adjusted. Must be a
#'   number between `0` and `3`.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, we'll lessen the amount of vertical padding across
#' the entire table with `opt_vertical_padding()`. Using a `scale` value of
#' `0.25` (down from the default of `1`) means the the vertical space will be
#' greatly reduced, resulting in a more compact table.
#'
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_vertical_padding(scale = 0.25)
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_vertical_padding_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-7
#'
#' @section Function Introduced:
#' `v0.4.0` (February 15, 2022)
#'
#' @export
opt_vertical_padding <- function(
    data,
    scale = 1
) {

  option_value_list <-
    get_padding_option_value_list(
      scale = scale,
      type = "vertical"
    )

  tab_options_multi(
    data = data,
    options = option_value_list
  )
}

#' Option to expand or contract horizontal padding
#'
#' @description
#'
#' Increase or decrease the horizontal padding throughout all locations of a
#' **gt** table by use of a `scale` factor, which here is defined by a real
#' number between `0` and `3`. This function serves as a shortcut for setting
#' the following eight options in [tab_options()]:
#'
#' - `heading.padding.horizontal`
#' - `column_labels.padding.horizontal`
#' - `data_row.padding.horizontal`
#' - `row_group.padding.horizontal`
#' - `summary_row.padding.horizontal`
#' - `grand_summary_row.padding.horizontal`
#' - `footnotes.padding.horizontal`
#' - `source_notes.padding.horizontal`
#'
#' @inheritParams fmt_number
#'
#' @param scale *Scale factor*
#'
#'   `scalar<numeric|integer>(0>=val>=3)` // *default:* `1`
#'
#'   A scale factor by which the horizontal padding will be adjusted. Must be a
#'   number between `0` and `3`.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, we'll increase the amount of horizontal padding
#' across the entire table with `opt_horizontal_padding()`. Using a `scale`
#' value of `3` (up from the default of `1`) means the the horizontal space will
#' be greatly increased, resulting in a more spacious table.
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_horizontal_padding(scale = 3)
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_horizontal_padding_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-8
#'
#' @section Function Introduced:
#' `v0.4.0` (February 15, 2022)
#'
#' @export
opt_horizontal_padding <- function(
    data,
    scale = 1
) {

  option_value_list <-
    get_padding_option_value_list(
      scale = scale,
      type = "horizontal"
    )

  tab_options_multi(
    data = data,
    options = option_value_list
  )
}

get_padding_option_value_list <- function(scale, type) {

  # Stop if `scale` is beyond an acceptable range
  if (scale < 0 | scale > 3) {
    cli::cli_abort(
      "The value provided for `scale` ({scale}) must be between `0` and `3`."
    )
  }

  pattern <- if (type == "vertical") "_padding" else  "_padding_horizontal"

  # Get the padding parameters from `dt_options_tbl` that relate
  # to the `type` (either vertical or horizontal padding)
  padding_params <-
    dplyr::pull(
      dplyr::filter(dt_options_tbl, grepl(paste0(pattern, "$"), parameter)),
      parameter
    )

  padding_options <- dplyr::filter(dt_options_tbl, parameter %in% padding_params)
  padding_options <- dplyr::select(padding_options, parameter, value)
  padding_options <-
    dplyr::mutate(
      padding_options,
      parameter = gsub(pattern, gsub("_", ".", pattern, fixed = TRUE), parameter, fixed = TRUE)
    )
  padding_options <- dplyr::mutate(padding_options, value = unlist(value))
  padding_options <- dplyr::mutate(padding_options, px = as.numeric(gsub("px", "", value)))
  padding_options <- dplyr::mutate(padding_options, px = px * scale)

  create_option_value_list(
    padding_options$parameter,
    paste0(padding_options$px, "px")
  )
}

#' Option to use all caps in select table locations
#'
#' @description
#'
#' Sometimes an all-capitalized look is suitable for a table. With the
#' `opt_all_caps()` function, we can transform characters in the column labels,
#' the stub, and in all row groups in this way (and there's control over which
#' of these locations are transformed).
#'
#' This function serves as a convenient shortcut for `<gt_tbl> |>
#' tab_options(<location>.text_transform = "uppercase", <location>.font.size =
#' pct(80), <location>.font.weight = "bolder")` (for all `locations` selected).
#'
#' @inheritParams fmt_number
#'
#' @param all_caps *Use all-caps transformation*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   A logical value to indicate whether the text transformation to all caps
#'   should be performed (`TRUE`, the default) or reset to default values
#'   (`FALSE`) for the `locations` targeted.
#'
#' @param locations *Locations to target*
#'
#'   `mult-kw:[column_labels|stub|row_group]` // *default:* `c("column_labels", "stub", "row_group")`
#'
#'   Which locations should undergo this text transformation? By default it
#'   includes all of the `"column_labels"`, the `"stub"`, and the `"row_group"`
#'   locations. However, we could just choose one or two of those.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, we'll ensure that all text in the column labels,
#' the stub, and in all row groups is transformed to all caps using
#' `opt_all_caps()`.
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_all_caps()
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_all_caps_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-9
#'
#' @section Function Introduced:
#' `v0.2.0.5` (March 31, 2020)
#'
#' @export
opt_all_caps <- function(
    data,
    all_caps = TRUE,
    locations = c("column_labels", "stub", "row_group")
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  # Ensure that all named locations are valid
  if (!all(locations %in% c("column_labels", "stub", "row_group"))) {
    cli::cli_abort(
      "The available locations are `column_labels`, `stub`, and `row_group`."
    )
  }

  # Create a regex pattern to obtain arg names for all specific `locations`
  pattern <-
    paste0(
      "^(", paste(locations, collapse = "|"),
      ")\\.(text_transform|font\\.size|font\\.weight)"
    )

  # Obtain the `tab_options()` args vector with the `pattern`
  options_vec <- get_tab_options_arg_vec(pattern = pattern)

  if (all_caps) {

    values_vec <-
      dplyr::case_when(
        grepl("\\.font\\.size$", options_vec) ~ "80%",
        grepl("\\.font\\.weight$", options_vec) ~ "bolder",
        grepl("\\.text_transform$", options_vec) ~ "uppercase"
      )

    option_value_list <- create_option_value_list(options_vec, values_vec)
  } else {
    option_value_list <- create_default_option_value_list(options_vec)
  }

  tab_options_multi(
    data = data,
    options = option_value_list
  )
}

#' Option to set table lines to different extents
#'
#' @description
#'
#' The `opt_table_lines()` function sets table lines in one of three possible
#' ways: (1) all possible table lines drawn (`"all"`), (2) no table lines at all
#' (`"none"`), and (3) resetting to the default line styles (`"default"`). This
#' is great if you want to start off with lots of lines and subtract just a few
#' of them with [tab_options()] or [tab_style()]. Or, use it to start with a
#' completely lineless table, adding individual lines as needed.
#'
#' @inheritParams fmt_number
#'
#' @param extent *Extent of lines added*
#'
#'   `singl-kw:[all|none|default]` // *default:* `"all"`
#'
#'   The extent to which lines will be visible in the table. Options are
#'   `"all"`, `"none"`, or `"default"`.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, we'll use the `opt_table_lines()` function to
#' generate lines everywhere there can possibly be lines (the default for the
#' `extent` argument is `"all"`).
#'
#' ```r
#' exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_table_lines()
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_table_lines_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-10
#'
#' @section Function Introduced:
#' `v0.2.0.5` (March 31, 2020)
#'
#' @export
opt_table_lines <- function(
    data,
    extent = c("all", "none", "default")
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  extent <- rlang::arg_match(extent)

  # Normalize `extent` values to property values
  values_vec <- if (extent == "all") "solid" else extent

  # Get vector of `tab_options()` arg names for all table line styles
  options_vec <- get_tab_options_arg_vec(pattern = "\\.style$")

  if (values_vec %in% c("solid", "none")) {
    option_value_list <- create_option_value_list(options_vec, values_vec)
  } else {
    option_value_list <- create_default_option_value_list(options_vec)
  }

  tab_options_multi(
    data = data,
    options = option_value_list
  )
}

#' Option to wrap an outline around the entire table
#'
#' @description
#'
#' This function puts an outline of consistent `style`, `width`, and `color`
#' around the entire table. It'll write over any existing outside lines so long
#' as the `width` is larger that of the existing lines. The default value of
#' `style` (`"solid"`) will draw a solid outline, whereas a value of `"none"`
#' will remove any present outline.
#'
#' @inheritParams fmt_number
#'
#' @param style *Outline style property*
#'
#'   `scalar<character>` // *default:* `"solid"`
#'
#'   The style property for the table outline. By default, this is `"solid"`. If
#'   `"none"` is used then the outline is removed and any values provided for
#'   `width` and `color` will be ignored (i.e., not set).
#'
#' @param width *Outline width value*
#'
#'   `scalar<character>` // *default:* `px(3)`
#'
#'   The width property for the table outline. By default, this is `px(3)` (or,
#'   `"3px"`).
#'
#' @param color *Color of outline*
#'
#'   `scalar<character>` // *default:* `"#D3D3D3"`
#'
#'   The color of the table outline. By default, this is `"#D3D3D3"`.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Use the [`exibble`] dataset to create a **gt** table with a number of table
#' parts added (using functions like [summary_rows()], [grand_summary_rows()],
#' and more). Following that, let's make it so that we have an outline wrap
#' around the entire table by using the `opt_table_outline()` function.
#'
#' ```r
#' tab_1 <-
#'   exibble |>
#'   gt(rowname_col = "row", groupname_col = "group") |>
#'   summary_rows(
#'     groups = "grp_a",
#'     columns = c(num, currency),
#'     fns = c("min", "max")
#'   ) |>
#'   grand_summary_rows(
#'     columns = currency,
#'     fns = total ~ sum(., na.rm = TRUE)
#'   ) |>
#'   tab_source_note(source_note = "This is a source note.") |>
#'   tab_footnote(
#'     footnote = "This is a footnote.",
#'     locations = cells_body(columns = 1, rows = 1)
#'   ) |>
#'   tab_header(
#'     title = "The title of the table",
#'     subtitle = "The table's subtitle"
#'   ) |>
#'   opt_table_outline()
#'
#' tab_1
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_table_outline_1.png")`
#' }}
#'
#' Remove the table outline with the `style = "none"` option.
#'
#' ```r
#' tab_1 |> opt_table_outline(style = "none")
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_table_outline_2.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-11
#'
#' @section Function Introduced:
#' `v0.2.0.5` (March 31, 2020)
#'
#' @export
opt_table_outline <- function(
    data,
    style = "solid",
    width = px(3),
    color = "#D3D3D3"
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  if (style == "none") {
    width <- NULL
    color <- NULL
  }

  params <-
    c(
      if (!is.null(style)) "style",
      if (!is.null(width)) "width",
      if (!is.null(color)) "color"
    )

  pattern <- paste0("^table\\.border.*?\\.(", paste(params, collapse = "|"), ")")

  # Get vector of `tab_options()` arg names for the table border styles
  options_vec <- get_tab_options_arg_vec(pattern = pattern)

  if (is.null(width)) width <- NA_character_
  if (is.null(color)) color <- NA_character_

  values_vec <-
    dplyr::case_when(
      grepl("^table\\.border\\..*?\\.style$", options_vec) ~ style,
      grepl("^table\\.border\\..*?\\.width$", options_vec) ~ width,
      grepl("^table\\.border\\..*?\\.color$", options_vec) ~ color
    )

  option_value_list <- create_option_value_list(options_vec, values_vec)

  tab_options_multi(
    data = data,
    options = option_value_list
  )
}

#' Options to define font choices for the entire table
#'
#' @description
#'
#' The `opt_table_font()` function makes it possible to define fonts used for an
#' entire **gt** table. Any font names supplied in `font` will (by default, with
#' `add = TRUE`) be placed before the names present in the existing font stack
#' (i.e., they will take precedence). You can choose to base the font stack on
#' those provided by [system_fonts()] by providing a valid keyword for a themed
#' set and optionally prepending `font` values to that.
#'
#' Take note that you could still have entirely different fonts in specific
#' locations of the table. For that you would need to use [tab_style()] or
#' [tab_style_body()] in conjunction with the [cell_text()] helper function.
#'
#' @inheritParams fmt_number
#'
#' @param font *Default table fonts*
#'
#'   `vector<character>|list|obj:<font_css>` // *default:* `NULL` (`optional`)
#'
#'   One or more font names available as system or web fonts. These can be
#'   combined with a `c()` or a `list()`. To choose fonts from the
#'   *Google Fonts* service, we can call the [google_font()] helper function.
#'
#' @param stack *Name of font stack*
#'
#'   `scalar<character>` // *default:* `NULL` (`optional`)
#'
#'   A name that is representative of a font stack (obtained via internally via
#'   the [system_fonts()] helper function). If provided, this new stack will
#'   replace any defined fonts and any `font` values will be prepended.
#'
#' @param style *Text style*
#'
#'   `scalar<character>` // *default:* `NULL` (`optional`)
#'
#'   An option to modify the text style. Can be one of either `"normal"`,
#'   `"italic"`, or `"oblique"`.
#'
#' @param weight *Text weight*
#'
#'   `scalar<character|numeric|integer>` // *default:* `NULL` (`optional`)
#'
#'   Option to set the weight of the font. Can be a text-based keyword such as
#'   `"normal"`, `"bold"`, `"lighter"`, `"bolder"`, or, a numeric value between
#'   `1` and `1000`, inclusive. Please note that typefaces have varying support
#'   for the numeric mapping of weight.
#'
#' @param add *Add to existing fonts*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   Should fonts be added to the beginning of any already-defined fonts for the
#'   table? By default, this is `TRUE` and is recommended since those fonts
#'   already present can serve as fallbacks when everything specified in `font`
#'   is not available. If a `stack` is provided, then `add` will automatically
#'   set to `FALSE`.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Possibilities for the `font` argument:
#'
#' We have the option to supply one or more font names for the `font` argument.
#' They can be enclosed in `c()` or a `list()`. You can generate this list or
#' vector with a combination of font names, and you can freely use the
#' [google_font()], [default_fonts()], and [system_fonts()] functions to help
#' compose your font family.
#'
#' @section Possibilities for the `stack` argument:
#'
#' There are several themed font stacks available via the [system_fonts()]
#' helper function. That function can be used to generate all or a segment of a
#' vector supplied to the `font` argument. However, using the `stack` argument
#' with one of the 15 keywords for the font stacks available in
#' [system_fonts()], we could be sure that the typeface class will work across
#' multiple computer systems. Any of the following keywords can be used:
#'
#' - `"system-ui"`
#' - `"transitional"`
#' - `"old-style"`
#' - `"humanist"`
#' - `"geometric-humanist"`
#' - `"classical-humanist"`
#' - `"neo-grotesque"`
#' - `"monospace-slab-serif"`
#' - `"monospace-code"`
#' - `"industrial"`
#' - `"rounded-sans"`
#' - `"slab-serif"`
#' - `"antique"`
#' - `"didone"`
#' - `"handwritten"`
#'
#' @section Examples:
#'
#' Use a subset of the [`sp500`] dataset to create a small **gt** table. We'll
#' use the [fmt_currency()] function to display a dollar sign for the first row
#' of monetary values. Then, set a larger font size for the table and use the
#' `"Merriweather"` font (from *Google Fonts*, via [google_font()]) with two
#' system font fallbacks (`"Cochin"` and the generic `"serif"`).
#'
#' ```r
#' sp500 |>
#'   dplyr::slice(1:10) |>
#'   dplyr::select(-volume, -adj_close) |>
#'   gt() |>
#'   fmt_currency(
#'     rows = 1,
#'     use_seps = FALSE
#'   ) |>
#'   opt_table_font(
#'     font = list(
#'       google_font(name = "Merriweather"),
#'       "Cochin", "serif"
#'     )
#'   )
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_table_font_1.png")`
#' }}
#'
#' Use the [`sza`] dataset to create an eleven-row table, two-column table.
#' Within `opt_table_font()`, use the `stack` argument to define the use of the
#' `"rounded-sans"` font stack. This sets up a family of fonts with rounded,
#' curved letterforms that should be locally available in different computing
#' environments.
#'
#' ```r
#' sza |>
#'   dplyr::filter(
#'     latitude == 20 &
#'       month == "jan" &
#'       !is.na(sza)
#'   ) |>
#'   dplyr::select(-latitude, -month) |>
#'   gt() |>
#'   opt_table_font(stack = "rounded-sans") |>
#'   opt_all_caps()
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_table_font_2.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-12
#'
#' @section Function Introduced:
#' `v0.2.2` (August 5, 2020)
#'
#' @export
opt_table_font <- function(
    data,
    font = NULL,
    stack = NULL,
    weight = NULL,
    style = NULL,
    add = TRUE
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  existing_fonts <-
    dt_options_get_value(
      data = data,
      option = "table_font_names"
    )

  existing_additional_css <-
    dt_options_get_value(
      data = data,
      option = "table_additional_css"
    )

  if (!is.null(font)) {

    font <- normalize_font_input(font_input = font)
    additional_css <- c(font$import_stmt, existing_additional_css)

    data <-
      tab_options(
        data = data,
        table.additional_css = additional_css
      )
  }

  if (!is.null(stack)) {

    font_stack <- system_fonts(name = stack)

    data <-
      tab_options(
        data = data,
        table.font.names = c(font$name, font_stack)
      )

  } else {

    data <-
      tab_options(
        data = data,
        table.font.names = c(font$name, if (add) existing_fonts)
      )
  }

  if (!is.null(weight)) {

    if (is.numeric(weight)) weight <- as.character(weight)

    data <-
      tab_options(
        data = data,
        table.font.weight = weight
      )

    data <-
      tab_options(
        data = data,
        column_labels.font.weight = weight
      )
  }

  if (!is.null(style)) {

    data <-
      tab_options(
        data = data,
        table.font.style = style
      )
  }

  data
}

#' Option to add custom CSS for the table
#'
#' @description
#'
#' The `opt_css()` function makes it possible to add CSS to a **gt** table. This
#' CSS will be added after the compiled CSS that **gt** generates automatically
#' when the object is transformed to an HTML output table. You can supply `css`
#' as a vector of lines or as a single string.
#'
#' @inheritParams fmt_number
#'
#' @param css *CSS declarations*
#'
#'   `scalar<character>` // **required**
#'
#'   The CSS to include as part of the rendered table's `<style>` element.
#'
#' @param add *Add to existing CSS*
#'
#'   `scalar<logical>` // *default:* `TRUE`
#'
#'   If `TRUE`, the default, the CSS is added to any already-defined CSS
#'   (typically from previous calls of [opt_table_font()], `opt_css()`, or,
#'   directly setting CSS the `table.additional_css` value in [tab_options()]).
#'   If this is set to `FALSE`, the CSS provided here will replace any
#'   previously-stored CSS.
#'
#' @param allow_duplicates *Allow for CSS duplication*
#'
#'   `scalar<logical>` // *default:* `FALSE`
#'
#'   When this is `FALSE` (the default), the CSS provided here won't be added
#'   (provided that `add = TRUE`) if it is seen in the already-defined CSS.
#'
#' @return An object of class `gt_tbl`.
#'
#' @section Examples:
#'
#' Let's use the [`exibble`] dataset to create a simple, two-column **gt** table
#' (keeping only the `num` and `currency` columns). Through use of the
#' `opt_css()` function, we can insert CSS rulesets as as string. We need to
#' ensure that the the table ID is set explicitly (we've done so here with the
#' ID value of `"one"`, setting it in the [gt()] function).
#'
#' ```r
#' exibble |>
#'   dplyr::select(num, currency) |>
#'   gt(id = "one") |>
#'   fmt_currency(
#'     columns = currency,
#'     currency = "HKD"
#'   ) |>
#'   fmt_scientific(columns = num) |>
#'   opt_css(
#'     css = "
#'     #one .gt_table {
#'       background-color: skyblue;
#'     }
#'     #one .gt_row {
#'       padding: 20px 30px;
#'     }
#'     #one .gt_col_heading {
#'       text-align: center !important;
#'     }
#'     "
#'   )
#' ```
#'
#' \if{html}{\out{
#' `r man_get_image_tag(file = "man_opt_css_1.png")`
#' }}
#'
#' @family table option functions
#' @section Function ID:
#' 10-13
#'
#' @section Function Introduced:
#' `v0.2.2` (August 5, 2020)
#'
#' @export
opt_css <- function(
    data,
    css,
    add = TRUE,
    allow_duplicates = FALSE
) {

  # Perform input object validation
  stop_if_not_gt_tbl(data = data)

  existing_additional_css <-
    dt_options_get_value(
      data = data,
      option = "table_additional_css"
    )

  css <- paste(css, collapse = "\n")

  if (!add && !allow_duplicates && css %in% existing_additional_css) {
    return(data)
  }

  additional_css <- c(existing_additional_css, css)

  tab_options(
    data = data,
    table.additional_css = additional_css
  )
}

normalize_font_input <- function(font_input) {

  if (
    !inherits(font_input, "character") &&
    !inherits(font_input, "list") &&
    !inherits(font_input, "font_css")
  ) {
    cli::cli_abort(
      "Values provided to `font` must either be a list or a character vector."
    )
  }

  if (inherits(font_input, "character")) {
    font_input <- list(font_input)
  }

  # Unlist a list of lists; this normalizes the value for `font_input`
  # in the cases where multiple fonts were provided in `c()` and `list()`
  if (any(vapply(font_input, is.list, FUN.VALUE = logical(1)))) {
    font_input <- unlist(font_input, recursive = FALSE)
  }

  if (is.null(names(font_input))) {
    font_names <- unlist(font_input)
    import_stmts <- ""
  } else {
    font_names <- unique(unname(unlist(font_input[names(font_input) %in% c("name", "")])))
    import_stmts <- unique(unname(unlist(font_input[names(font_input) %in% "import_stmt"])))
  }

  font_list <-
    list(
      name = font_names,
      import_stmt = import_stmts
    )

  class(font_list) <- "font_css"
  font_list
}

# Create an option-value list with a vector of arg names from the
# `tab_options()` function and either one value or n-length values
# corresponding to those options
create_option_value_list <- function(tab_options_args, values) {

  # Validate the length of the `values` vector
  if (length(values) == 1) {

    values <- rep_len(values, length(tab_options_args))

  } else if (length(values) != length(tab_options_args)) {

    cli::cli_abort(
      "The length of the `values` vector must be `1` or the length of
      `tab_options_args`."
    )
  }

  as.list(stats::setNames(object = values, tab_options_args))
}

create_default_option_value_list <- function(tab_options_args) {

  lapply(
    stats::setNames(, tab_options_args),
    FUN = function(x) {
      dt_options_get_default_value(tidy_gsub(x, ".", "_", fixed = TRUE))
    }
  )
}

dt_options_get_default_value <- function(option) {

  # Validate the provided `option` value
  if (length(option) != 1) {
    cli::cli_abort("A character vector of length one must be provided.")
  }
  if (!(option %in% dt_options_tbl$parameter)) {
    cli::cli_abort("The `option` provided is invalid.")
  }

  dt_options_tbl$value[[which(dt_options_tbl$parameter == option)]]
}

# Get vector of argument names (excluding `data`) from `tab_options`
#' @include tab_create_modify.R
tab_options_arg_names <- base::setdiff(names(formals(tab_options)), "data")

# Create vector of all args from `tab_options()` by
# use of a regex pattern
get_tab_options_arg_vec <- function(pattern) {
  grep(pattern = pattern, tab_options_arg_names, value = TRUE)
}

# Validate any vector of `tab_options()` argument names
validate_tab_options_args <- function(tab_options_args) {

  if (!all(tab_options_args %in% tab_options_arg_names)) {
    cli::cli_abort("All `tab_options_args` must be valid names.")
  }
}

# Do multiple calls of `tab_options()` with an option-value list (`options`)
tab_options_multi <- function(data, options) {

  # Validate the names of the `options`
  validate_tab_options_args(names(options))

  do.call(tab_options, c(list(data = data), options))
}