Reputation: 932
Following on from this example can anyone please tell me if it's possible to update the colours of my selectizeInput
based on input from the colourInput
.
## load iris dataset
data(iris)
cats <- levels(iris$Species)
## colourInput ---- create list of shiny inputs for UI
ids <- paste0("col", seq(3))
cols <- c("red", "blue", "yellow")
foo <- function(x) {colourInput(ids[x], cats[x], cols[x])}
my_input <- lapply(seq(ids), foo)
## css styling for selectizeInput menu
CSS <- function(values, colors){
template <- "
.option[data-value=%s], .item[data-value=%s]{
background: %s !important;
color: white !important;
}"
paste0(
apply(cbind(values, colors), 1, function(vc){
sprintf(template, vc[1], vc[1], vc[2])
}),
collapse = "\n"
)
}
css <- CSS(cats, cols[seq(cats)])
## ------ shiny app ------
runApp(shinyApp(
ui = fluidPage(
tabsetPanel(type = "tabs",
tabPanel("Dataset", id = "data",
tags$head(
tags$style(HTML(css))
),
selectizeInput("species", "Labels",
choices = cats,
multiple = TRUE,
selected = cats),
plotOutput("scatter")
),
tabPanel("Colour Menu", id = "colmenu",
my_input)
)
),
server = function(input, output, session) {
## get coords according to selectizeInput
mrkSel <- reactive({
lapply(input$species,
function(z) which(iris$Species == z))
})
## colours selected by user in colourPicker
cols_user <- reactive({
sapply(ids, function(z) input[[z]])
})
## update scatter colours
scattercols <- reactive({
cols_user()[sapply(input$species, function(z)
which(cats == z))]
})
## scatter plot is conditional on species selected
output$scatter <- renderPlot({
plot(iris$Petal.Length, iris$Petal.Width, pch=21)
if (!is.null(input$species)) {
for (i in 1:length(input$species)) {
points(iris$Petal.Length[mrkSel()[[i]]], iris$Petal.Width[mrkSel()[[i]]],
pch = 19, col = scattercols()[i])
}
}
})
}
)
)
Session information
sessionInfo()
R version 4.0.0 (2020-04-24)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS High Sierra 10.13.6
Matrix products: default
BLAS: /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib
locale:
[1] en_GB.UTF-8/en_GB.UTF-8/en_GB.UTF-8/C/en_GB.UTF-8/en_GB.UTF-8
attached base packages:
[1] stats4 parallel stats graphics grDevices utils datasets methods base
other attached packages:
[1] colorspace_1.4-1 shinythemes_1.1.2 DT_0.13 dplyr_0.8.5 pRoloc_1.29.0
[6] BiocParallel_1.22.0 MLInterfaces_1.68.0 cluster_2.1.0 annotate_1.66.0 XML_3.99-0.3
[11] AnnotationDbi_1.50.0 IRanges_2.22.1 MSnbase_2.14.0 ProtGenerics_1.20.0 S4Vectors_0.26.0
[16] mzR_2.22.0 Rcpp_1.0.4.6 Biobase_2.48.0 BiocGenerics_0.34.0 colourpicker_1.0
[21] shinyjs_1.1 shiny_1.4.0.2 ggplot2_3.3.0
Upvotes: 1
Views: 754
Reputation: 84519
In server
:
output$css <- renderUI({
tags$style(HTML(CSS(cats, cols_user())))
})
and in ui
:
tags$head(
uiOutput("css")
)
Upvotes: 4