Draft: specs and vctrs support

DESCRIPTION

@@ -42,7 +42,8 @@ Imports:
     scales (>= 1.1.0),
     stringr (>= 1.3.1),
     tibble (>= 3.0.0),
-    tidyselect (>= 1.0.0)
+    tidyselect (>= 1.0.0),
+    vctrs
 Suggests:
     covr,
     knitr,
@@ -100,6 +101,7 @@ Collate:
     'render_as_html.R'
     'resolver.R'
     'shiny.R'
+    'spec.R'
     'summary_rows.R'
     'text_transform.R'
     'utils.R'
@@ -111,4 +113,6 @@ Collate:
     'utils_render_html.R'
     'utils_render_latex.R'
     'utils_render_rtf.R'
+    'utils_spec.R'
+    'vctrs.R'
     'zzz.R'

NAMESPACE

@@ -1,6 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(as.data.frame,gt_tbl)
+S3method(obj_print_header,gt_vctr)
+S3method(print,gt_spec)
 S3method(print,gt_tbl)
 S3method(print,rtf_text)
 export("%>%")
@@ -67,6 +69,8 @@ export(gt)
 export(gt_latex_dependencies)
 export(gt_output)
 export(gt_preview)
+export(gt_spec_number)
+export(gt_vctr)
 export(gtsave)
 export(html)
 export(info_currencies)
@@ -109,6 +113,7 @@ export(text_transform)
 export(vars)
 export(web_image)
 import(rlang)
+import(vctrs)
 importFrom(dplyr,vars)
 importFrom(ggplot2,ggsave)
 importFrom(htmltools,css)

R/format_data.R

@@ -168,17 +168,6 @@ fmt_number <- function(data,
   # Perform input object validation
   stop_if_not_gt(data = data)
 
-  # 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)
-
-  # Stop function if `locale` does not have a valid value
-  validate_locale(locale)
-
-  # Normalize the `suffixing` input to either return a character vector
-  # of suffix labels, or NULL (the case where `suffixing` is FALSE)
-  suffix_labels <- normalize_suffixing_inputs(suffixing, scale_by)
-
   # Stop function if any columns have data that is incompatible
   # with this formatter
   if (
@@ -195,75 +184,26 @@ fmt_number <- function(data,
     )
   }
 
-  # Set the `formatC_format` option according to whether number
-  # formatting with significant figures is to be performed
-  if (!is.null(n_sigfig)) {
-
-    # Stop function if `n_sigfig` does not have a valid value
-    validate_n_sigfig(n_sigfig)
-
-    formatC_format <- "fg"
-  } else {
-    formatC_format <- "f"
-  }
-
   # 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(
+    fns = gt_spec_number(
+      decimals = decimals,
+      n_sigfig = n_sigfig,
+      drop_trailing_zeros = drop_trailing_zeros,
+      drop_trailing_dec_mark = drop_trailing_dec_mark,
+      use_seps = use_seps,
+      accounting = accounting,
+      scale_by = scale_by,
+      suffixing = suffixing,
       pattern = pattern,
-      format_fn = function(x, context) {
-
-        # Create the `suffix_df` object
-        suffix_df <-
-          create_suffix_df(
-            x,
-            decimals = decimals,
-            suffix_labels = suffix_labels,
-            scale_by = scale_by
-          )
-
-        # Scale the `x` values by the `scale_by` values in `suffix_df`
-        x <- scale_x_values(x, scale_by = suffix_df$scale_by)
-
-        # Format numeric values to character-based numbers
-        x_str <-
-          format_num_to_str(
-            x,
-            context = context,
-            decimals = decimals,
-            n_sigfig = n_sigfig,
-            sep_mark = sep_mark,
-            dec_mark = dec_mark,
-            drop_trailing_zeros = drop_trailing_zeros,
-            drop_trailing_dec_mark = drop_trailing_dec_mark,
-            format = formatC_format
-          )
-
-        # Paste the vector of suffixes to the right of the values
-        x_str <- paste_right(x_str, x_right = suffix_df$suffix)
-
-        # Format values in accounting notation (if `accounting = TRUE`)
-        x_str <-
-          format_as_accounting(
-            x_str,
-            x = x,
-            context = context,
-            accounting = accounting
-          )
-
-        # Force a positive sign on certain values if the option is taken
-        if (!accounting && force_sign) {
-
-          positive_x <- !is.na(x) & x > 0
-          x_str[positive_x] <- paste_left(x_str[positive_x], x_left = "+")
-        }
-
-        x_str
-      }
+      sep_mark = sep_mark,
+      dec_mark = dec_mark,
+      force_sign = force_sign,
+      locale = locale
     )
   )
 }

R/spec.R

@@ -0,0 +1,97 @@
+#' @rdname fmt_number
+#' @export
+gt_spec_number <- function(decimals = 2,
+                           n_sigfig = NULL,
+                           drop_trailing_zeros = FALSE,
+                           drop_trailing_dec_mark = TRUE,
+                           use_seps = TRUE,
+                           accounting = FALSE,
+                           scale_by = 1.0,
+                           suffixing = FALSE,
+                           pattern = "{x}",
+                           sep_mark = ",",
+                           dec_mark = ".",
+                           force_sign = FALSE,
+                           locale = NULL) {
+
+  call <- capture_call("gt_spec_number")
+
+  # 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)
+
+  # Stop function if `locale` does not have a valid value
+  validate_locale(locale)
+
+  # Normalize the `suffixing` input to either return a character vector
+  # of suffix labels, or NULL (the case where `suffixing` is FALSE)
+  suffix_labels <- normalize_suffixing_inputs(suffixing, scale_by)
+
+  # Set the `formatC_format` option according to whether number
+  # formatting with significant figures is to be performed
+  if (!is.null(n_sigfig)) {
+
+    # Stop function if `n_sigfig` does not have a valid value
+    validate_n_sigfig(n_sigfig)
+
+    formatC_format <- "fg"
+  } else {
+    formatC_format <- "f"
+  }
+
+  # Return the factory
+  funs <- num_fmt_factory_multi(
+    pattern = pattern,
+    format_fn = function(x, context) {
+
+      # Create the `suffix_df` object
+      suffix_df <-
+        create_suffix_df(
+          x,
+          decimals = decimals,
+          suffix_labels = suffix_labels,
+          scale_by = scale_by
+        )
+
+      # Scale the `x` values by the `scale_by` values in `suffix_df`
+      x <- scale_x_values(x, scale_by = suffix_df$scale_by)
+
+      # Format numeric values to character-based numbers
+      x_str <-
+        format_num_to_str(
+          x,
+          context = context,
+          decimals = decimals,
+          n_sigfig = n_sigfig,
+          sep_mark = sep_mark,
+          dec_mark = dec_mark,
+          drop_trailing_zeros = drop_trailing_zeros,
+          drop_trailing_dec_mark = drop_trailing_dec_mark,
+          format = formatC_format
+        )
+
+      # Paste the vector of suffixes to the right of the values
+      x_str <- paste_right(x_str, x_right = suffix_df$suffix)
+
+      # Format values in accounting notation (if `accounting = TRUE`)
+      x_str <-
+        format_as_accounting(
+          x_str,
+          x = x,
+          context = context,
+          accounting = accounting
+        )
+
+      # Force a positive sign on certain values if the option is taken
+      if (!accounting && force_sign) {
+
+        positive_x <- !is.na(x) & x > 0
+        x_str[positive_x] <- paste_left(x_str[positive_x], x_left = "+")
+      }
+
+      x_str
+    }
+  )
+
+  new_gt_spec(funs, call)
+}

R/utils_spec.R

@@ -0,0 +1,17 @@
+capture_call <- function(name = as.character(sys.call(1))[[1]], fun = sys.function(sys.parent()), env = parent.frame()) {
+  formals <- formals(fun)
+  args <- mget(names(formals), env)
+
+  same <- unlist(Map(formals, args, f = identical))
+  custom_args <- args[!same]
+  call2(name, !!!custom_args)
+}
+
+new_gt_spec <- function(funs, call) {
+  structure(funs, call = call, class = "gt_spec")
+}
+
+#' @export
+print.gt_spec <- function(x, ...) {
+  cat("<", as_label(attr(x, "call")), ">\n", sep = "")
+}

R/vctrs.R

@@ -0,0 +1,18 @@
+#' Attach a spec to a vector
+#'
+#' Use `gt_vctr()` early in your analysis to define the formatting of numbers
+#' and other data.
+#' The formatting is then picked up automatically by `gt()`.
+#'
+#' @param x A numeric vector
+#' @param spec Created by [gt_spec_number()] and other functions.
+#' @import vctrs
+#' @export
+gt_vctr <- function(x, spec) {
+  vctrs::new_vctr(x, gt_spec = spec, class = "gt_vctr")
+}
+
+#' @export
+obj_print_header.gt_vctr <- function(x, ...) {
+  print(attr(x, "gt_spec"))
+}

_pkgdown.yml

@@ -65,6 +65,17 @@ reference:
     - text_transform
     - data_color
 
+  - title: Data Format Specifications
+    desc: >
+      Each `fmt_*()` function uses a corresponding `gt_spec_*()` function under
+      the hood. Columns in the raw data can choose their formatting early
+      using `gt_vctr()` with a data format specification, it will be picked up
+      automatically by `gt()` and also when such a column is used in a ggplot2
+      scale.
+    contents:
+    - gt_spec_number
+    - gt_vctr
+
   - title: Modify Columns
     desc: >
       The `cols_*()` functions allow for modifications that act on entire