gt_plt_bar_pct still showing plot for NAs

[melindahiggins2000]

I am having an issue with this example (re: issue #86). I actually get the full bar for NAs using gt_plt_bar_pct for the NA in the "b" column. Here is my code as listed from the repex and the plot I am getting.

I have the current version of gt and gtExtras.

Is there another dependency I am missing?

library(gt)
library(gtExtras)

data <- data.frame(
  id = 1:3,
  a = 1:3,
  b = c(1, NA, 3), 
  c = rep(NA, 3)
)

data |> 
  gt() |> 
  cols_label(a = "aaaaa", b = "bbbbb", c = "ccccc") |> 
  gt_plt_bar_pct(a) |> 
  gt_plt_bar_pct(b) |> 
  gt_plt_bar_pct(c)

My sessionInfo() is as follows:

> sessionInfo()
R version 4.3.1 (2023-06-16 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 11 x64 (build 22000)

Matrix products: default

locale:
[1] LC_COLLATE=English_United States.utf8 
[2] LC_CTYPE=English_United States.utf8   
[3] LC_MONETARY=English_United States.utf8
[4] LC_NUMERIC=C                          
[5] LC_TIME=English_United States.utf8    

time zone: America/New_York
tzcode source: internal

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods  
[7] base     

other attached packages:
[1] gtExtras_0.5.0.9002 gt_0.10.0          

loaded via a namespace (and not attached):
 [1] sass_0.4.6         utf8_1.2.3         generics_0.1.3    
 [4] xml2_1.3.3         stringi_1.7.12     extrafontdb_1.0   
 [7] digest_0.6.29      magrittr_2.0.3     grid_4.3.1        
[10] RColorBrewer_1.1-3 fastmap_1.1.1      plyr_1.8.8        
[13] rematch2_2.1.2     ggtext_0.1.2       gridExtra_2.3     
[16] fansi_1.0.4        waffle_1.0.2       scales_1.2.1      
[19] textshaping_0.3.6  cli_3.6.1          rlang_1.1.1       
[22] munsell_0.5.0      withr_2.5.0        tools_4.3.1       
[25] dplyr_1.1.3        colorspace_2.0-3   ggplot2_3.4.3     
[28] DT_0.29            curl_5.0.2         paletteer_1.4.1   
[31] vctrs_0.6.3        R6_2.5.1           lifecycle_1.0.3   
[34] stringr_1.5.0      htmlwidgets_1.6.2  ragg_1.2.5        
[37] fontawesome_0.5.2  pkgconfig_2.0.3    pillar_1.9.0      
[40] gtable_0.3.4       glue_1.6.2         Rcpp_1.0.11       
[43] systemfonts_1.0.4  xfun_0.40          tibble_3.2.1      
[46] tidyselect_1.2.0   rstudioapi_0.15.0  knitr_1.44        
[49] farver_2.1.1       extrafont_0.19     htmltools_0.5.6   
[52] labeling_0.4.3     svglite_2.1.1      Rttf2pt1_1.3.12   
[55] compiler_4.3.1     gridtext_0.1.5 

Thank you for your time and help.

Originally posted by @melindahiggins2000 in https://github.com/jthomasmock/gtExtras/issues/86#issuecomment-1783464370

[jthomasmock]

Howdy, thanks for detailed report!

Pushed some changes to GitHub, try dev version 0.5.0.9003:

library(gtExtras)

data <- data.frame(
  id = 1:3,
  a = 1:3,
  b = c(1, NA, 3), 
  c = rep(NA, 3)
)

data |> 
  gt() |> 
  cols_label(a = "aaaaa", b = "bbbbb", c = "ccccc") |> 
  gt_plt_bar_pct(a) |> 
  gt_plt_bar_pct(b) |> 
  gt_plt_bar_pct(c)

[melindahiggins2000]

Thank you! @jthomasmock for the updates. I was able to get the plots to work as long as I used either gt_reprex_image() or gtsave() at the end of the code chain to save the image and then embed the saved image into my document. However, I wasn't able to get this to work to show the image within the Viewer window in RStudio. But it is working now with some tweaking on my end to save and embed the images! The NAs are now showing up as blank cells. Thank you! @melindahiggins2000

[jthomasmock]

Thanks for confirming!

[rmtrane]

(I'm leaving this here for now in case anyone else has similar issues that I do. If a more permanent solution is of interest, I'm happy to create a pull-request when time permits.)

First of all, I absolutely love this package. So thank you so much for maintaining and updating it!

I'm still seeing an issue with how gt_plot_bar_pct handles missing values, in particular for labels = TRUE. Based on the example above, the following works as expected:

library(gtExtras)

data <- data.frame(
  id = 1:3,
  a = 1:3,
  b = c(1, NA, 3), 
  c = rep(NA, 3)
)

data |>
  gt() |> 
  cols_label(a = "aaaaa", b = "bbbbb", c = "ccccc") |> 
  gt_plt_bar_pct(a) |>
  gt_plt_bar_pct(b) |>
  gt_plt_bar_pct(c) |>
  print()

However, if you add labels = TRUE to either of the columns that contain NA, things break (created using reprex):

library(gtExtras)
#> Loading required package: gt

data <- data.frame(
  id = 1:3,
  a = 1:3,
  b = c(1, NA, 3), 
  c = rep(NA, 3)
)

data |>
  gt() |> 
  cols_label(a = "aaaaa", b = "bbbbb", c = "ccccc") |> 
  gt_plt_bar_pct(a) |>
  gt_plt_bar_pct(b, labels = TRUE) |>
  gt_plt_bar_pct(c) |>
  print()
#> Warning in fn(body[[col]][stub_df$rownum_i %in% loc$rows]): NAs introduced by
#> coercion
#> Error in if (x < (label_cutoff * max_x)) {: missing value where TRUE/FALSE needed

I've managed to put together a fix that works for my purposes, which also allows the user to specify missing_text to use for labels when NA is present. See the end of this post. Changes made:

• return NA in the bar <- lapply(...) call if x is NA and labels = TRUE. This means we never get to the if (x < (label_cutoff * max_x)) check that causes the error above.
• when creating the charts in the chart <- lapply(bar, ...) call, we use gt:::context_missing_text to set the output we want for missing values. If setting the new argument missing_text = "" (default below), cells will be blank. (I prefer missing_text = '---' for consistency with sub_missing())
• finally, before returning the updated gt_object, cells that had missing values in them are centered.

Result:

data |>
  gt() |> 
  cols_label(a = "aaaaa", b = "bbbbb", c = "ccccc") |> 
  new_gt_plt_bar_pct(a, labels = T) |>
  new_gt_plt_bar_pct(b, labels = T) |>
  new_gt_plt_bar_pct(c, labels = T)

data |>
  gt() |> 
  cols_label(a = "aaaaa", b = "bbbbb", c = "ccccc") |> 
  new_gt_plt_bar_pct(a, labels = T, missing_text = '---') |>
  new_gt_plt_bar_pct(b, labels = T, missing_text = '---') |>
  new_gt_plt_bar_pct(c, labels = T, missing_text = '---')

As mentioned above, this has worked for me. However, I have not had the change to rigorously test it, though it does seem to pass the two tests written in tests/testthat/test-gt-bar-html.R.

Finally, the updated function:

new_gt_plt_bar_pct <- function(
    gt_object,
    column,
    height = 16,
    width = 100,
    fill = "purple",
    background = "#e1e1e1",
    scaled = FALSE,
    labels = FALSE,
    label_cutoff = 0.4,
    decimals = 1,
    font_style = "bold",
    font_size = "10px",
    missing_text = ""
) {

  stopifnot(`'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?` = "gt_tbl" %in%
    class(gt_object))

  stopifnot(`label_cutoff must be a number between 0 and 1` = dplyr::between(
    label_cutoff,
    0, 1
  ))

  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()

  col_to_widen <- rlang::new_formula(col_name, px(width))

  bar_plt_html <- function(xy) {
    if (length(na.omit(xy)) == 0) {
      max_x <- 0
    } else {
      max_x <- max(as.double(xy), na.rm = TRUE)
    }
    bar <- lapply(data_in, function(x) {

      if (is.na(x) & labels) 
        return(NA)

      scaled_value <- if (isFALSE(scaled)) {
        x / max_x * 100
      } else {
        x
      }
      if (labels) {
        label_values <- if (scaled) {
          x
        } else {
          x / max_x * 100
        }
        label <- glue::glue("{round(label_values, decimals)}%")
        if (x < (label_cutoff * max_x)) {
          css_styles <- paste0(
            "background:", fill,
            ";", "width:", scaled_value, "%;", "height:",
            height, "px;", "display:flex;", "align-items:center;",
            "justify-content:center;", "color:", gtExtras:::ideal_fgnd_color(background),
            ";", "font-weight:", font_style, ";", "font-size:",
            font_size, ";", "position:relative;"
          )
          span_styles <- paste0(
            "color:", gtExtras:::ideal_fgnd_color(background),
            ";", "position:absolute;", "left:0%;", "margin-left:",
            scaled_value * width / 100, "px;", "font-weight:",
            font_style, ";", "font-size:", font_size,
            ";"
          )
          glue::glue("<div style='{css_styles}'>", "<span style='{span_styles}'>{label}</span></div>")
        } else {
          css_styles <- paste0(
            "background:", fill,
            ";", "width:", scaled_value, "%;", "height:",
            height, "px;", "display:flex;", "align-items:center;",
            "justify-content:flex-start;", "position:relative;"
          )
          span_styles <- paste0(
            "color:", gtExtras:::ideal_fgnd_color(fill),
            ";", "position:absolute;", "left:0px;",
            "margin-left:5px;", "font-weight:", font_style,
            ";", "font-size:", font_size, ";"
          )
          glue::glue("<div style='{css_styles}'>", "<span style='{span_styles}'>{label}</span></div>")
        }
      } else if (!is.na(x)) {
        glue::glue("<div style='background:{fill};width:{scaled_value}%;height:{height}px;'></div>")
      } else if (is.na(x)) {
        "<div style='background:transparent;width:0%;height:{height}px;'></div>"
      }
    })
    chart <- lapply(bar, function(bar) {
      if (is.na(bar) & labels) {
        gt:::context_missing_text(missing_text, "html")
      } else {
        glue::glue("<div style='flex-grow:1;margin-left:8px;background:{background};'>{bar}</div>")
      }
    })
    chart
  }
  quiet <- function(x) {
    sink(tempfile())
    on.exit(sink())
    invisible(force(x))
  }

  quiet(gt_object %>%
    cols_width(col_to_widen) %>%
    text_transform(
      locations = cells_body(
        columns = {{ column }}
      ),
      fn = bar_plt_html
    ) %>%
    cols_align(
      align = "left",
      columns = {{ column }}
    ) %>%
    tab_style(
      style = cell_text(align = "center"),
      locations = cells_body(
        columns = {{ column }},
        rows = is.na(data_in)
      )
    ))
}