R/fontawesome-icons.R

In gtExtras: Extending 'gt' for Beautiful HTML Tables

#' Repeat `{fontawesome}` icons based on an integer.
#' @description
#' The `gt_fa_repeats` function takes an existing `gt_tbl` object and
#' adds specific `fontawesome` to the cells. The icons are repeated according to the
#' integer that the column contains.
#'
#' @param gt_object An existing gt table object of class `gt_tbl`
#' @param column The column wherein the integers should be replaced with `{fontawesome}` icons.
#' @param name A character string indicating the name of the "`fontawesome` icon.
#' @param ... Additional arguments passed to `fontawesome::fa()`
#' @param palette Name of palette as a string. Must be either length of 1 or a vector of valid color names/hex values of equal length to the unique levels of the column (ie if there are 4 names, there need to be 4x colors).
#' @param align Character string indicating alignment of the column, defaults to "left"
#' @param direction The direction of the `paletteer` palette, should be either `-1` for reversed or the default of `1` for the existing direction.
#' @return An object of class `gt_tbl`.
#' @export
#' @section Examples:
#' ```r
#' library(gt)
#' mtcars[1:5, 1:4] %>%
#'   gt() %>%
#'   gt_fa_repeats(cyl, name = "car")
#' ```
#' @section Figures:
#' \if{html}{\figure{fa-cars.png}{options: width=50\%}}
#'
#' @family Utilities
#' @section Function ID:
#' 2-8

gt_fa_repeats <- function(gt_object, column, name = NULL, ...,
                          palette = NULL, align = "left",
                          direction = 1) {
  stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object))

  text_transform(
    gt_object,
    locations = cells_body(columns = {{ column }}),
    fn = function(x) {
      int_conv <- suppressWarnings(as.integer(x))
      int_x <- int_conv[!is.na(int_conv)]

      if (is.null(palette) && length(unique(int_x)) >= 8) {
        stop("Please add your own palette that is equal to the number of unique counts", call. = FALSE)
      }

      if (is.null(palette)) {
        pal_filler <- rev(c(
          "#CC79A7", "#D55E00", "#0072B2",
          "#F0E442", "#009E73", "#56B4E9",
          "#E69F00", "#000000"
        ))[seq_along(unique(int_x))]
      } else if (length(palette) == 1) {
        pal_filler <- palette %>% rep(length(unique(int_x)))
      } else {
        pal_filler <- palette
      }

      lapply(X = int_conv, FUN = function(xy) {
        # handle missing values
        if (is_blank(xy) || is.na(xy)) {
          return(gt::html("&nbsp;"))
        }

        fct_x <- factor(xy, levels = unique(int_x), labels = pal_filler) %>%
          as.character()


        fct_lvl <- suppressWarnings(unique(x[!is.na(as.integer(x))]))

        stopifnot("The length of the unique elements must match the palette length" = length(fct_lvl) == length(pal_filler))

        fa_repeats <- fontawesome::fa(name, ..., fill = fct_x, height = "20px", a11y = "sem") %>%
          as.character() %>%
          rep(., xy) %>%
          gt::html()

        label <- paste(xy, name)

        htmltools::div(
          title = label, "aria-label" = label, role = "img",
          list(fa_repeats)
        )
      })
    }
  ) %>%
    cols_align(align = align, columns = {{ column }})
}

#' Add `{fontawesome}` icons inside a `{gt}` column.
#' @description
#' The `gt_fa_column` function takes an existing `gt_tbl` object and
#' adds specific `fontawesome` icons based on what the names in the column are.
#' The icons are colored according to a palette that the user supplies, either
#' a vector of valid colors/hex colors of length equal to the unique levels.
#'
#' @param gt_object An existing gt table object of class `gt_tbl`
#' @param column The column wherein the character strings should be replaced with their corresponding `{fontawesome}` icons.
#' @param ... Additional arguments passed to `fontawesome::fa()`
#' @param palette Name of palette as a string. Must be either length of 1 or a vector of valid color names/hex values of equal length to the unique levels of the column (ie if there are 4 names, there need to be 4x colors). Note that if you would like to specify a specific color to match a specific icon, you can also use a named vector like: `c("angle-double-up" = "#009E73", "angle-double-down" = "#D55E00","sort" = "#000000")`
#' @param align Character string indicating alignment of the column, defaults to "left"
#' @param direction The direction of the `paletteer` palette, should be either `-1` for reversed or the default of `1` for the existing direction.
#' @param height A character string indicating the height of the icon, defaults to "20px"
#' @return An object of class `gt_tbl`.
#' @export
#' @section Examples:
#' ```r
#' library(gt)
#' fa_cars <- mtcars %>%
#'   head() %>%
#'   dplyr::select(cyl, mpg, am, gear) %>%
#'   dplyr::mutate(man = ifelse(am == 1, "gear", "gears")) %>%
#'   gt() %>%
#'   gt_fa_column(man)
#' ```
#' @section Figures:
#' \if{html}{\figure{fa-column-cars.png}{options: width=50\%}}
#'
#' @family Utilities
#' @section Function ID:
#' 2-15

gt_fa_column <- function(gt_object, column, ..., palette = NULL,
                         align = "left", direction = 1, height = "20px") {
  stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object))

  text_transform(
    gt_object,
    locations = cells_body(columns = {{ column }}),
    fn = function(x) {

      if (is.null(palette)) {
        # if no palette use categorical colorblind palette
        pal_filler <- c(
          "#000000", "#E69F00", "#56B4E9", "#009E73",
          "#F0E442", "#0072B2", "#D55E00", "#CC79A7"
        )[seq_along(unique(x[!(x %in% c("", "NA", NA))]))]
        # if single color, then repeat to match length
      } else if (length(palette) == 1) {
        pal_filler <- palette %>% rep(length(unique(x)))
      } else if (all(unique(x) %in% names(palette))) {
        pal_no_missing <- x[!x %in% c("", "NA", NA, "NULL", NULL)]
        # palette is superset of values,
        # so reduce palette to just what's needed
        pal_filler <- palette[unique(pal_no_missing)]
      } else {
        # palette is the palette
        pal_filler <- palette
      }

      # pass arguments into anonymous function
      lapply(X = x, FUN = function(xy) {
        if (xy %in% c("", "NA", NA, NULL, "NULL")) {
          return(gt::html("&nbsp;"))
        }

        # drop missing levels
        x <- x[!(x %in% c("", "NA", NA, NULL, "NULL"))]

        fct_lvl <- unique(x)
        # TODO revisit if a useful check, since I'm dropping missing vals
        # stopifnot(
        #   "The length of the unique elements must match the palette length" =
        #     length(fct_lvl) == length(as.vector(na.omit(pal_filler)))
        #   )

        if (!is.null(names(pal_filler))) {
          fct_x <- factor(xy, levels = names(pal_filler), labels = pal_filler) %>%
            as.character()
        } else {
          fct_x <- factor(xy, levels = fct_lvl, labels = pal_filler) %>%
            as.character()
        }

        # conditional to return blanks if the passed element
        # is missing, NA, NULL, or blank
        if (!nzchar(xy) || is_blank(xy)) {
          gt::html("&nbsp;")
        } else {
          my_fa <- list(
            fontawesome::fa(xy, ...,
              fill = fct_x,
              height = height, a11y = "sem"
            ) %>% gt::html()
          )
          htmltools::div(
            title = xy, "aria-label" = xy, role = "img",
            my_fa, style = "padding:0px"
          )
        }
      })
    }
  ) %>%
    cols_align(align = align, columns = {{ column }})
}




#' Add rating "stars" to a gt column
#'
#' @param gt_object An existing gt table object of class `gt_tbl`
#' @param column The column wherein the numeric values should be replaced with their corresponding `{fontawesome}` icons.
#' @param max_rating The max number of icons to add, these will be added in grey to indicate "missing"
#' @param ... Additional arguments passed to `fontawesome::fa()`
#' @param color The color of the icon, accepts named colors (`"orange"`) or hex strings.
#' @param icon The icon name, passed to `fontawesome::fa()`
#'
#' @return An object of class `gt_tbl`.
#' @export
#'
#' @section Examples:
#' ```r
#' library(gt)
#' set.seed(37)
#' rating_table <- mtcars %>%
#'   dplyr::select(mpg:wt) %>%
#'   dplyr::slice(1:5) %>%
#'   dplyr::mutate(rating = sample(1:5, size = 5, TRUE)) %>%
#'   gt() %>%
#'   gt_fa_rating(rating, icon = "r-project")
#' ```
#' @section Figures:
#' \if{html}{\figure{fa-stars.png}{options: width=60\%}}
#'
#' @family Utilities
#' @section Function ID:
#' 2-16

gt_fa_rating <- function(gt_object, column, max_rating = 5, ...,
                         color = "orange", icon = "star") {
  stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object))

  text_transform(
    gt_object,
    locations = cells_body(columns = {{ column }}),
    fn = function(x) {
      # convert the raw text to numeric
      num_x <- suppressWarnings(as.numeric(x))

      lapply(X = num_x, FUN = function(rating) {
        # handle missing values & return a blank space if missing
        if (is_blank(rating) || rating %in% c(NA, "NA", "")) {
          return(gt::html("&nbsp;"))
        }
        # adapted from: glin.github.io/reactable/articles/cookbook/cookbook.html#rating-stars
        rounded_rating <- floor(rating + 0.5) # always round up
        stars <- lapply(seq_len(max_rating), function(i) {
          if (i <= rounded_rating) {
            fontawesome::fa(icon, fill = color, height = "20px", a11y = "sem")
          } else {
            fontawesome::fa(icon, fill = "grey", height = "20px", a11y = "sem")
          }
        })
        label <- sprintf("%s out of %s", rating, max_rating)
        div_out <- htmltools::div(title = label, "aria-label" = label, role = "img", stars, style = "padding:0px")

        # need to convert from text to html
        as.character(div_out) %>%
          gt::html()
      })
    }
  ) %>%
    cols_align(align = "left", columns = {{ column }})
}


#' Add rank change indicators to a gt table
#' @description Takes an existing `gt` table and converts a column of integers
#' into various types of up/down arrows. Note that you need to specify a palette
#' of three colors, in the order of up, neutral, down. Defaults to green, grey,
#' purple. There are 6 supported `fa_type`, representing various arrows.
#' Note that you can use `font_color = 'match'` to match the palette across
#' arrows and text. `show_text = FALSE` will remove the text from the column,
#' resulting only in colored arrows.
#' @param gt_object An existing `gt` table object
#' @param column The single column that you would like to convert to rank change indicators.
#' @param palette A character vector of length 3. Colors can be represented as hex values or named colors. Colors should be in the order of up-arrow, no-change, down-arrow, defaults to green, grey, purple.
#' @param fa_type The name of the Fontawesome icon, limited to 5 types of various arrows, one of `c("angles", "arrow", "turn", "chevron", "caret")`
#' @param font_color A string, indicating the color of the font, can also be returned as `'match'` to match the font color to the arrow palette.
#' @param show_text A logical indicating whether to show/hide the values in the column.
#' @return a `gt` table
#' @export
#'
#' @section Examples:
#' ```r
#' rank_table <- dplyr::tibble(x = c(1:3, -1, -2, -5, 0)) %>%
#'   gt::gt() %>%
#'   gt_fa_rank_change(x, font_color = "match")
#' ```
#' @section Figures:
#' \if{html}{\figure{fa_rank_change.png}{options: width=5\%}}
#'
#' @family Utilities
gt_fa_rank_change <- function(
    gt_object,
    column,
    palette = c("#1b7837", "lightgrey", "#762a83"),
    fa_type = c("angles", "arrow", "turn", "chevron", "caret"),
    font_color = "black",
    show_text = TRUE) {

  vals <- gt_index(gt_object, {{ column }})

  stopifnot("Column must be integers" = is.integer(as.integer(vals)))
  stopifnot("Palette must be length 3, in order of increase, no change, decrease" = length(palette) == 3)
  stopifnot(
    'fa_type must be one of "angles", "arrow", "turn", "chevron", "caret"' =
      fa_type %in% c("angles", "arrow", "turn", "chevron", "caret")
  )

  # internal function
  # could possibly pull out to standalone function
  fa_rank_chg <- function(fa_name, color, font_color, text) {
    if (font_color == "match") {
      font_color <- color
    }

    if (is_blank(text) || is_blank(fa_name)) {
      return(gt::html("<bold style='color:#d3d3d3;'>--</bold>"))
    } else if (!nzchar(text) & !is_blank(text)) {
      fa_height <- "20px"
    } else if (nzchar(text) & !is_blank(text)) {
      fa_height <- "12px"
    }

    # fill the Fontawesome call
    my_fa <- list(
      fontawesome::fa(
        name = fa_name, fill = color, height = fa_height,
        a11y = "sem"
      ) %>% gt::html()
    )

    # hardcode some HTML/CSS styling
    htmltools::div(
      "aria-label" = text, role = "img",
      htmltools::div(my_fa, style = "float: left;margin-right:1px;"),
      htmltools::div(text, style = "float:right;"),
      style = glue::glue("padding:0px;display:inline;color:{font_color};font-weight:bold;font-size:12px;")
    ) %>%
      as.character() %>%
      gt::html()
  }

  gt_object %>%
    text_transform(
      locations = cells_body({{ column }}),
      fn = function(x) {

        vals <- gt_index(gt_object, {{ column }})

        color_vals <- dplyr::case_when(
          vals > 0 ~ palette[1],
          vals == 0 ~ palette[2],
          vals < 0 ~ palette[3],
          TRUE ~ palette[2]
        )

        if (fa_type[1] == "level") {
          fa_vals <- dplyr::case_when(
            vals > 0 ~ "level-up-alt",
            vals < 0 ~ "level-down-alt",
            vals == 0 ~ "equals",
            TRUE ~ "question"
          )
        } else {
          fa_vals <- dplyr::case_when(
            vals > 0 ~ paste0(fa_type[1], "-up"),
            vals == 0 ~ "equals",
            vals < 0 ~ paste0(fa_type[1], "-down")
          )
        }

        if (isFALSE(show_text)) {
          vals <- ""
        }

        mapply(fa_rank_chg, fa_vals, color_vals, font_color, vals,
          SIMPLIFY = FALSE
        )
      }
    )
}