Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
490 lines (454 sloc) 16 KB
#' View a table with info on date styles
#'
#' The `fmt_date()` function lets us format date-based values in a convenient
#' manner using preset styles. The table generated by the `info_date_style()`
#' function provides a quick reference to all 14 styles, with associated number
#' codes, the format names, and example outputs using a fixed date
#' (`2000-02-29`).
#'
#' @examples
#' # Get a table of info on the different
#' # date-formatting styles (which are used
#' # by supplying a number code to the
#' # `fmt_date()` function)
#' tab_1 <- info_date_style()
#'
#' @section Figures:
#' \if{html}{\figure{man_info_date_style_1.svg}{options: width=100\%}}
#'
#' @family information functions
#' @export
info_date_style <- function() {
dplyr::tibble(
Number = 1:14,
Name = c(
"iso", "wday_month_day_year", "wd_m_day_year", "wday_day_month_year",
"month_day_year", "m_day_year", "day_m_year", "day_month_year",
"day_month", "year", "month", "day", "year.mn.day", "y.mn.day"),
date = "2000-02-29") %>%
gt() %>%
fmt_date(columns = vars(date), rows = 1, date_style = 1) %>%
fmt_date(columns = vars(date), rows = 2, date_style = 2) %>%
fmt_date(columns = vars(date), rows = 3, date_style = 3) %>%
fmt_date(columns = vars(date), rows = 4, date_style = 4) %>%
fmt_date(columns = vars(date), rows = 5, date_style = 5) %>%
fmt_date(columns = vars(date), rows = 6, date_style = 6) %>%
fmt_date(columns = vars(date), rows = 7, date_style = 7) %>%
fmt_date(columns = vars(date), rows = 8, date_style = 8) %>%
fmt_date(columns = vars(date), rows = 9, date_style = 9) %>%
fmt_date(columns = vars(date), rows = 10, date_style = 10) %>%
fmt_date(columns = vars(date), rows = 11, date_style = 11) %>%
fmt_date(columns = vars(date), rows = 12, date_style = 12) %>%
fmt_date(columns = vars(date), rows = 13, date_style = 13) %>%
fmt_date(columns = vars(date), rows = 14, date_style = 14) %>%
tab_spanner(label = "Date Formats", columns = c("Number", "Name")) %>%
cols_label(date = "Formatted Date") %>%
tab_header(
title = "Preset Date Formats",
subtitle = md("Usable in the `fmt_date()` and `fmt_datetime()` functions")
) %>%
tab_style(
style = cell_text(align = "left"),
locations = list(
cells_title(groups = "title"),
cells_title(groups = "subtitle")
)
)
}
#' View a table with info on time styles
#'
#' The `fmt_time()` function lets us format time-based values in a convenient
#' manner using preset styles. The table generated by the `info_time_style()`
#' function provides a quick reference to all five styles, with associated
#' number codes, the format names, and example outputs using a fixed time
#' (`14:35`).
#'
#' @examples
#' # Get a table of info on the different
#' # time-formatting styles (which are used
#' # by supplying a number code to the
#' # `fmt_time()` function)
#' tab_1 <- info_time_style()
#'
#' @section Figures:
#' \if{html}{\figure{man_info_time_style_1.svg}{options: width=100\%}}
#'
#' @family information functions
#' @export
info_time_style <- function() {
dplyr::tibble(
Number = 1:5,
Name = c("hms", "hm", "hms_p", "hm_p", "h_p"),
time = "14:35") %>%
gt() %>%
fmt_time(columns = vars(time), rows = 1, time_style = 1) %>%
fmt_time(columns = vars(time), rows = 2, time_style = 2) %>%
fmt_time(columns = vars(time), rows = 3, time_style = 3) %>%
fmt_time(columns = vars(time), rows = 4, time_style = 4) %>%
fmt_time(columns = vars(time), rows = 5, time_style = 5) %>%
tab_spanner(label = "Time Formats", columns = c("Number", "Name")) %>%
cols_label(time = "Formatted Time") %>%
tab_header(
title = "Preset Time Formats",
subtitle = md("Usable in the `fmt_time()` and `fmt_datetime()` functions")
) %>%
tab_style(
style = cell_text(align = "left"),
locations = list(
cells_title(groups = "title"),
cells_title(groups = "subtitle")
)
)
}
#' View a table with info on supported currencies
#'
#' The `fmt_currency()` function lets us format numeric values as currencies.
#' The table generated by the `info_currencies()` function provides a quick
#' reference to all the available currencies. The currency identifiers are
#' provided (name, 3-letter currency code, and 3-digit currency code) along with
#' the each currency's exponent value (number of digits of the currency
#' subunits). A formatted example is provided (based on the value of `49.95`) to
#' demonstrate the default formatting of each currency.
#'
#' There are 172 currencies, which can lead to a verbose display table. To make
#' this presentation more focused on retrieval, we can provide an initial letter
#' corresponding to the 3-letter currency code to `begins_with`. This will
#' filter currencies in the info table to just the set beginning with the
#' supplied letter.
#'
#' @param type The type of currency information provided. Can either be `code`
#' where currency information corresponding to 3-letter currency codes is
#' provided, or `symbol` where currency info for common currency names (e.g.,
#' dollar, pound, yen, etc.) is returned.
#' @param begins_with Providing a single letter will filter currencies to only
#' those that begin with that letter in their currency code. The default
#' (`NULL`) will produce a table with all currencies displayed. This option
#' only constrains the information table where `type == "code"`.
#'
#' @examples
#' # Get a table of info on all of
#' # the currencies where the three-
#' # letter code begins with a "h"
#' tab_1 <- info_currencies(begins_with = "h")
#'
#' # Get a table of info on all of the
#' # common currency name/symbols that
#' # can be used with `fmt_currency()`
#' tab_2 <- info_currencies(type = "symbol")
#'
#' @section Figures:
#' \if{html}{\figure{man_info_currencies_1.svg}{options: width=100\%}}
#'
#' \if{html}{\figure{man_info_currencies_2.svg}{options: width=100\%}}
#'
#' @family information functions
#' @export
info_currencies <- function(type = c("code", "symbol"),
begins_with = NULL) {
if (type[1] == "code") {
if (!is.null(begins_with)) {
starting <-
substr(begins_with, 1, 1) %>%
toupper()
curr <-
currencies %>%
dplyr::filter(grepl(paste0("^", starting, ".*"), curr_code))
} else {
curr <- currencies
}
tab_1 <-
curr %>%
dplyr::select(-symbol) %>%
dplyr::select(curr_name, dplyr::everything()) %>%
dplyr::mutate(value = 49.95) %>%
gt()
for (i in seq(nrow(curr))) {
tab_1 <-
tab_1 %>%
fmt_currency(
columns = vars(value),
rows = i,
currency = curr[[i, "curr_code"]]
)
}
tab_1 <-
tab_1 %>%
tab_spanner(
label = "Identifiers",
columns = c("curr_name", "curr_code", "curr_number")
) %>%
cols_label(
curr_name = html("Currency\nName"),
curr_code = html("Currency\nCode"),
curr_number = html("Currency\nNumber"),
exponent = "Exp",
value = html("Formatted\nCurrency"),
) %>%
tab_header(
title = md("Currencies Supported in **gt**"),
subtitle = md("Currency codes are used in the `fmt_currency()` function")
) %>%
tab_style(
style = cell_text(align = "left"),
locations = list(
cells_title(groups = "title"),
cells_title(groups = "subtitle")
)
)
return(tab_1)
}
if (type[1] == "symbol") {
curr <- currency_symbols
tab_1 <-
currency_symbols %>%
dplyr::select(-symbol) %>%
dplyr::mutate(value = 49.95) %>%
gt()
for (i in seq(nrow(curr))) {
tab_1 <-
tab_1 %>%
fmt_currency(
columns = vars(value),
rows = i,
currency = curr[[i, "curr_symbol"]]
)
}
tab_1 <-
tab_1 %>%
cols_label(
curr_symbol = html("Currency\nSymbol"),
value = html("Formatted\nCurrency"),
) %>%
tab_header(
title = md("Currencies Supported in **gt**"),
subtitle = md("Currency symbols are used in the `fmt_currency()` function")
) %>%
tab_style(
style = cell_text(align = "left"),
locations = list(
cells_title(groups = "title"),
cells_title(groups = "subtitle")
)
)
return(tab_1)
}
}
#' View a table with info on supported locales
#'
#' Many of the `fmt_*()` functions have a `locale` argument that makes
#' locale-based formatting easier. The table generated by the `info_locales()`
#' function provides a quick reference to all the available locales. The locale
#' identifiers are provided (base locale ID, common display name) along with the
#' each locale's group and decimal separator marks. A formatted numeric example
#' is provided (based on the value of `11027`) to demonstrate the default
#' formatting of each locale.
#'
#' There are 712 locales, which means that a very long display table is provided
#' by default. To trim down the output table size, we can provide an initial
#' letter corresponding to the base locale ID to `begins_with`. This will filter
#' locales in the info table to just the set beginning with the supplied letter.
#'
#' @param begins_with Providing a single letter will filter locales to only
#' those that begin with that letter in their base locale ID. The default
#' (`NULL`) will produce a table with all locales displayed.
#' @examples
#' # Get a table of info on all of
#' # the locales where the base
#' # locale ID begins with a "v"
#' tab_1 <- info_locales(begins_with = "v")
#'
#' @family information functions
#' @export
info_locales <- function(begins_with = NULL) {
if (!is.null(begins_with)) {
starting <-
substr(begins_with, 1, 1) %>%
tolower()
loc <-
locales %>%
dplyr::filter(grepl(paste0("^", starting, ".*"), base_locale_id))
} else {
loc <- locales
}
tab_1 <-
loc %>%
dplyr::select(
base_locale_id, display_name, group_sep, dec_sep) %>%
dplyr::mutate(value = 11027) %>%
gt()
for (i in seq(nrow(loc))) {
tab_1 <-
tab_1 %>%
fmt_number(
columns = vars(value),
rows = i,
locale = loc$base_locale_id[i]
)
}
tab_1 %>%
tab_spanner(
label = "Separators",
columns = vars(group_sep, dec_sep)
) %>%
cols_merge(
columns = vars(base_locale_id, display_name),
pattern = "<code>{1}</code><br><span style=font-size:11px>{2}</span>"
) %>%
cols_label(
base_locale_id = "Locale",
group_sep = "Group",
dec_sep = "Decimal",
value = html("Formatted<br>Value")
) %>%
cols_align(
align = "center",
columns = vars(group_sep, dec_sep)
) %>%
tab_header(
title = md("Locales Supported in **gt**"),
subtitle = md("Locale codes are used in several `fmt_*()` functions")
) %>%
tab_style(
style = cell_text(align = "left"),
locations = list(
cells_title(groups = "title"),
cells_title(groups = "subtitle")
)
) %>%
tab_style(
style = cell_text(size = px(32)),
locations = cells_data(columns = vars(group_sep, dec_sep))
) %>%
tab_options(data_row.padding = "5px")
}
#' View a table with info on color palettes
#'
#' While the [data_color()] function allows us to flexibly color data cells in
#' our \pkg{gt} table, the harder part of this process is discovering and
#' choosing color palettes that are suitable for the table output. We can make
#' this process much easier in two ways: (1) by using the \pkg{paletteer}
#' package, which makes a wide range of palettes from various R packages readily
#' available, and (2) calling the `info_paletteer()` function to give us an
#' information table that serves as a quick reference for all of the discrete
#' color palettes available in \pkg{paletteer}.
#'
#' The palettes displayed are organized by package and by palette name. These
#' values are required when obtaining a palette (as a vector of hexadecimal
#' colors), from the the `paletteer::paletteer_d()` function. Once we are
#' familiar with the names of the color palette packages (e.g.,
#' \pkg{RColorBrewer}, \pkg{ggthemes}, \pkg{wesanderson}), we can narrow down
#' the content of this information table by supplying a vector of such package
#' names to `color_pkgs`.
#'
#' Colors from the following color packages (all supported by \pkg{paletteer})
#' are shown by default with `info_paletteer()`:
#' \itemize{
#' \item awtools, 5 palettes
#' \item dichromat, 17 palettes
#' \item dutchmasters, 6 palettes
#' \item ggpomological, 2 palettes
#' \item ggsci, 42 palettes
#' \item ggthemes, 31 palettes
#' \item ghibli, 27 palettes
#' \item grDevices, 1 palette
#' \item jcolors, 13 palettes
#' \item LaCroixColoR, 21 palettes
#' \item NineteenEightyR, 12 palettes
#' \item nord, 16 palettes
#' \item ochRe, 16 palettes
#' \item palettetown, 389 palettes
#' \item pals, 8 palettes
#' \item Polychrome, 7 palettes
#' \item quickpalette, 17 palettes
#' \item rcartocolor, 34 palettes
#' \item RColorBrewer, 35 palettes
#' \item Redmonder, 41 palettes
#' \item wesanderson, 19 palettes
#' \item yarrr, 21 palettes
#' }
#'
#' @param color_pkgs A vector of color packages that determines which sets of
#' palettes should be displayed in the information table. If this is
#' `NULL` (the default) then all of the discrete palettes from all of the
#' color packages represented in \pkg{paletteer} will be displayed.
#' @examples
#' # Get a table of info on just the
#' # `ggthemes` color palette (easily
#' # accessible from the paletteer pkg)
#' tab_1 <-
#' info_paletteer(
#' color_pkgs = "ggthemes")
#'
#' @section Figures:
#' \if{html}{\figure{man_info_paletteer_1.svg}{options: width=100\%}}
#'
#' @family information functions
#' @export
info_paletteer <- function(color_pkgs = NULL) {
if (is.null(color_pkgs)) {
color_pkgs <-
c(
"awtools", "dichromat", "dutchmasters", "ggsci", "ggpomological",
"ggthemes", "ghibli", "grDevices", "jcolors", "LaCroixColoR",
"NineteenEightyR", "nord", "ochRe", "palettetown", "pals",
"Polychrome", "quickpalette", "rcartocolor", "RColorBrewer",
"Redmonder", "tidyquant", "wesanderson", "yarrr")
}
palettes_strips_df <-
palettes_strips %>%
dplyr::filter(package %in% color_pkgs)
palettes_strips <-
palettes_strips_df %>%
dplyr::pull(colors)
palettes_strips_df %>%
dplyr::select(package, palette, length) %>%
dplyr::mutate(`Color Count and Palette` = NA) %>%
gt(groupname_col = "package", rowname_col = "palette") %>%
text_transform(
locations = cells_data("Color Count and Palette"),
fn = function(x) {
palettes_strips
}
) %>%
cols_label(length = "") %>%
tab_stubhead(label = "Package and Palette Name") %>%
tab_header(
title = md("Palettes Made Easily Available with **paletteer**"),
subtitle = md("Palettes like these are useful with the `data_color()` function")
) %>%
tab_style(
style = cell_text(align = "left"),
locations = list(
cells_title(groups = "title"),
cells_title(groups = "subtitle")
)
) %>%
tab_style(
style = list(
cell_fill(color = "#E3E3E3"),
cell_text(font = "Courier", size = "smaller", weight = "bold")
),
locations = cells_stub(rows = TRUE)
) %>%
tab_style(
style = cell_text(font = "Courier"),
locations = cells_data(columns = vars(length))
) %>%
tab_options(
row_group.background.color = "#FFFFF0",
column_labels.background.color = "#666660",
row_group.font.weight = "600",
row_group.font.size = "smaller"
) %>%
tab_source_note(
source_note = md(
paste0(
"The **paletteer** package is maintained by Emil Hvitfeldt. More ",
"information can be found on [the **paletteer** site]",
"(https://emilhvitfeldt.github.io/paletteer/) and on the ",
"[**CRAN** info page]",
"(https://cran.r-project.org/web/packages/paletteer/index.html)."
)
)
)
}
You can’t perform that action at this time.