Add the fmt_fraction() formatter function

NAMESPACE

@@ -52,6 +52,7 @@ export(fmt_currency)
 export(fmt_date)
 export(fmt_datetime)
 export(fmt_engineering)
+export(fmt_fraction)
 export(fmt_integer)
 export(fmt_markdown)
 export(fmt_missing)

R/format_data.R

@@ -996,6 +996,310 @@ fmt_percent <- function(data,
   )
 }
 
+#' Format values as a mixed fractions
+#'
+#' @description
+#' With numeric values in a **gt** table, we can perform mixed-fraction-based
+#' formatting. There are several options for setting the accuracy of the
+#' fractions (e.g., setting the number of desired figures in the denominator or
+#' expressing fractions with fixed denominators). The following options are
+#' available for controlling this type of formatting:
+#'
+#' - accuracy: how to express the fractional part of the mixed fractions; there
+#' are nine named options for this.
+#' - layout: for HTML output, we can choose to use diagonal or inline fractions
+#' - digit grouping separators: options to enable/disable digit separators
+#' and provide a choice of separator symbol for the whole number portion
+#' - pattern: option to use a text pattern for decoration of the formatted
+#' mixed fractions
+#' - locale-based formatting: providing a locale ID will result in number
+#' formatting specific to the chosen locale
+#'
+#' @details
+#' Targeting of values is done through `columns` and additionally by `rows` (if
+#' nothing is provided for `rows` then entire columns are selected). A number of
+#' helper functions exist to make targeting more effective. Conditional
+#' formatting is possible by providing a conditional expression to the `rows`
+#' argument. See the Arguments section for more information on this.
+#'
+#' @inheritParams fmt_number
+#' @param accuracy The type of fractions to generate. With either of `"low"`,
+#'   `"med"`, and `"high"` we can generate fractions with denominators of up to
+#'   1, 2, or 3 digits. Several options provide a fixed denominator: `"/2"` (for
+#'   fractions as halves), `"/4"` (quarters), `"/8"` (eighths), `"/16"`
+#'   (sixteenths), and `"1/100"` (hundredths).
+#' @param layout For HTML output, the `"diagonal"` layout is the default. This
+#'   will generate fractions that are typeset with raised/lowered numerals and a
+#'   virgule. The `"inline"` layout places the numerals of the fraction on the
+#'   baseline and uses a standard slash character.
+#'
+#' @return An object of class `gt_tbl`.
+#'
+#' @family Format Data
+#' @section Function ID:
+#' 3-6
+#'
+#' @import rlang
+#' @export
+fmt_fraction <- function(
+    data,
+    columns,
+    rows = everything(),
+    accuracy = c("low", "med", "high", "/2", "/4", "/8", "/16", "/100"),
+    layout = c("diagonal", "inline"),
+    use_seps = TRUE,
+    pattern = "{x}",
+    sep_mark = ",",
+    dec_mark = ".",
+    locale = NULL
+) {
+
+  accuracy <- match.arg(accuracy)
+  layout <- match.arg(layout)
+
+  # Perform input object validation
+  stop_if_not_gt(data = data)
+
+  # Resolve the `locale` value here with the global locale value
+  locale <- resolve_locale(data = data, locale = locale)
+
+  # Stop function if any columns have data that is incompatible
+  # with this formatter
+  if (!column_classes_are_valid(
+    data = data,
+    columns = {{ columns }},
+    valid_classes = c("numeric", "integer")
+  )
+  ) {
+    stop(
+      "The `fmt_fraction()` function can only be used on `columns` with numeric data",
+      call. = FALSE
+    )
+  }
+
+  # In the inline layout (where there is no special typesetting of the
+  # fraction part) we must include a space to distinguish between the
+  # whole number and fraction parts
+  # if (layout == "inline") {
+  #   incl_space <- TRUE
+  # }
+
+  # Use locale-based marks if a locale ID is provided
+  sep_mark <- get_locale_sep_mark(locale, sep_mark, use_seps)
+  dec_mark <- get_locale_dec_mark(locale, dec_mark)
+
+  # Pass `data`, `columns`, `rows`, and the formatting
+  # functions as a function list to `fmt()`
+  fmt(
+    data = data,
+    columns = {{ columns }},
+    rows = {{ rows }},
+    fns = num_fmt_factory_multi(
+      pattern = pattern,
+      format_fn = function(x, context) {
+
+        # Round all values of x to 3 digits with the R-H-U method of
+        # rounding (for reproducibility purposes)
+        x <- round_gt(x, 3)
+
+        # Determine which of `x` are finite values
+        x_is_a_number <- is.finite(x)
+
+        # Divide the `x` values in 'big' and 'small' components; delay the
+        # formatting of `big_x` until it is appropriately rounded on the
+        # basis of the fractions obtained at the desired accuracy
+        big_x <- trunc(x)
+        small_x <- abs(x - big_x)
+
+        # Get the correct minus mark based on the output context
+        minus_mark <- context_minus_mark(context = context)
+
+        # Format the 'small' portion of the numeric values
+        # to character-based numbers with exactly 3 decimal places
+        small_x[x_is_a_number] <-
+          format_num_to_str(
+            small_x[x_is_a_number],
+            context = context, decimals = 3, n_sigfig = NULL,
+            sep_mark = ",", dec_mark = ".",
+            drop_trailing_zeros = FALSE,
+            drop_trailing_dec_mark = TRUE,
+            format = "f"
+          )
+
+        # Map the `accuracy` keyword to a column index in the
+        # internal `fractions` dataset
+        fractions_col_idx <-
+          which(c("low", "med", "high", "/2", "/4", "/8", "/16", "/100") %in% accuracy) + 1
+
+        # Generate an vector of empty strings that will eventually contain
+        # all of the fractional parts of the finalized numbers
+        fraction_x <- rep("", length(x))
+
+        # For every `small_x` value that corresponds to a number
+        # (i.e., not Inf), get the fractional part from the `fractions`
+        # lookup table
+        fraction_x[x_is_a_number] <-
+          vapply(
+            small_x[x_is_a_number],
+            FUN.VALUE = character(1),
+            USE.NAMES = FALSE,
+            FUN = function(x) {
+              fractions[fractions[["x"]] == x, ][[fractions_col_idx]]
+            }
+          )
+
+        # Round up or down the `big_x` values when necessary; values
+        # of exactly "1" indicate a requirement for rounding and this
+        # is a two-pass operation to handle positive and then negative
+        # values of `big_x`
+        big_x[big_x >= 0 & fraction_x == "1"] <-
+          big_x[big_x >= 0 & fraction_x == "1"] + 1
+
+        big_x[big_x <= 0 & fraction_x == "1"] <-
+          big_x[big_x <= 0 & fraction_x == "1"] - 1
+
+        # Remove whole number values from `fraction_x`; they were only
+        # needed for rounding guidance and they signal the lack of a
+        # fractional part
+        fraction_x[fraction_x %in% c("0", "1")] <- ""
+
+        # Format the 'big' portion of the numeric values
+        # to character-based numbers
+        big_x <-
+          format_num_to_str(
+            big_x,
+            context = context, decimals = 0, n_sigfig = NULL,
+            sep_mark = sep_mark, dec_mark = dec_mark,
+            drop_trailing_zeros = TRUE,
+            drop_trailing_dec_mark = TRUE,
+            format = "f"
+          )
+
+        # Initialize a vector that will contain the finalized strings
+        x_str <- character(length(x))
+
+        # Generate the mixed fractions by pasting `big_x` and `small_x`
+        # while ensuring there is a single space between these components
+        x_str[x_is_a_number] <-
+          paste(
+            big_x[x_is_a_number],
+            fraction_x[x_is_a_number],
+            sep = " "
+          )
+
+        # Trim any whitespace
+        x_str <- gsub("(^ | $)", "", x_str)
+
+        # Eliminate the display of leading zeros in mixed fractions
+        x_str <- gsub("^0\\s+?", "", x_str)
+
+        # There are situations where small fractions (not mixed) require
+        # a minus mark; these conditions are specific so we need to ascertain
+        # which values in `x_str` require this and then apply the mark to
+        # the targets
+        x_is_negative <- x < 0
+        x_is_zero <- x_str == "0"
+        x_has_minus_mark <- grepl(minus_mark, big_x)
+        x_needs_minus_mark <- x_is_negative & !x_is_zero & !x_has_minus_mark
+
+        x_str[x_needs_minus_mark] <- paste0(minus_mark, x_str[x_needs_minus_mark])
+
+        # Generate diagonal fractions if the `layout = "diagonal"` option was chosen
+        if (layout == "diagonal") {
+
+          has_a_fraction <- grepl("/", x_str)
+
+          non_fraction_part <- gsub("^(.*?)[0-9]*/[0-9]*", "\\1", x_str[has_a_fraction])
+
+          fraction_part <- gsub("^(.*?)([0-9]*/[0-9]*)", "\\2", x_str[has_a_fraction])
+
+          num_vec <- strsplit(fraction_part, "/") %>% lapply(`[[`, 1) %>% unlist()
+          denom_vec <- strsplit(fraction_part, "/") %>% lapply(`[[`, 2) %>% unlist()
+
+          if (context == "html") {
+
+            num_vec <-
+              paste0("<span class=\"gt_fraction_numerator\">", num_vec, "</span>")
+
+            denom_vec <-
+              paste0("<span class=\"gt_fraction_denominator\">", denom_vec, "</span>")
+
+            slash_mark <-
+              htmltools::tags$span(
+                class = "gt_slash_mark",
+                htmltools::HTML("&frasl;")
+              )
+
+            x_str[has_a_fraction] <-
+              paste0(
+                gsub(" ", "&#8239;", non_fraction_part),
+                num_vec, slash_mark, denom_vec
+              )
+
+          } else if (context == "latex") {
+
+            x_str[has_a_fraction] <-
+              paste0(
+                gsub(" ", "\\\\, ", non_fraction_part),
+                paste0("{{}^{", num_vec, "}\\!/_{", denom_vec, "}}")
+              )
+
+          } else if (context == "rtf") {
+
+            x_str[has_a_fraction] <-
+              paste0(
+                gsub(" ", "", non_fraction_part),
+                paste0("{\\super ", num_vec, "}/{\\sub ", denom_vec, "}")
+              )
+          }
+        }
+
+        # For the `layout = "inline"` option, LaTeX outputs in math mode
+        # disregard space characters so the `\ ` spacing command must used
+        if (layout == "inline" && context == "latex") {
+          x_str <- gsub(" ", "\\\\ ", x_str)
+        }
+
+        # In rare cases that Inf or -Inf appear, ensure that these
+        # special values are printed correctly
+        x_str[is.infinite(x)] <- x[is.infinite(x)]
+
+        x_str
+      }
+    )
+  )
+}
+
+get_fractions <- function(small_x, accuracy) {
+
+  fractions_col_idx <-
+    which(c("low", "med", "high", "/2", "/4", "/8", "/16", "/100") %in% accuracy) + 1
+
+  vapply(
+    small_x,
+    FUN.VALUE = character(1),
+    USE.NAMES = FALSE,
+    FUN = function(x) {
+      res <- fractions[fractions[["x"]] == x, ][[fractions_col_idx]]
+      if (res %in% c("0", "1")) res <- ""
+      res
+    }
+  )
+}
+
+# The `round_gt()` function is used in gt over `base::round()` for consistency
+# in rounding across R versions; it uses the 'Round-Half-Up' (R-H-U) algorithm,
+# which is *not* used in R >= 4.0
+round_gt <- function(x, digits = 0) {
+
+  x_sign <- sign(x)
+  z <- abs(x) * 10^digits
+  z <- 0.5 + z + sqrt(.Machine$double.eps)
+  z <- trunc(z)
+  z <- z / 10^digits
+  z * x_sign
+}
+
 #' Format values as currencies
 #'
 #' @description
@@ -1101,7 +1405,7 @@ fmt_percent <- function(data,
 #'
 #' @family Format Data
 #' @section Function ID:
-#' 3-6
+#' 3-7
 #'
 #' @import rlang
 #' @export
@@ -1246,7 +1550,7 @@ fmt_currency <- function(data,
 #'
 #' @family Format Data
 #' @section Function ID:
-#' 3-7
+#' 3-8
 #'
 #' @import rlang
 #' @export

_pkgdown.yml

@@ -58,6 +58,7 @@ reference:
     - fmt_scientific
     - fmt_engineering
     - fmt_percent
+    - fmt_fraction
     - fmt_currency
     - fmt_bytes
     - fmt_date

data-raw/X04-palettes_strips.R

@@ -56,10 +56,13 @@ get_d_palettes <- function(color_packages = c(
     dplyr::filter(package %in% color_packages) %>%
     mutate(colors = "NA_character_")
 
-  for (i in seq(nrow(palettes))) {
+  for (i in seq_len(nrow(palettes))) {
+
+    pkg <- palettes[[i, "package"]]
+    pal <- palettes[[i, "palette"]]
 
     color_strip <-
-      palettes_d[[palettes[i, "package"]]][[palettes[i, "palette"]]] %>%
+      palettes_d[[pkg]][[pal]] %>%
       make_color_strip_svg()
 
     palettes[i, "colors"] <- color_strip

data-raw/X05-google_fonts.R

@@ -9,7 +9,7 @@ fs::dir_create(work_dir)
 
 # Download and extract the tarball for the google/font repository
 downloader::download(
-  "https://github.com/google/fonts/tarball/master",
+  "https://github.com/google/fonts/tarball/main",
   destfile = file.path(work_dir, "google_fonts.tar.gz")
 )
 utils::untar(file.path(work_dir, "google_fonts.tar.gz"), exdir = work_dir)

data-raw/X07-fractions.R

@@ -0,0 +1,7 @@
+library(tidyverse)
+
+fractions <-
+  readr::read_csv(
+    file = "data-raw/fractions.csv",
+    col_types = "ccccccccc"
+  )