Would this chart be of interest back in gtExtras? What changes/additions/options might be required? (e.g. One thing I'm currently looking at here is dropping the use of css float in favour of flexbox or similar) Would this be better as adding colo(u)r options to gt_plt_bar (although we prefer the pure HTML approach for performance reasons)
Initial Prototype
library(tidyverse)
library(gt)
library(gtExtras)
#' Add HTML-based bar plots into rows of a `gt` table
#' @description
#' The `gt_plt_bar_plus_minus` function takes an existing `gt_tbl` object and
#' adds horizontal negative/positive barplots via native HTML.
#'
#' @param gt_object An existing gt table object of class `gt_tbl`
#' @param column The column wherein the bar plot should replace existing data.
#' @param height A number representing the vertical height of the plot in pixels. Defaults to 16 px.
#' @param width A number representing the horizontal width of the plot in pixels. Defaults to 100 px.
#' @param maxPlusMinus The maximum +/- percentage to show in the bar chart. Default is zero (auto-detect max/min)
#' @param positiveFill A character representing the fill for the positive bar, defaults to green. Accepts a named color (eg 'purple') or a hex color.
#' @param negativeFill A character representing the fill for the negative bar, defaults to red. Accepts a named color (eg 'purple') or a hex color.
#' @param background A character representing the background filling out the 100% mark of the bar, defaults to light grey. Accepts a named color (eg 'white') or a hex color.
#' @param labels `TRUE`/`FALSE` logical representing if labels should be plotted. Defaults to `FALSE`, meaning that no value labels will be plotted.
#' @param decimals A number representing how many decimal places to be used in label rounding. Defaults to 1.
#' @param labelsPercentSuffix `TRUE`/`FALSE` logical representing if labels should be shown with a % suffix. Defaults to `FALSE`.
#' @param font_style A character representing the font style of the labels. Accepts one of 'bold' (default), 'italic', or 'normal'.
#' @param font_size A character representing the font size of the labels. Defaults to '10px'.
#' @return An object of class `gt_tbl`.
#' @export
#' @section Examples:
#' ```r
#' library(gt)
#'
#' base_tab <- dplyr::tibble(x = seq(-30, 89, length.out = 12)) %>%
#' dplyr::mutate(
#' `Just x` = x,
#' `x scaled to 100%` = x / max(x) * 100,
#' `x scaled to 50%` = x / max(x) * 50
#' ) %>%
#' gt()
#'
#' base_tab %>%
#' gt_plt_bar_plus_minus(
#' column = `Just x`,
#' positiveFill = "yellow",
#' negativeFill = "pink",
#' background = "black",
#' labels = TRUE,
#' labelsPercentSuffix = TRUE
#' ) %>%
#' gt_plt_bar_plus_minus(
#' column = `x scaled to 100%`,
#' labels = TRUE,
#' labelsPercentSuffix = TRUE
#' ) %>%
#' gt_plt_bar_plus_minus(
#' column = `x scaled to 50%`,
#' maxPlusMinus = 100,
#' labels = TRUE,
#' labelsPercentSuffix = TRUE,
#' width = 200,
#' height = 40
#' )
#' ```
#' @section Figures:
#' \if{html}{\figure{gt_bar_plot.png}{options: width=100\%}}
#'
#' @family Plotting
#' @section Function ID:
#' 3-5
gt_plt_bar_plus_minus <- function(
gt_object,
column,
height = 16,
width = 100,
maxPlusMinus = 0,
positiveFill = "green",
negativeFill = "red",
background = "#e1e1e1",
labels = FALSE,
decimals = 1,
labelsPercentSuffix = FALSE,
font_style = "bold",
font_size = "10px") {
stopifnot(`'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?` = "gt_tbl" %in%
class(gt_object))
# ensure font_style is one of the accepted values
stopifnot(
'`font_style` argument must be "bold", "normal", or "italic"' =
font_style %in% c("bold", "normal", "italic")
)
all_cols <- gt_index(gt_object, column = {{ column }}, as_vector = FALSE)
data_in <- all_cols %>% select({{ column }}) %>% pull()
col_name <- all_cols %>%
select({{ column }}) %>%
names()
# create a formula for cols_width
col_to_widen <- rlang::new_formula(col_name, px(width))
bar_plt_html <- function(xy) {
if (length(na.omit(xy)) == 0) {
max_x <- 0
min_x <- 0
} else {
min_x <- min(as.double(xy), na.rm = TRUE)
max_x <- max(as.double(xy), na.rm = TRUE)
}
if (min_x > 0) min_x <- 0
if (max_x < 0) max_x <- 0
scale_factor <- if (maxPlusMinus > 0) {
maxPlusMinus
} else {
max(-min_x, max_x)
}
bar <- lapply(data_in, function(x) {
scaled_value <- 100 * x / scale_factor
if (scaled_value > 100) {
scaled_value = 100
} else if (scaled_value < -100) {
scaled_value = -100
}
if(!is.na(x)) {
chart <-
if (x < 0) {
glue::glue(
"<div style='float:left;display:block;background:{background};width:{(100+scaled_value)/2}%;height:{height}px;' ></div>
<div style='float:left;display:block;background:{negativeFill};width:{-scaled_value/2}%;height:{height}px;' ></div>
<div style='float:left;display:block;background:{background};width:50%;height:{height}px;' ></div>
"
)
} else {
glue::glue(
"<div style='float:left;display:block;background:{background};width:50%;height:{height}px;' ></div>
<div style='float:left;display:block;background:{positiveFill};width:{scaled_value/2}%;height:{height}px;' ></div>
<div style='float:left;display:block;background:{background};width:{(100 - scaled_value)/2}%;height:{height}px;' ></div>
"
)
}
if (labels){
x_label <- round(x, decimals) |> as.character()
x_label <- ifelse(labelsPercentSuffix, paste0(x_label, "%"), x_label)
left_or_right <- if (x < 0) "left" else "right";
chart <-
glue::glue("{chart}<div style='position:absolute;{left_or_right}:55%;color:{gtExtras:::ideal_fgnd_color(background)};font-weight:{font_style};font-size:{font_size};'>{x_label}</div>")
}
chart
} else if(is.na(x)){
"<div style='background:transparent;width:0%;height:{height}px;'></div>" # no labels added
}
})
chart <- lapply(bar, function(bar) {
glue::glue("<div style='position:relative;margin-left:8px;background:{background};'>{bar}</div>")
})
chart
}
# silence NAs messing with rownum_i
quiet <- function(x) {
sink(tempfile())
on.exit(sink())
invisible(force(x))
}
gt_object %>%
cols_width(col_to_widen) %>%
text_transform(
locations = cells_body(columns = {{ column }}),
fn = quiet(bar_plt_html)
) %>%
cols_align(align = "left", columns = {{ column }})
}
# demo 1
mtcars |>
dplyr::mutate(mpg_plus_minus = (mpg-20.0)/max(mpg) * 100) |>
dplyr::mutate(mpg_pct_max = round(mpg/max(mpg) * 100, digits = 2),
mpg_scaled = mpg/max(mpg) * 200) |>
dplyr::mutate(mpg_unscaled = mpg) |>
select(mpg, mpg_plus_minus, mpg_scaled, mpg_unscaled) |>
gt::gt() |>
gt_plt_bar_plus_minus(column = mpg_unscaled, labels=TRUE, labelsPercentSuffix = TRUE) %>%
gt_plt_bar_plus_minus(column = mpg_scaled, maxPlusMinus = 500, labels=TRUE, labelsPercentSuffix = FALSE) %>%
gt_plt_bar_plus_minus(column = mpg_plus_minus, labels = TRUE,
background = "lightblue", font_style = "normal")
# demo 2
base_tab <- dplyr::tibble(x = seq(-30, 89, length.out = 12)) |>
dplyr::mutate(
`Just x` = x,
`x scaled to 100%` = x / max(x) * 100,
`x scaled to 50%` = x / max(x) * 50
) |>
#sample_n(nrow(.)) |>
gt()
base_tab %>%
gt_plt_bar_plus_minus(
column = `Just x`,
positiveFill = "yellow",
negativeFill = "pink",
background = "black",
labels = TRUE,
labelsPercentSuffix = TRUE
) %>%
gt_plt_bar_plus_minus(
column = `x scaled to 100%`,
labels = TRUE,
labelsPercentSuffix = TRUE
) %>%
gt_plt_bar_plus_minus(
column = `x scaled to 50%`,
maxPlusMinus = 100,
width = 200,
height = 40,
font_size = "20px",
labels = TRUE,
labelsPercentSuffix = TRUE
)
Prework
Proposal
We've done some work to produce individual cells with +/- bars like:
This implementation shares quite a lot with https://github.com/jthomasmock/gtExtras/blob/HEAD/R/gt-bar-html.R - although it's dropped the
scaledparameter (because we didn't want this to always be about percentages).Would this chart be of interest back in gtExtras? What changes/additions/options might be required? (e.g. One thing I'm currently looking at here is dropping the use of css
floatin favour of flexbox or similar) Would this be better as adding colo(u)r options togt_plt_bar(although we prefer the pure HTML approach for performance reasons)Initial Prototype