动态边框颜色
Dynamic border colors
我想要一组动态文本框，其边框颜色与其所描述的颜色相匹配。如果文本框的文本是“红色”，我想要一个红色边框。以下是我如何在使用大部分原始代码的 reprex 中获得该行为：
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)
下面是 file.txt 的样子，制表符分隔：
group disease celltype include
1 HC B TRUE
2 SLE M TRUE
2 HC C TRUE
加载中，一切正常：
然后当我更改我正在查看的列时，它会按照我的预期执行，每个文本框都有一个带有描述颜色的边框：
但是如果我们返回到已选择的列：
然后边框颜色就没有了！
看react_log，我觉得跟groupIncludeManualPaletteInput()eventReactive里的re-initializinginput_color和input_color有关系.我还注意到，当成功时，runjs() 部分是 运行 两次，但如果不成功，它只会 运行 一次。
作为解决此问题的额外尝试，我认为可能数据类型是问题所在。我尝试了将 groupIncludeManualPaletteInput 用作 reactiveValue 的各种组合，但 none 似乎首先与 renderUI 相吻合。
当您第二次 select 同一组时，您在 colorId 中使用了相同的输入 ID。但是，您需要独特的输入 IDs in shiny。我添加了一个计数器来改变它。试试这个。
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)
根据@YBS 对我的评论的回复，我采用了预先计算可以使用输入文件创建的所有字段并使用 conditionalPanel() 有选择地显示它们。
这在理论上存在无法加载另一个文件的缺点，但实际上我没有看到它。但我可以使用@YBS 的答案（一个计数器）来解决这个问题，如果它不再是理论上的。
我还更改了使字段成为仅依赖于 data$manifest 的常规反应的部分。我还更改了颜色的更新函数，使它们适合在 observe 而不是 observeEvent 中。没有其他必要的更改，但是当我 over-engineered 我认为是一个大更新时遇到了障碍。
我想要一组动态文本框，其边框颜色与其所描述的颜色相匹配。如果文本框的文本是“红色”，我想要一个红色边框。以下是我如何在使用大部分原始代码的 reprex 中获得该行为：
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)
下面是 file.txt 的样子，制表符分隔：
group disease celltype include
1 HC B TRUE
2 SLE M TRUE
2 HC C TRUE
加载中，一切正常：
然后当我更改我正在查看的列时，它会按照我的预期执行，每个文本框都有一个带有描述颜色的边框：
但是如果我们返回到已选择的列：
然后边框颜色就没有了！
看react_log，我觉得跟groupIncludeManualPaletteInput()eventReactive里的re-initializinginput_color和input_color有关系.我还注意到，当成功时，runjs() 部分是 运行 两次，但如果不成功，它只会 运行 一次。
作为解决此问题的额外尝试，我认为可能数据类型是问题所在。我尝试了将 groupIncludeManualPaletteInput 用作 reactiveValue 的各种组合，但 none 似乎首先与 renderUI 相吻合。
当您第二次 select 同一组时，您在 colorId 中使用了相同的输入 ID。但是，您需要独特的输入 IDs in shiny。我添加了一个计数器来改变它。试试这个。
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)
根据@YBS 对我的评论的回复，我采用了预先计算可以使用输入文件创建的所有字段并使用 conditionalPanel() 有选择地显示它们。
这在理论上存在无法加载另一个文件的缺点，但实际上我没有看到它。但我可以使用@YBS 的答案（一个计数器）来解决这个问题，如果它不再是理论上的。
我还更改了使字段成为仅依赖于 data$manifest 的常规反应的部分。我还更改了颜色的更新函数，使它们适合在 observe 而不是 observeEvent 中。没有其他必要的更改，但是当我 over-engineered 我认为是一个大更新时遇到了障碍。