Cell colouring in Shiny Rendertable when using shiny modules - shiny

Question

I have been using the guidance here to colour the cells of my table in based on the number in the cell. However the whole table is currently displaying in the colour selected and not just the one cell.
This is what is currently outputting
I believe the issue with this is that my shiny app is built in modules.
This is the code in my DriversTable module:
# UI ----
topDriversTableUI <- function(id) {
tagList(
div(
style = "text-align: left; font-size: 120%",
h4(strong("Social risk")),
p("This section of the tool looks exclusively at the reasons why a neighbourhood is socially vulnerable.")
),
textOutput(NS(id, "lsoas_clicked_name")),
br(),
# dataTableOutput(NS(id, "drivers_table_domains")),
fluidRow(box(
tableOutput(NS(id, "top_drivers_table_domains")),
title = "Overarching reasons why the neighbourhood is socially vulnerable to flooding",
solidHeader = TRUE,
width = 11,
status = "primary",
collapsible = TRUE
)),
fluidRow(box(
tableOutput(NS(id, "top_drivers_table_variables")),
title = "Underlying reasons why the neighbourhood is socially vulnerable to flooding",
solidHeader = TRUE,
width = 11,
status = "primary",
collapsible = TRUE)
),
tags$head(tags$style("#top_drivers_table_variables td{
position:relative;
};
"))
)
}
# Server ----
topDriversTableServer <- function(id,
vuln_drivers,
lsoas_clicked,
selected_ltlas) {
# Checks to ensure the inputs are reactive (data not reactive)
stopifnot(is.reactive(lsoas_clicked))
moduleServer(id, function(input, output, session) {
observeEvent(
lsoas_clicked(),
{
top_drivers_data <- reactive({
vuln_drivers |>
dplyr::filter(lsoa11_name %in% lsoas_clicked()) |>
# explain the concept of quantiles in plain language
# variable_quantiles = 1 means in top 10% worst scoring neighborhoods nationally
mutate(quantiles_eng = case_when(
quantiles_eng <= 5 ~ '<div style="width: 100%; height: 100%; z-index: 0; background-color: red; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>',
quantiles_eng > 5 ~ '<div style="width: 100%; height: 100%; z-index: 0; background-color: green; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>')
) |>
select(
`Rank` = normalised_rank,
`Driver of flooding vulnerability` = domain_variable_name,
`Domain or variable` = domain_variable,
`Comparison of value nationally` = quantiles_eng
# `Values` = values
) |>
arrange(`Domain or variable`, Rank) |>
mutate(Rank = if_else(is.na(Rank), "-", as.character(Rank))) |>
mutate(`Comparison of value nationally` = if_else(is.na(`Comparison of value nationally`), "No data available", `Comparison of value nationally`))
})
output$top_drivers_table_domains <- renderTable({
top_drivers_data() |>
filter(`Domain or variable` == "domain") |>
select(-`Domain or variable`)
}, sanitize.text.function = function(x) x)
output$top_drivers_table_variables <- renderTable({
top_drivers_data() |>
filter(`Domain or variable` == "variable") |>
select(-`Domain or variable`)
}, sanitize.text.function = function(x) x)
output$lsoas_clicked_name <- renderText({
# Message to user if no LSOAs selected ----
# Blank since error message captured in 'top_drivers_table' object
validate(need(
length(lsoas_clicked()) > 0,
""
))
paste("Neighbourhood: ", lsoas_clicked())
})
},
ignoreNULL = FALSE # means event triggered when the input (i.e. lsoa_clicked()) is NULL. Needed to trigger the validate message
)
observeEvent(
selected_ltlas(),
{
lsoas_clicked(NULL)
}
)
})
}
I believe the issue is coming from this part of the code:
tags$head(tags$style("#top_drivers_table_variables td{
position:relative;
};
"))
I believe it is this part of the code because if I run this test code and commented out that part then a similar issue occurs:
test <- data.frame(test1 = c(1:3), test2 = c(4:6))
test[test$test2 == 5, "test2"] <- '<div style="width: 100%; height: 100%; z-index: 0; background-color: green; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>'
test[test$test2 == 4, "test2"] <- '<div style="width: 100%; height: 100%; z-index: 0; background-color: red; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>'
library(shiny)
ui <- shinyUI(fluidPage(
box(tableOutput("tt"), title = "title"),
# tags$head(tags$style("#tt td{
# position:relative;
# };
#
# "))
)
)
server <- shinyServer(function(input, output) {
output$tt <- renderTable({
test
}, sanitize.text.function = function(x) x)
})
shinyApp(ui = ui, server = server)

Answer 1

When using module, you must use ns() around your objects IDs in your module. This ns() is adding the module id to the object id.
Which mean your object #top_drivers_table_variables actually is #moduleid-top_drivers_table_variables in your HTML code when it is inside a module.
So to add some CSS to it, you need to add the module id to it.
I think doing something like this should solve the problem
tags$head(tags$style(paste0("#",NS(id, "top_drivers_table_variables"), "td{
position:relative;
};
")))
To make some tests on what is really the id of an object when using modules, and especially nested modules, you can launch your app, and on you browser do a right click on the object and click "Inspect'. Then the HTML and CSS code of the app will appear on a panel on your browser. You can then verify what is really the id of you object.