Is there a way to make the bars' colors conditional to the column?
I would like to make the colors of the bars in the column "Percentile" conditional to the value, meaning that if the value is between 100-90 it has one color, if it's between 90-80 it's another color, and so on...
This is the table in question:
player_percentiles %>%
gt() %>%
gt_plt_bar_pct(Percentile, labels = F, fill = "black") %>%
cols_width(Percentile ~ px(200)) %>%
opt_row_striping() %>%
cols_align(align = "left", columns = Stat) %>%
cols_align(align = "center", columns = Percentile) %>%
opt_stylize(style = 1, color = "gray") %>%
cols_label(perc_value = "") %>%
tab_style(
style = cell_text(color = "darkred"),
locations = cells_body(columns = perc_value)
)
And just in case, a glimpse of the tibble used for the table:
# A tibble: 23 × 4
Stat `Per 90` perc_value Percentile
<fct> <chr> <dbl> <dbl>
1 Passes Completed 64.3 94 94
2 Passes Attempted 75.9 94 94
3 Pass Completion % 84.1% 65 65
4 Total Passing Distance 1177.9 96 96
5 Progressive Passing Distance 345.5 95 95
6 Progressive Distance % 29.4% 61 61
7 Short Passes Completed 27.5 86 86
8 Short Passes Attempted 30.2 86 86
9 Short Pass Completion % 90.8% 73 73
10 Medium Passes Completed 26.9 94 94
# ℹ 13 more rows
And the dput() of the tibble
dput(player_percentiles)
structure(list(Stat = structure(1:23, levels = c("Passes Completed",
"Passes Attempted", "Pass Completion %", "Total Passing Distance",
"Progressive Passing Distance", "Progressive Distance %", "Short Passes Completed",
"Short Passes Attempted", "Short Pass Completion %", "Medium Passes Completed",
"Medium Passes Attempted", "Medium Pass Completion %", "Long Passes Completed",
"Long Passes Attempted", "Long Pass Completion %", "Assists",
"xAG: Exp. Assisted Goals", "xA: Expected Assists", "Key Passes",
"Passes into Final 1/3", "Passes into Penalty Area", "Crosses into Penalty Area",
"Progressive Passes"), class = "factor"), `Per 90` = c("64.3",
"75.9", "84.1%", "1177.9", "345.5", "29.4%", "27.5", "30.2",
"90.8%", "26.9", "30.2", "88.6%", "8.1", "11.3", "70.8%", "0.08",
"0.13", "0.14", "1.32", "7.31", "1.78", "0.17", "8.64"), perc_value = c(94,
94, 65, 96, 95, 61, 86, 86, 73, 94, 96, 68, 98, 95, 80, 46, 69,
73, 66, 95, 92, 63, 96), Percentile = c(94, 94, 65, 96, 95, 61,
86, 86, 73, 94, 96, 68, 98, 95, 80, 46, 69, 73, 66, 95, 92, 63,
96)), row.names = c(NA, -23L), class = c("tbl_df", "tbl", "data.frame"
))
Any help is highly appreciated!
Solution
A preferred solution would be to register a table draw callback, but I could not figure out how to do that with {gt}.
Instead, a similar approach would be to borrow from the answer to this question and start an interval when the table is generated in a reactive value. This interval is executed every 10ms until it finds the table tds whereupon it cancels itself and proceeds to set the bar colors.
Shiny Example Code
library(gt)
library(gtExtras)
library(shiny)
library(shinyjs)
player_percentiles <- structure(
list(
Stat = structure(
1:23,
levels = c(
"Passes Completed",
"Passes Attempted",
"Pass Completion %",
"Total Passing Distance",
"Progressive Passing Distance",
"Progressive Distance %",
"Short Passes Completed",
"Short Passes Attempted",
"Short Pass Completion %",
"Medium Passes Completed",
"Medium Passes Attempted",
"Medium Pass Completion %",
"Long Passes Completed",
"Long Passes Attempted",
"Long Pass Completion %",
"Assists",
"xAG: Exp. Assisted Goals",
"xA: Expected Assists",
"Key Passes",
"Passes into Final 1/3",
"Passes into Penalty Area",
"Crosses into Penalty Area",
"Progressive Passes"
),
class = "factor"
),
`Per 90` = c(
"64.3",
"75.9",
"84.1%",
"1177.9",
"345.5",
"29.4%",
"27.5",
"30.2",
"90.8%",
"26.9",
"30.2",
"88.6%",
"8.1",
"11.3",
"70.8%",
"0.08",
"0.13",
"0.14",
"1.32",
"7.31",
"1.78",
"0.17",
"8.64"
),
perc_value = c(
94,
94,
65,
96,
95,
61,
86,
86,
73,
94,
96,
68,
98,
95,
80,
46,
69,
73,
66,
95,
92,
63,
96
),
Percentile = c(
94,
94,
65,
96,
95,
61,
86,
86,
73,
94,
96,
68,
98,
95,
80,
46,
69,
73,
66,
95,
92,
63,
96
)
),
row.names = c(NA, -23L),
class = c("tbl_df", "tbl", "data.frame")
)
ui <- fluidPage(useShinyjs(), gt_output("gtout"))
server <- function(input, output) {
gtrv <- reactiveVal({
player_percentiles %>%
gt() %>%
gt_plt_bar_pct(Percentile, labels = F, fill = "black") %>%
cols_width(Percentile ~ px(200)) %>%
opt_row_striping() %>%
cols_align(align = "left", columns = Stat) %>%
cols_align(align = "center", columns = Percentile) %>%
opt_stylize(style = 1, color = "gray") %>%
cols_label(perc_value = "") %>%
tab_style(style = cell_text(color = "darkred"),
locations = cells_body(columns = perc_value))
})
output$gtout <- render_gt({ gtrv() })
observeEvent(gtrv, {
runjs('
var watch_for_gt_draw = setInterval(function() {
var tds = $( "td[headers=\'Percentile\'] > div > div" );
if(tds) {
clearInterval(watch_for_gt_draw);
tds.each(function() {
var p = $( this ).width() / $( this ).parent().width();
var b = "#FFFFFF";
if (p <= 0.1) {
b = "#000000";
} else if (p <= 0.2) {
b = "#1C0000";
} else if (p <= 0.3) {
b = "#380000";
} else if (p <= 0.4) {
b = "#550000";
} else if (p <= 0.5) {
b = "#710000";
} else if (p <= 0.6) {
b = "#8D0000";
} else if (p <= 0.7) {
b = "#AA0000";
} else if (p <= 0.8) {
b = "#C60000";
} else if (p <= 0.9) {
b = "#E20000";
} else if (p <= 1.0) {
b = "#FF0000";
}
$( this ).css("background", b);
});
}
}, 10);
'
)
})
}
shinyApp(ui = ui, server = server)
Output
- Retrieving expected data.frame for testthat expectation
- How to use an anonymous function with pipe operator?
- R passing RSelenium driver environment as function argument
- Keep file names merging list with lapply?
- replace strings that contains one another
- Stop parsing out zeros after decimals in ggplot2's annotate
- Plot data.tree coloring and labelling by level
- Extracting the date and time out of a date and time format
- How to reshape a dataframe into wide format with specified column pairs
- Show partial segments removed after limit scales for `geom_pointrange`
- Control ggplot2 legend look without affecting the plot
- Concatenate strings over all rows in a single column of a data frame
- Is there some way to keep variable names from.SD+.SDcols together with non .SD variable names in data.table?
- How to create mutually dependent checkbox columns in a DT table?
- A problem with an stacked, grouped and faceted graph y gg plot
- Installing R on Linux: configure: error: libcurl >= 7.28.0 library and headers are required with support for https
- Create a column conditional on multiple other character and numerical columns
- data.frame to array (2 columns)
- Changing options() in a function environment without changing options() in global environment in R?
- pivot(), group_by() and summarise() with nested data
- Why legend is not showing up in plot layout using patchwork in R?
- in dplyr::mutate, dplyr::starts_with works for .before but not .after?
- Finding optimal cut-off points for dividing a variable into equal groups considering ties in which quantiles do not work
- How to add a legend to hline?
- R Shiny Suppress slider handle for sliderInput until click
- brmultinom brglm2 vifs and dredge dont work
- R, how to get current time miliseconds, without extra information ? (Sys.time(), format("%X"))
- Installing multiple versions of R
- Command to see 'R' path that RStudio is using
- Fast pairwise longest common substring from start