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
- Converting the row of a data.table to a vector
- ggplot multi-line log-log labels
- dplyr filter vector by position in pipe %>%
- Removing white spaces in a histogram?
- How to assign and match land cover type from Corine to a dataframe with a set of lon lat coordinates?
- Error in list2env(list, envir = .GlobalEnv) : names(x) must be a character vector of the same length as x
- How to traverse hclust internal node in R
- How are the abbreviations from the par function like mgp, mar, mai, deciphered?
- How to map over function with multiple arguments (and changing data)?
- Join/fill in data based on both row and column values
- How to plot a Log Pearson III distribution using `ggplot2` in R?
- Variable names and Easystats reports
- R plotly(): Adding regression line to a correlation scatter plot
- How to Use ifelse Statements in R
- Creating subgraphs from neighbors with max weight in R using igraph
- merge based on id and dates with missing data
- Automatically adjust the size of the text inside each bar on a bar plot using ggplot2 in R
- gghighlight and facet_wrap one always highlighted
- Mask and Crop functions in Terra R
- How to use a variable in dplyr::filter?
- Changing R Temporary Files
- How do you add a general label to facets in ggplot2?
- change colour of controls in R DT datatable
- Click Button Within Datatable to Display Popup Twice in a row
- How to display values in filter with ascending order
- Select Data From Column in Data Table
- Warning: Error in dataTableOutput: unused argument (height = "auto")
- How to have cells with rounded corners in {gt}?
- Two colours in the same box
- Change color of datatable filter dropdown box