shinyshinyjs
Dynamic border colors
I want to have a set of dynamic textboxes that have border colors that match the color that's described by it. If the text of the textbox is "red", I want a red border. Here is how I am getting that behavior in a reprex that uses much of my original code:
library(shinyjs) # useShinyjs
library(ggplot2)
library(RColorBrewer)
library(shiny)
ui <- fluidPage(
titlePanel("Reprex"),
sidebarLayout(
sidebarPanel(
useShinyjs(),
fluidRow(column(9, fileInput('manifest', 'Choose File',
accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv'))),
column(3, actionButton("load_button", "Load", width = "100%"))),
fluidRow(column(5, selectInput(inputId = "group_palette_input",
label = "Palette Selector",
choices = NA)),
column(5, selectInput(inputId = "column_input",
label = "Column Selector",
choices = NA))),
uiOutput("group_colors"),
width=4),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Plot")
)
)
)
)
server <- function(input, output, session) {
# Load the demo data on initialization and press the load button to update the file
data <- reactiveValues()
observeEvent(eventExpr = input$load_button, ignoreInit = FALSE, ignoreNULL = FALSE, {
manifestName = ifelse(is.null(input$manifest$datapath), "file.txt", input$manifest$datapath)
man = read.table(manifestName, sep = "\t", header = T, check.names=F, strip.white = T)
data$manifest <- man[man$include, ]
})
# Update column selector
observeEvent(data$manifest, {
freezeReactiveValue(input, "column_input")
updateSelectInput(inputId = "column_input",
choices = names(data$manifest),
selected = "group") # All files should have a group column
})
# Update palette selector
observeEvent(data$manifest, {
freezeReactiveValue(input, "group_palette_input")
updateSelectInput(inputId = "group_palette_input",
choices = rownames(brewer.pal.info),
selected = "Dark2")
})
groupIncludeManualPaletteInput <- eventReactive(input$column_input, {
fullColors = brewer.pal(length(groups()), input$group_palette_input)
lapply(1:length(groups()),
function(groupIndex) {
colorId = paste0(groups()[groupIndex], "_color")
fluidRow(column(5, textInput(inputId = colorId,
label = NULL,
value = fullColors[groupIndex])),
column(1, checkboxInput(inputId = as.character(groups()[groupIndex]), # Numeric column causes issues, need to wrap with as.character
label = groups()[groupIndex],
value = TRUE),
style='padding:0px;')) # Removing padding puts the two columns closer together
}) # End lapply
})
groups <- reactive(sort(unique(data$manifest[[input$column_input]])))
# Update groupIncludeManualPaletteInput
observeEvent(input$group_palette_input, {
groupColorIds = paste0(groups(), "_color")
fullColors = brewer.pal(length(groups()), input$group_palette_input)
for (groupColorIndex in seq_along(groupColorIds)) {
updateTextInput(session, groupColorIds[groupColorIndex], value = fullColors[groupColorIndex])
}
})
# Vector of booleans to mask the included groups
includedGroups <- reactive(unlist(map(as.character(groups()), ~input[[.x]]))) # unlist() allows includedGroups to be used as an index variable
# Vector of characters of group names that are included
currentGroups <- reactive(groups()[includedGroups()])
# Vector of characters of color names that are included
currentColors <- reactive(unlist(map(groups(), ~input[[paste0(.x, "_color")]])[includedGroups()]))
output$group_colors <- renderUI(groupIncludeManualPaletteInput())
# Make the borders of these textboxes match the color they describe
# This is run twice when it works, but only once when it doesn't as a simple observe
# As an observeEvent on groups(), only activates once and temporarily shows the border color; Adding in the req(input[[colorId]]) doesn't help
# Same thing when the observation is on the groupIncludeManualPaletteInput()
# Doubling the js code doesn't work
# In the html, I can see that the border color is not being set
# observing currentColors() is a dud too
# Adding an if statement in the javascript doesn't change behavior.
observe({
lapply(seq_along(groups()),
function(groupIndex) {
colorId = paste0(groups()[groupIndex], "_color")
cat("Made it into Loop,", input[[colorId]], '\n')
cat(colorId, ': ', input[[colorId]], '\n\n')
runjs(paste0("document.getElementById('", colorId, "').style.borderColor ='", input[[colorId]] ,"'"))
runjs(paste0("document.getElementById('", colorId, "').style.borderWidth = 'thick'"))
})
})
}
shinyApp(ui, server)
Here's what file.txt can look like, tab delimited:
group disease celltype include
1 HC B TRUE
2 SLE M TRUE
2 HC C TRUE
Loading up, it all looks correct:
And then when I change what column I'm looking at, it does what I expect it to do, each textbox has a border with color described:
But if we go back to a column already chosen:
Then the border color is gone!
Looking at the react_log, I think it has something to do with re-initializing input$1_color and input$2_color in the groupIncludeManualPaletteInput() eventReactive. I also notice that when succesful, the runjs() section is run twice, but when unsuccessful, it only runs once.
As additional attempts to solve this issue, I thought that maybe the data types were the issue. I tried various combinations of using groupIncludeManualPaletteInput as a reactiveValue, but none seemed to mesh with renderUI in the first place.
Solution
You are using the same input ID in colorId when you select the same group the second time. However, you need unique input IDs in shiny. I have added a counter to change it. Try this.
library(shinyjs) # useShinyjs
library(ggplot2)
library(RColorBrewer)
library(shiny)
ui <- fluidPage(
titlePanel("Reprex"),
sidebarLayout(
sidebarPanel(
useShinyjs(),
fluidRow(column(9, fileInput('manifest', 'Choose File',
accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv'))),
column(3, actionButton("load_button", "Load", width = "100%"))),
fluidRow(column(5, selectInput(inputId = "group_palette_input",
label = "Palette Selector",
choices = NULL)),
column(5, selectInput(inputId = "column_input",
label = "Column Selector",
choices = rownames(brewer.pal.info)))),
uiOutput("group_colors"),
width=4),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Plot")
)
)
)
)
server <- function(input, output, session) {
cntr <- reactiveValues(val=0)
# Load the demo data on initialization and press the load button to update the file
# data <- reactiveValues()
# observeEvent(eventExpr = input$load_button, ignoreInit = FALSE, ignoreNULL = FALSE, {
# manifestName = ifelse(is.null(input$manifest$datapath), "file.csv", input$manifest$datapath)
# man = read.table(manifestName, sep = "\t", header = T, check.names=F, strip.white = T)
# data$manifest <- man[man$include, ]
# })
datamanifest <- reactive({
req(input$manifest)
read.csv(input$manifest$datapath, header = TRUE)
})
# Update column selector
observeEvent(datamanifest(), {
freezeReactiveValue(input, "column_input")
updateSelectInput(inputId = "column_input",
choices = names(datamanifest()),
selected = "group") # All files should have a group column
})
# Update palette selector
observeEvent(datamanifest(), {
freezeReactiveValue(input, "group_palette_input")
updateSelectInput(inputId = "group_palette_input",
choices = rownames(brewer.pal.info),
selected = "Dark2")
})
groupIncludeManualPaletteInput <- eventReactive(groups(), {
req(input$group_palette_input)
cntr$val <- cntr$val + 1
fullColors = brewer.pal(length(groups()), input$group_palette_input)
lapply(1:length(groups()),
function(groupIndex) {
colorId = paste0(groups()[groupIndex], "_color", cntr$val)
fluidRow(column(5, textInput(inputId = colorId,
label = NULL,
value = fullColors[groupIndex])),
column(1, checkboxInput(inputId = as.character(groups()[groupIndex]), # Numeric column causes issues, need to wrap with as.character
label = groups()[groupIndex],
value = TRUE),
style='padding:0px;')) # Removing padding puts the two columns closer together
}) # End lapply
})
groups <- eventReactive(input$column_input, {sort(unique(datamanifest()[[input$column_input]]))})
# Update groupIncludeManualPaletteInput
observeEvent(input$group_palette_input, {
groupColorIds = paste0(groups(), "_color",cntr$val)
fullColors = brewer.pal(length(groups()), input$group_palette_input)
for (groupColorIndex in seq_along(groupColorIds)) {
updateTextInput(session, groupColorIds[groupColorIndex], value = fullColors[groupColorIndex])
}
})
# Vector of booleans to mask the included groups
includedGroups <- eventReactive(groups(), {unlist(map(as.character(groups()), ~input[[.x]]))}) # unlist() allows includedGroups to be used as an index variable
# Vector of characters of group names that are included
currentGroups <- eventReactive(includedGroups(), {groups()[includedGroups()]})
# Vector of characters of color names that are included
currentColors <- reactive(unlist(map(groups(), ~input[[paste0(.x, "_color")]])[includedGroups()]))
output$group_colors <- renderUI(groupIncludeManualPaletteInput())
# Make the borders of these textboxes match the color they describe
# This is run twice when it works, but only once when it doesn't as a simple observe
# As an observeEvent on groups(), only activates once and temporarily shows the border color; Adding in the req(input[[colorId]]) doesn't help
# Same thing when the observation is on the groupIncludeManualPaletteInput()
# Doubling the js code doesn't work
# In the html, I can see that the border color is not being set
# observing currentColors() is a dud too
# Adding an if statement in the javascript doesn't change behavior.
observe({
lapply(seq_along(groups()),
function(groupIndex) {
colorId = paste0(groups()[groupIndex], "_color",cntr$val)
cat("Made it into Loop,", input[[colorId]], '\n')
cat(colorId, ': ', input[[colorId]], '\n\n')
runjs(paste0("document.getElementById('", colorId, "').style.borderColor ='", input[[colorId]] ,"'"))
runjs(paste0("document.getElementById('", colorId, "').style.borderWidth = 'thick'"))
})
})
}
shinyApp(ui, server)
- Math.Sin() gives incorrect value
- How to run my python script when the sunOS is start booting
- Express-session: not resetting cookie expiration on each request
- Getting a stack overflow exception when normalizing a vector
- Edit default summary function in R gives error for multiple variables
- What was a For loop? Why isn't it needed in R?
- How to use download button in shiny and save results in various formats (csv, texte, pdf, spss...)?
- Why are there two assignment operators, `<-` and `->` in R?
- lm()$assign: what is it?
- How to get the value of list(...) in R and S functions
- Design matrix for MLM from library(lme4) with fixed and random effects
- how to generate elements not included in my sample
- Create a matrix with gradually changing values without a for loop
- Emacs ESS and S-plus ( S+ ) 8.1 compatability
- How to lag date-index in a time-series in R?
- Nonlinear regression in R / S
- Calling R from S-Plus?