R/fmt_symbol_first.R

In gtExtras: Extending 'gt' for Beautiful HTML Tables

#' Aligning first-row text only
#' @description
#' This is an experimental function that allows you to apply a suffix/symbol
#' to only the first row of a table, and maintain the alignment with whitespace
#' in the remaining rows.
#' @param gt_object An existing gt table object of class `gt_tbl`
#' @param column columns to apply color to with tidyeval
#' @param symbol The HTML code or raw character string of the symbol being inserted, optionally
#' @param suffix a suffix to add, optionally
#' @param decimals the number of decimal places to round to
#' @param last_row_n Defining the last row to apply this to. The function will attempt to guess the proper length, but you can always hardcode a specific length.
#' @param symbol_first TRUE/FALSE - symbol before after suffix.
#' @param scale_by A numeric value to multiply the values by. Useful for scaling percentages from 0 to 1 to 0 to 100.
#' @param gfont A string passed to `gt::google_font()` - Existing Google Monospaced fonts are available at: [fonts.google.com](https://fonts.google.com/?category=Monospace&preview.text=0123456789&preview.text_type=custom)
#' @return An object of class `gt_tbl`.
#' @export
#' @examples
#' library(gt)
#' fmted_tab <- gtcars %>%
#'   head() %>%
#'   dplyr::select(mfr, year, bdy_style, mpg_h, hp) %>%
#'   dplyr::mutate(mpg_h = rnorm(n = dplyr::n(), mean = 22, sd = 1)) %>%
#'   gt::gt() %>%
#'   gt::opt_table_lines() %>%
#'   fmt_symbol_first(column = mfr, symbol = "&#x24;", last_row_n = 6) %>%
#'   fmt_symbol_first(column = year, suffix = "%") %>%
#'   fmt_symbol_first(column = mpg_h, symbol = "&#37;", decimals = 1) %>%
#'   fmt_symbol_first(hp, symbol = "&#176;", suffix = "F", symbol_first = TRUE)
#'
#' @section Figures:
#' \if{html}{\figure{gt_fmt_first.png}{options: width=500}}
#'
#' @family Utilities
#' @section Function ID:
#' 2-1

fmt_symbol_first <- function(
  gt_object,
  column = NULL, # column of interest to apply to
  symbol = NULL, # symbol to add, optionally
  suffix = "", # suffix to add, optionally
  decimals = NULL, # number of decimal places to round to
  last_row_n = NULL, # what's the last row in data?
  symbol_first = FALSE, # symbol before or after suffix?,
  scale_by = NULL, # scaling value for things like percentages
  gfont = NULL # Google font option
) {
  stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object))
  # Test and error out if mandatory columns are missing
  stopifnot(
    "`symbol_first` argument must be a logical" = is.logical(symbol_first)
  )
  # stopifnot("`last_row_n` argument must be specified and numeric" = is.numeric(last_row_n))
  stopifnot("Input must be a gt table" = "gt_tbl" %in% class(gt_object))

  decimals <- decimals

  # needs to type convert to double to play nicely with decimals and rounding
  # as it's converted to character by gt::text_transform

  add_to_first <- function(x, suff = suffix, symb = symbol) {
    if (!is.null(decimals) && !is.null(scale_by)) {
      # if decimal not null, convert to double
      x <- suppressWarnings(as.double(x) * scale_by)
      fmt_val <- format(x = x, nsmall = decimals, digits = decimals)
    } else if (!is.null(decimals) && is.null(scale_by)) {
      # if decimal not null, convert to double
      x <- suppressWarnings(as.double(x))
      fmt_val <- format(x = x, nsmall = decimals, digits = decimals)
    } else if (is.null(decimals) && is.null(scale_by)) {
      fmt_val <- x
    }

    # combine the value, passed suffix, symbol -> html
    if (isTRUE(symbol_first)) {
      paste0(fmt_val, symb, suff) %>% gt::html()
    } else {
      paste0(fmt_val, suff, symb) %>% gt::html()
    }
  }

  # TODO remove in future?
  # # repeat non-breaking space for combined length of suffix + symbol
  # # logic is based on is a NULL passed or not
  # if (!is.null(symbol) | !identical(as.character(symbol), character(0))) {
  #   suffix <- ifelse(identical(as.character(suffix), character(0)), "", suffix)
  #   length_nbsp <- c("&nbsp;", rep("&nbsp;", nchar(suffix))) %>%
  #     paste0(collapse = "")
  # } else {
  #   suffix <- ifelse(identical(as.character(suffix), character(0)), "", suffix)
  #   length_nbsp <- rep("&nbsp;", nchar(suffix)) %>%
  #     paste0(collapse = "")
  # }

  # affect rows OTHER than the first row
  add_to_remainder <- function(
    x #,
    # TODO remove in future?
    # length = length_nbsp
  ) {
    if (!is.null(decimals) && !is.null(scale_by)) {
      # if decimal not null, convert to double
      x <- suppressWarnings(as.double(x) * scale_by)
      # then round and format ALL to force specific decimals
      fmt_val <- format(x = x, nsmall = decimals, digits = decimals)
    } else if (!is.null(decimals) && is.null(scale_by)) {
      # if decimal not null, convert to double
      x <- suppressWarnings(as.double(x))
      # then round and format ALL to force specific decimals
      fmt_val <- format(x = x, nsmall = decimals, digits = decimals)
    } else if (is.null(decimals) && is.null(scale_by)) {
      fmt_val <- x
    }
    paste0(
      fmt_val,
      "<span style='color: transparent;'>",
      symbol,
      suffix,
      "</span>"
    ) %>%
      lapply(FUN = gt::html)
  }

  # default to nrows in input data
  if (is.null(last_row_n)) {
    last_row_n <- nrow(gt_object[["_data"]])
  } else {
    last_row_n <- last_row_n
  }

  # pass gt object
  # align right to make sure the spacing is meaningful
  tab_out <- gt_object %>%
    cols_align(align = "right", columns = c({{ column }})) %>%
    # transform first rows
    text_transform(
      locations = cells_body(c({{ column }}), rows = 1),
      fn = add_to_first
    ) %>%
    # transform remaining rows
    text_transform(
      locations = cells_body(c({{ column }}), rows = 2:last_row_n),
      fn = add_to_remainder
    )

  if (!is.null(gfont)) {
    tab_out <- tab_out %>%
      # convert to mono-font for column of interest
      tab_style(
        style = cell_text(font = google_font(gfont)),
        locations = cells_body(columns = c({{ column }}))
      )
  }

  tab_out
}