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!
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.
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)