drop-down checkbox input in shiny - r

Is it possible to have a dropdown list in Shiny where you can select multiple values? I know selectInput has the option to set multiple = T but I don't like it that all selected option are visible in the screen, especially since I have over 40. The same holds for checkboxGroupInput(), which I like more but still all selected values are shown. Isn't it just possible to get a drop-down like the one I copied from Excel below, rather than the examples of Shinys selectInput and checkboxGroupInput() thereafter?

EDIT : This function (and others) is available in package shinyWidgets
Hi I wrote this dropdownButton function once, it create a bootstrap dropdown button (doc here), the results looks like :
Here is the code :
# func --------------------------------------------------------------------
dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {
status <- match.arg(status)
# dropdown button content
html_ul <- list(
class = "dropdown-menu",
style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
)
# dropdown button apparence
html_button <- list(
class = paste0("btn btn-", status," dropdown-toggle"),
type = "button",
`data-toggle` = "dropdown"
)
html_button <- c(html_button, list(label))
html_button <- c(html_button, list(tags$span(class = "caret")))
# final result
tags$div(
class = "dropdown",
do.call(tags$button, html_button),
do.call(tags$ul, html_ul),
tags$script(
"$('.dropdown-menu').click(function(e) {
e.stopPropagation();
});")
)
}
And an example :
# app ---------------------------------------------------------------------
library("shiny")
ui <- fluidPage(
tags$h1("Example dropdown button"),
br(),
fluidRow(
column(
width = 6,
dropdownButton(
label = "Check some boxes", status = "default", width = 80,
checkboxGroupInput(inputId = "check1", label = "Choose", choices = paste(1:26, ") Choice ", LETTERS))
),
verbatimTextOutput(outputId = "res1")
),
column(
width = 6,
dropdownButton(
label = "Check some boxes", status = "default", width = 80,
actionButton(inputId = "a2z", label = "Sort A to Z", icon = icon("sort-alpha-asc")),
actionButton(inputId = "z2a", label = "Sort Z to A", icon = icon("sort-alpha-desc")),
br(),
actionButton(inputId = "all", label = "(Un)select all"),
checkboxGroupInput(inputId = "check2", label = "Choose", choices = paste(1:26, ") Choice ", LETTERS))
),
verbatimTextOutput(outputId = "res2")
)
)
)
server <- function(input, output, session) {
output$res1 <- renderPrint({
input$check1
})
# Sorting asc
observeEvent(input$a2z, {
updateCheckboxGroupInput(
session = session, inputId = "check2", choices = paste(1:26, ") Choice ", LETTERS), selected = input$check2
)
})
# Sorting desc
observeEvent(input$z2a, {
updateCheckboxGroupInput(
session = session, inputId = "check2", choices = paste(26:1, ") Choice ", rev(LETTERS)), selected = input$check2
)
})
output$res2 <- renderPrint({
input$check2
})
# Select all / Unselect all
observeEvent(input$all, {
if (is.null(input$check2)) {
updateCheckboxGroupInput(
session = session, inputId = "check2", selected = paste(1:26, ") Choice ", LETTERS)
)
} else {
updateCheckboxGroupInput(
session = session, inputId = "check2", selected = ""
)
}
})
}
shinyApp(ui = ui, server = server)
In bonus I put the ascending/descending sorting thingy in the second dropdown buttons.
EDIT Mar 22 '16
To split yours checkboxes into multiple columns you can do the split yourself with fluidRow and columns and multiples checkboxes, you just have to bind the values server-side.
To implement scrolling put your checkboxes into a div with style='overflow-y: scroll; height: 200px;'.
Look at this example :
library("shiny")
ui <- fluidPage(
tags$h1("Example dropdown button"),
br(),
fluidRow(
column(
width = 6,
dropdownButton(
label = "Check some boxes", status = "default", width = 450,
tags$label("Choose :"),
fluidRow(
column(
width = 4,
checkboxGroupInput(inputId = "check1a", label = NULL, choices = paste0(1:10, ") ", LETTERS[1:10]))
),
column(
width = 4,
checkboxGroupInput(inputId = "check1b", label = NULL, choices = paste0(11:20, ") ", LETTERS[11:20]))
),
column(
width = 4,
checkboxGroupInput(inputId = "check1c", label = NULL, choices = paste0(21:26, ") ", LETTERS[21:26]))
)
)
),
verbatimTextOutput(outputId = "res1")
),
column(
width = 6,
tags$style(".container { border:2px solid steelblue; width: 100%; height: 200px; overflow-y: scroll; }"),
dropdownButton(
label = "Check some boxes", status = "default", width = 120,
tags$div(
class = "container",
checkboxGroupInput(inputId = "check2", label = "Choose", choices = paste0(1:26, ") ", LETTERS))
)
),
verbatimTextOutput(outputId = "res2")
)
)
)
server <- function(input, output, session) {
valuesCheck1 <- reactiveValues(x = NULL)
observeEvent(input$check1a, valuesCheck1$x <- unique(c(valuesCheck1$x, input$check1a)))
observeEvent(input$check1b, valuesCheck1$x <- unique(c(valuesCheck1$x, input$check1b)))
observeEvent(input$check1c, valuesCheck1$x <- unique(c(valuesCheck1$x, input$check1c)))
output$res1 <- renderPrint({
valuesCheck1$x
})
output$res2 <- renderPrint({
input$check2
})
}
shinyApp(ui = ui, server = server)

Firstly, lot of thanks for this dropdownButton function. It's very useful!
Secondly, i tried to use it into shiny dashboard sidebarmenu, but the default characters' style is "color:white" (because of dark background). That takes me a couple of hour to understand that can be changed inside your function, more precisly in html_ul stuff. Here's the line of interest, with color:black :
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px; color:black")
Quite simple... But when you don't know it (R is the only language I know)... So, I hope this will help any other css-ignorant (and/or HTML?) like me!
Cheers!

There are a couple questions in the comments related the the dropdownButton (worked great for me, thank you) about how to create a scrolling bar on the dropdown. Sorry I don't have reputation to reply in the comments directly.
Try tweaking the relevant ID in your styles.css, for whatever object you put in the dropdownButton. So for the example, the checkboxGroupInput ID needs to have:
#check1
{
height: 200px;
overflow: auto;
}
Edit:
To call the styles.css in the ui.R:
navbarPage("Superzip", id="nav",
tabPanel("Interactive map",
div(class="outer",
tags$head(
# Include our custom CSS
includeCSS("styles.css")
),
leafletOutput("map", width="100%", height="100%"),
...
And the styles.css, with the auto overflow for the inputID ttype and chain:
input[type="number"] {
max-width: 80%;
}
div.outer {
position: fixed;
top: 41px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
/* Customize fonts */
body, label, input, button, select {
font-family: 'Helvetica Neue', Helvetica;
font-weight: 200;
}
h1, h2, h3, h4 { font-weight: 400; }
#controls {
/* Appearance */
background-color: white;
padding: 0 20px 20px 20px;
cursor: move;
/* Fade out while not hovering */
opacity: 0.65;
zoom: 0.9;
transition: opacity 500ms 1s;
}
#controls:hover {
/* Fade in while hovering */
opacity: 0.95;
transition-delay: 0;
}
#data_inputs {
/* Appearance */
background-color: white;
padding: 0 20px 20px 20px;
cursor: move;
/* Fade out while not hovering */
opacity: 0.65;
zoom: 0.9;
transition: opacity 500ms 1s;
}
#data_inputs:hover {
/* Fade in while hovering */
opacity: 0.95;
transition-delay: 0;
}
/* Position and style citation */
#cite {
position: absolute;
bottom: 10px;
left: 10px;
font-size: 12px;
}
#cite {
position: absolute;
bottom: 10px;
left: 10px;
font-size: 12px;
}
#ttype
{
height: 200px;
overflow: auto;
}
#chain
{
height: 200px;
overflow: auto;
}
."form-group shiny-input-checkboxgroup shiny-input-container"
{
height: 50px;
overflow: auto;
}
/* If not using map tiles, show a white background */
.leaflet-container {
background-color: white !important;
}

For future visitors that might need similar solutions, a good option could be the selectizeInput .
Pros:
You can set the list length
Is a dropdown function
User can select one or more choices by searching the list
or by typing in the box.
For more information check the above link. Hope this will help.
Cheers!

Related

Create JSON from a shiny app by drag&drop elements with various number of parameters

I want to create a bucket list in a shiny app from a list of available items.
Multiple entries per type are possible.
These items represent categories, e.g. car, plant, insect.
Then, I want to implement elements to enter type-specific key/value pairs for the chosen items, like "brand", "color" and "speed" in case of type "car" or "size" in case of type "plant". That means that also the number of key/value pairs is type specific.
the main goal is to receive a JSON file like e.g.:
{
"protocol":
{
"car":{
"id":1,
"brand":"BMW",
"color":"red",
"speed":300,
}
"plant":{
"id":2
"size":3
"car":{
"id":3,
"brand":"Porsche",
"color":"purple",
"speed":600,
}
"insect":{
"id":4
"aggressive":TRUE
}
...
}
so far, so good, I created the following code:
library(shiny)
library(sortable)
library(htmlwidgets)
library(jsonlite)
icons <- function(x) {lapply(x, function(x){tags$div(tags$strong(x))})}
ui <- fluidPage(
tags$head(
tags$style(HTML('
#drag_from > div {cursor: move; #fallback
cursor: grab; cursor: pointer;
}
#drag_to > div {cursor: move; #fallback
cursor: grab; cursor: pointer;
}
#drag_to {list-style-type: none; counter-reset: css-counter 0;}
#drag_to > div {counter-increment: css-counter 1;}
#drag_to > div:before {content: counter(css-counter) ". ";}
')
)
),
div(
style = "margin-top: 2rem; width: 60%; display: grid;
grid-template-columns: 1fr 1fr; gap: 2rem;
align-items: start;",
div(
div(
class = "panel panel-default",
div(class = "panel-heading", "Drag from here"),
div(
class = "panel-body",
id = "drag_from",
icons(c("car", "plant", "insect"))
)
),
),
div(
div(
class = "panel panel-default",
div(class = "panel-heading", "Drag to here"),
div(
class = "panel-body",
id = "drag_to"
)
)
)
),
sortable_js(
"drag_from",
options = sortable_options(
group = list(
pull = "clone",
name = "group1",
put = TRUE
)
)
),
sortable_js(
"drag_to",
options = sortable_options(
group = list(
group = "group1",
put = TRUE,
pull = TRUE
),
onSort = sortable_js_capture_input(input_id = "selected")
)
),
textInput("filename", "protocol filename", ".json"),
downloadButton('download',"Download JSON")
)
server <- function(input, output) {
output$table1 <- renderTable({input$selected})
output$download <- downloadHandler(
filename = function(){input$filename},
content = function(filename){
write_json({input$selected}, filename)
}
)
}
shinyApp(ui, server)
Now, what's missing is the second part (possibility to enter type specific key/value pairs for the chosen items)
any idea how to proceed?

Can't take a screenshot from a shiny app with background image to use it as a report

I have this simplified app:
library(shiny)
library(shinyWidgets)
library(shinyscreenshot)
library(capture)
my_ids <- LETTERS[1:13]
ui <- fluidPage(
#background image
tags$img(
src = "http://upload.wikimedia.org/wikipedia/commons/5/5d/AaronEckhart10TIFF.jpg",
style = 'position: absolute; position: absolute;
width: 1250px; height: 880px;'
),
div(id = "container1",
style="position: absolute;left: 30px; top: 170px; display: inline-block;vertical-align:middle; width: 300px;",
radioGroupButtons(inputId = my_ids[1], label = "", choices = 0:3, selected = 0, checkIcon = list(yes = icon("check")), status = c("zero", "one", "two", "three"))
),
div(style="position: absolute;left: 10px; top: 830px;",
capture::capture(
selector = "body",
filename = "all-page.png",
icon("camera"), "Take screenshot of all page"
))
)
server <- function(input, output, session) {
observeEvent(input$update, {
updateRadioGroupButtons(session = session, inputId = my_ids[1], selected = 0)
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
In this app we have a background picture and the user can press some buttons that will generate a value shown on the background picture. The app works well.
Now I would like to take a screenshot of the picture with all elements on it (like buttons etc. to use it as a report.
How can I do this. I tried shinyscreenshot and capture.
I need the screenshot to print as a report on a DIN A4 format.
Here is what I get after numerous trials and errors. This solution uses the JavaScript libraries jspdf and domtoimage.
The result is a pdf file in format A4. Unfortunately, that does not work with the icon.
library(shiny)
library(shinyWidgets)
js <- "
function Export(){
var $img = $('#img');
var width = $img.width();
var height = $img.height();
domtoimage.toPng($('html')[0])
.then(function (blob) {
var pdf = new jsPDF('p', 'mm', 'a4');
var imgProps = pdf.getImageProperties(blob);
var pdfWidth = pdf.internal.pageSize.width;
var pdfHeight = pdf.internal.pageSize.height;
var widthRatio = pdfWidth / width;
var heightRatio = pdfHeight / height;
var ratio = Math.min(widthRatio, heightRatio);
var w = imgProps.width * ratio;
var h = imgProps.height * ratio;
pdf.addImage(blob, 'PNG', 0, 0, w, h);
pdf.save('allPage.pdf');
});
}
"
my_ids <- LETTERS[1:13]
ui <- fluidPage(
tags$head(
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jspdf/1.5.3/jspdf.min.js"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/dom-to-image/2.6.0/dom-to-image.min.js"),
tags$script(HTML(js))
),
#background image
tags$img(
id = "img",
src = "http://upload.wikimedia.org/wikipedia/commons/5/5d/AaronEckhart10TIFF.jpg",
style = 'position: absolute; width: 1250px; height: 880px;'
),
div(id = "container1",
style="position: absolute; left: 30px; top: 170px; display: inline-block; vertical-align: middle; width: 300px;",
radioGroupButtons(
inputId = my_ids[1], label = "", choices = 0:3, selected = 0,
#checkIcon = list(yes = icon("check")),
status = c("zero", "one", "two", "three")
),
actionButton(
"export", "Export to PDF",
onclick = "Export();"
)
)
)
server <- function(input, output, session){
observeEvent(input$update, {
updateRadioGroupButtons(session = session, inputId = my_ids[1], selected = 0)
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
EDIT
For the icon, you can use this CSS:
css <- ".check {position: absolute; left: 0; top: 50%; transform: translateY(-50%); display: inline-block; text-rendering: auto; line-height: 1}
.check:before {content: '\\2713';}"
and then:
checkIcon = list(yes = tags$i(class = "check", role = "presentation"))

How to replenish the bucket list when running the sortable package?

I'm exploring ways to visualize a mathematical process (a series of sequential computations) and the sortable package may be the answer, with modifications. The below reproducible code is pulled from the basic examples of how to use sortable found online and in its reference manual (with a table output added so I can start manipulating the data frame).
I'm trying to see if there's a way to not deplete the bucket list as the user drags and drops from the left panel (labeled "Pool" in my example) to the right panel (labeled "Pool Ranking" in my example). So looking at the image at the bottom, the user can drag/drop items A, B, C, D, E, as many times as desired. The right "drag to" panel then grows longer than the left "drag from" panel due to the repetition of elements dragged/dropped.
Is this possible in sortable? How can it be done? Or should I be looking at other packages instead?
If I can figure this out, my next step will be to add another "drag from" panel of mathematical formulas to drag to the right of the dragged-to label elements A - E.
Reproducible code:
library(shiny)
library(sortable)
ui <-
fluidPage(
tags$head(tags$style(HTML("
.column_2 {
counter-reset: rank;
}
.column_2 .rank-list-item::before {
counter-increment: rank;
content: counter(rank) '. ';
}
"))),
htmlOutput("rankingForm"),
helpText(h5(strong("Output to table:"))),
tableOutput("table1")
)
server <- function(input, output, session) {
output$rankingForm <- renderUI({
fluidRow(
column(tags$b("Pool Ranking"), width = 12,
bucket_list(header = "Drag to the right from the Pool below to rank.",
group_name = "bucket_list_group", orientation = "horizontal",
add_rank_list("Pool:",
labels = c("A","B","C","D","E"),
input_id = "rank_list_1"
),
add_rank_list("Pool Ranking:", labels = NULL,
input_id = "rank_list_2")
)
)
)
})
output$table1 <- renderTable({input$rank_list_2})
}
shinyApp(ui=ui, server=server)
Through these listed StackOverflow posts and solutions, I arrived at the "Working solution" shown at the bottom:
Related posts:
vladimir_orbucina request at https://github.com/rstudio/sortable/issues/45 and
How to pull list elements from HTML/CSS and into an R data frame? and
How to make the label in the sortable package add_rank_list function reactive? and
Any creative ways to add rank ordering numbering to this simple sortable package example?
And an important link that explains cloning: https://rstudio.github.io/sortable/articles/cloning.html
Working solution:
library(shiny)
library(sortable)
library(htmlwidgets)
icons <- function(x) {lapply(x,function(x){tags$div(tags$strong(x))})}
ui <- fluidPage(
# Below solution provided by I|O on Jun 1, 2022:
tags$head(
tags$style(HTML('
#drag_from > div {cursor: move; #fallback
cursor: grab; cursor: pointer;
}
#drag_to > div {cursor: move; #fallback
cursor: grab; cursor: pointer;
}
#drag_to {list-style-type: none; counter-reset: css-counter 0;}
#drag_to > div {counter-increment: css-counter 1;}
#drag_to > div:before {content: counter(css-counter) ". ";}
')
)
),
div(
style = "margin-top: 2rem; width: 60%; display: grid; grid-template-columns: 1fr 1fr; gap: 2rem; align-items: start;",
div(
div(
class = "panel panel-default",
div(class = "panel-heading", "Drag from here"),
div(
class = "panel-body",
id = "drag_from",
icons(c("A", "B", "C", "D", "E"))
)
),
),
div(
div(
class = "panel panel-default",
div(class = "panel-heading", "Drag to here"),
div(
class = "panel-body",
id = "drag_to"
)
)
)
),
sortable_js(
"drag_from",
options = sortable_options(
group = list(
pull = "clone",
name = "group1",
put = FALSE
)
)
),
sortable_js(
"drag_to",
options = sortable_options(
group = list(
group = "group1",
put = TRUE,
pull = TRUE
),
onSort = sortable_js_capture_input(input_id = "selected") # << solution by stefan on Jun 01, 2022
)
),
helpText(h5(strong("Output to table:"))),
tableOutput("table1")
)
server <- function(input, output) {
output$table1 <- renderTable({input$selected})
}
shinyApp(ui, server)

Move R Shiny showNotification to a certain div

Closely related to this question, I am trying to move the showNotification´s to a certain div that is already on the page. Is there an easy way to do that?
The following app should illustrate the problem. The notifications in the lower right should go in the yellow div.
library(shiny)
ui=shinyUI(fluidPage(
tags$head(
tags$style(HTML("
#error {
width: 100%;
border: black 1px solid;
padding: 5px;
margin: 10px 0;
background-color: #f7f2d9;
}
"))
),
sidebarLayout(
sidebarPanel(
sliderInput("lambda","Number",min = 1,max = 100,value = 27)
),
mainPanel(
h3("Move the slider above 28 to trigger a Notification! "),
plotOutput("algebra"),
div(id = "error", p("The notifications should appear in here")),
tableOutput('table')
)
)
))
server=function(input, output) {
output$algebra <- renderPlot({
if (input$lambda > 28){
showNotification("How can I put this message in the #error div?", id = "error", type = "warning", duration = NULL)
return(NULL)
}
n <- 1:100
lambda <- seq(min(n), max(n), length.out = input$lambda)
plot((2*lambda)+3, type = "o",xlab= "X (number of data points)", ylab = "Y = 2x+3")
})
output$table <- renderTable(iris)
}
shinyApp(ui,server)
This seems to work:
library(shiny)
library(shinyjs)
ui=shinyUI(fluidPage(
useShinyjs(),
tags$head(
tags$style(HTML("
#error {
width: 100%;
border: black 1px solid;
padding: 5px;
margin: 10px 0;
background-color: #f7f2d9;
}
#shiny-notification-panel {
position: static;
}
"))
),
......
and in server:
output$algebra <- renderPlot({
if(input$lambda > 28){
showNotification("How can I put this message in the #error div?", type = "warning", duration = NULL)
runjs('setTimeout(function(){$("#error").append($("#shiny-notification-panel"))},0);')
return(NULL)
}
......
Not highly tested though. An alternative is bsAlert from the shinyBS package.

observers fire on render of dynamic UI when they should not

The problem I face is that observers linked to dynamically rendered elements seem to fire on render, while this is not how I want it to be.
The reason this is a problem, is that the color buttons I'm making are linked to a plot that takes several seconds to render (plotly widget)
I added ignoreInit = T the observers that are created, but they still fire on rendering, unlike normal observers linked to a button build directly in the UI
How do I stop the observers linked to the dynamically rendered colourInput from firing when the element is rendered?
In the dummy app below the following series of events is recreated in simplified form:
A model spits out a number (simulated by test button in demo app)
Based on this number, a number of colourInput buttons are made
A same number of observeEvents are made for each.
Not in the dummy app: When the user chooses to change a color, the corresponding group in plots is recolored accordingly
The test app contains a working static colourInput, and a dynamic part that demonstrates the problem scenario.
Test app:
library(shiny)
library("colourpicker")
THECOLORS <- c('#383838', '#5b195b','#1A237E', '#000080', '#224D17', '#cccc00', '#b37400', '#990000',
'#505050', '#a02ca0', '#000099', '#2645e0', '#099441', '#e5e500', '#cc8400', '#cc0000',
'#737373', '#e53fe5', '#0000FF', '#4479e1', '#60A830', '#ffff00','#e69500', '#ff0000',
'#b2b2b2', '#eb6ceb', '#6666ff', '#d0a3ff', '#9FDA40', '#ffff7f', '#ffa500', '#ff4c4c')
ui <- fluidPage(
h1("WELCOME TO THE TEST APP", style = 'text-align: center; font-weight:bold' ),
br(),
h3("STATIC PART: doesn't fire on startup, great!", style = 'font-weight:bold'),
div(colourpicker::colourInput(inputId = 'StaticColor', label = NULL, palette = "limited", allowedCols = THECOLORS, value = THECOLORS[14], showColour = "background", returnName = TRUE),
style = " height: 30px; width: 30px; border-radius: 6px; border-width: 2px; text-align:center; padding: 0px; display:block; margin-bottom: 10px"),
br(),
h3("Dynamic part: fires on render, NOT great!", style = 'font-weight:bold'),
actionButton(inputId = 'Tester', label = 'Click me'),
br(),
uiOutput('colorbutton')
)
server <- function(input, output, session) {
values <- reactiveValues()
values$mycolors <- THECOLORS
observeEvent(input$Tester, { values$NrofButtons <- sample(1:10, 1) })
observeEvent(values$NrofButtons, {
COLElement <- function(idx){sprintf("COL_button-%s-%d",values$NrofButtons,idx)}
output$colorbutton <- renderUI({
lapply(1:values$NrofButtons, function(x) {
div(colourpicker::colourInput(inputId = COLElement(x), label = NULL, palette = "limited", allowedCols = values$mycolors, value = values$mycolors[x], showColour = "background", returnName = TRUE),
style = " height: 30px; width: 30px; border-radius: 6px; border-width: 2px; text-align:center; padding: 0px; display:block; margin-bottom: 10px") })
})
lapply(1:values$NrofButtons, function(x) { observeEvent(input[[COLElement(x)]], { print(input[[COLElement(x)]] )}, ignoreInit = T) }) # make observer for each button
})
observeEvent(input[['StaticColor']], { print(input[['StaticColor']] )}, ignoreInit = T)
}
shinyApp(ui,server)
Renders should always be by themselves and be data driven, not event driven -- so I've made the render require the number of colors to be defined before rendering. Of course the number of colors aren't defined until the observeEvent is fired by clicking the button.
Overall there is still the issue that every time the button is clicked more observers are created for the same ID, working on a way to destroy these automatically on a subsequent click of the tester button.
The key addition was a ignoreInit = TRUE in your observeEvent(input$Tester, {...}) observer.
library(shiny)
library("colourpicker")
THECOLORS <- c('#383838', '#5b195b','#1A237E', '#000080', '#224D17', '#cccc00', '#b37400', '#990000',
'#505050', '#a02ca0', '#000099', '#2645e0', '#099441', '#e5e500', '#cc8400', '#cc0000',
'#737373', '#e53fe5', '#0000FF', '#4479e1', '#60A830', '#ffff00','#e69500', '#ff0000',
'#b2b2b2', '#eb6ceb', '#6666ff', '#d0a3ff', '#9FDA40', '#ffff7f', '#ffa500', '#ff4c4c')
ui <- fluidPage(
h1("WELCOME TO THE TEST APP", style = 'text-align: center; font-weight:bold' ),
br(),
h3("STATIC PART: doesn't fire on startup, great!", style = 'font-weight:bold'),
div(colourpicker::colourInput(inputId = 'StaticColor', label = NULL, palette = "limited", allowedCols = THECOLORS, value = THECOLORS[14], showColour = "background", returnName = TRUE),
style = " height: 30px; width: 30px; border-radius: 6px; border-width: 2px; text-align:center; padding: 0px; display:block; margin-bottom: 10px"),
br(),
h3("Dynamic part: fires on render, NOT great!", style = 'font-weight:bold'),
actionButton(inputId = 'Tester', label = 'Click me'),
br(),
uiOutput('colorbutton')
)
COLElement <- function(idx) sprintf("COL_button-%d", idx)
server <- function(input, output, session) {
values <- reactiveValues(previous_max = 1)
observeEvent(input$Tester, {
values$NrofButtons <- sample(1:10, 1)
# reset counters for all observers
for (i in seq(values$NrofButtons)) {
values[[sprintf("observer%d_renders", i)]] <- 0L
}
# only initialize incremental observers
lapply(values$previous_max:values$NrofButtons, function(x) {
observeEvent(input[[COLElement(x)]], {
# only execute the second time, since the `ignoreInit` isn't obeyed
if (values[[sprintf("observer%d_renders", x)]] > 0) {
print(input[[COLElement(x)]] )
} else {
values[[sprintf("observer%d_renders", x)]] <- 1L
}
}, ignoreInit = TRUE)
}) # make observer for each button
# record the max
values$previous_max <- max(values$previous_max, max(values$NrofButtons))
}, ignoreInit = TRUE)
output$colorbutton <- renderUI({
req(length(values$NrofButtons) > 0)
lapply(1:values$NrofButtons, function(x) {
div(colourpicker::colourInput(
inputId = COLElement(x)
, label = NULL
, palette = "limited"
, allowedCols = THECOLORS
, value = THECOLORS[x]
, showColour = "background"
, returnName = TRUE
)
, style = " height: 30px; width: 30px; border-radius: 6px; border-width: 2px; text-align:center; padding: 0px; display:block; margin-bottom: 10px"
)
})
})
observeEvent(input$StaticColor, {
print(input$StaticColor )
}, ignoreInit = TRUE)
}
shinyApp(ui,server)

Resources