observers fire on render of dynamic UI when they should not - r

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)

Related

Print indices of columns that are selected on click using the DT package in Shiny app

I have a selectable DT and a radio button that changes the orientation of the selection. I am able to print the index of the selections when the radio button is set to rows, but I don't know how to show the indices when the radio button is set to columns. Is there a way of printing the column indices instead of printing a NULL when the radio buttons are set to columns?
Here is my MRE:
library(shiny)
library(glue)
library(dplyr)
library(DT)
library(shinyWidgets)
library(tibble)
####Create the matrix and organization for the 96 well plate####
plate96 <- function(id) {
div(
style = "position: relative; height: 500px",
tags$style(HTML('
.wells {
transform: translateX(50%);
}
.wells tbody tr td:not(:first-of-type) {
border: 1px solid black;
height: 15px;
width: 15px;
padding: 15px;
font-size: 0;
}
')),
div(
style = "position: absolute; left: 50%; transform: translateX(-100%);",
div(
class = "wells",
DTOutput(id, width = "90%", height= "100%")
)
)
)
}
renderPlate96 = function(id, colors = rep("white", 96)) {
stopifnot(is.character(colors) && length(colors) == 96)
plate <- matrix(1:96,
nrow = 8,
ncol = 12,
byrow = TRUE,
dimnames = list(LETTERS[1:8], 1:12))
colnames (plate) = stringr::str_pad(colnames(plate), 2, "left", "0")
return(plate_return1 <-
datatable(
plate,
options = list(dom = 't', ordering = F),
selection = {if (id == "Horizontal") {list(target = "row")}
else if (id == "Vertical") {list(target = "column")}},
class = 'cell-border compact'
) %>%
formatStyle(
1:12,
cursor = 'pointer',
backgroundColor = styleEqual(1:96, colors, default = NULL)
)
)
}
ui <- fluidPage(
br(),
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("plateWells_selected"),
####Horizontal vs Vertical orientation radio buttons####
radioButtons("orientation_radio",
label = h3("Horizontal vs Vertical"),
c("Horizontal, counted down rows" = "Horizontal",
"Vertical, counted down columns" = "Vertical")),
)
server <- function(input, output, session){
####Create the 96 well plate image####
output$plate <- renderDT({
renderPlate96({as.character(input$orientation_radio)})
})
output$plateWells_selected <- renderPrint({
input$plate_rows_selected
})
}
shinyApp(ui = ui, server = server)
After more Googling, I found the answer.
The answer is given here:
https://rstudio.github.io/DT/shiny.html
2.1.2 Column Selection
Row selection is the default mode in DT. You can turn on column selection using datatable(..., selection = list(target = 'column')). In this case, you can click on any cell to select a column, and the (numeric) indices of the selected columns will be available in input$tableId_columns_selected.
You may also select rows and columns simultaneously using target = 'row+column'. In this case, column selection is achieved by clicking on the table footer. Clicking on the table body will select/deselect rows.

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.

Generate progress bar in modal in shiny app, that closes automatically

I am working on a shiny app that takes a long time to do calculations, I want to have a modal progress bar that closes automatically as soon as all calculations work.
The ideal solution would have two features
Covers most of the screen and prevents the user to interact with app
Closes automatically as soon as it finishes making calulations
I found this solution in the following question:
library("shiny")
library("shinyWidgets")
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch long calculation"), #, onclick = "$('#my-modal').modal().focus();"
# You can open the modal server-side, you have to put this in the ui :
tags$script("Shiny.addCustomMessageHandler('launch-modal', function(d) {$('#' + d).modal().focus();})"),
tags$script("Shiny.addCustomMessageHandler('remove-modal', function(d) {$('#' + d).modal('hide');})"),
# Code for creating a modal
tags$div(
id = "my-modal",
class="modal fade", tabindex="-1", `data-backdrop`="static", `data-keyboard`="false",
tags$div(
class="modal-dialog",
tags$div(
class = "modal-content",
tags$div(class="modal-header", tags$h4(class="modal-title", "Calculation in progress")),
tags$div(
class="modal-body",
shinyWidgets::progressBar(id = "pb", value = 0, display_pct = TRUE)
),
tags$div(class="modal-footer", tags$button(type="button", class="btn btn-default", `data-dismiss`="modal", "Dismiss"))
)
)
)
)
server <- function(input, output, session) {
value <- reactiveVal(0)
observeEvent(input$go, {
shinyWidgets::updateProgressBar(session = session, id = "pb", value = 0) # reinitialize to 0 if you run the calculation several times
session$sendCustomMessage(type = 'launch-modal', "my-modal") # launch the modal
# run calculation
for (i in 1:10) {
Sys.sleep(0.5)
newValue <- value() + 1
value(newValue)
shinyWidgets::updateProgressBar(session = session, id = "pb", value = 100/10*i)
}
Sys.sleep(0.5)
# session$sendCustomMessage(type = 'remove-modal', "my-modal") # hide the modal programmatically
})
}
shinyApp(ui = ui, server = server)
This solves issue 1, but I have to click on dismiss to see the results
The original progressbar provided in shiny is exactly what you need.
But I use css to make the progessbar display in the middle in the screen.
You can find the detail of using progress bar in shiny here.
library("shiny")
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch long calculation"), #, onclick = "$('#my-modal').modal().focus();"
# css to center the progress bar
tags$head(
tags$style(
HTML(".shiny-notification {
height: 100px;
width: 800px;
position:fixed;
top: calc(50% - 50px);
left: calc(50% - 400px);
font-size: 250%;
text-align: center;
}
"
)
)
)
)
server <- function(input, output, session) {
value <- reactiveVal(0)
observeEvent(input$go, {
withProgress(message = 'Calculation in progress', value = 0,detail="0%", {
# run calculation
for (i in 1:10) {
Sys.sleep(0.5)
newValue <- value() + 1
value(newValue)
incProgress(1/10,detail = paste0(i*10,"%"))
}
Sys.sleep(0.5)
})
})
}
shinyApp(ui = ui, server = server)
Not a whole answer, just answering the additional css requests. You could change the css to, which will make the panel fill up the whole page.
.shiny-notification {
height: 100%;
width: 100%;
top: 0;
left: 0;
position:fixed;
font-size: 250%;
text-align: center;
background-color: rgba(0, 0, 0, 0.7);
color: white;
}

Dynamically rendered UI: how to delete old reactive variables on second run

Hello heroes of Stack overflow,
SHORT SUMMARY:
App works great, until you change the entered number in the input field. UI re-renders great, but server side fails on stuff still in the memory it seems. Detailed explanation below:
I have a nicely working dynamic app, but I'm still dealing with a few bugs and one core problem.
The problem must be somewhere in the reactivity but I'm having a lot of difficulty to figure out what it is that Im doing wrong. I've tried dozens of things already, and none of them work, or end up breaking the app in other areas.
Here is the MAIN PROBLEM:
The app records the user click actions as 1's or 0's in a reactiveValues() list called dynamicvalues_highlight_button_sf1 and the elements are dynamically made within an lapply function that makes the dynamic observers the same way the dynamic buttons are made.
When you enter a number, buttons appear and everything works perfect
UNTIL you change the number in the text field.
-The buttons are updated and new amount is rendered, etc,
BUT: the old dynamicvalues_highlight_button_sf1 and dynamiclist is still being printed.
I am clueless why the old results are still there as well as new ones.
So instead of just the new results:
[1] "dl = 0, 0, 0, 0, 1" ## status of the current nr of elements (here its 5)
[1] "ob = 5" ### nr of the last clicked button
[1] "-----------next click event prints the below this line-----------"
the printout I get is old and new results:
[1] "dl = 0, 0, 0, 0, 1, 0" ## old results
[1] "ob = 5"
[1] "-----------next click event prints the below this line-----"
[1] "dl = 0, 0, 0, 0, 0, 0" ## new results
[1] "ob = 5"
[1] "-----------next click event prints the below this line-----"
I've tried things like rm(dynamicvalues_highlight_button_sf1) and rm(dynamiclist) but those can only work if the values are there, and cause a crash when the app starts since they don't.
Wrapping them inside an if(exists("dynamicvalues_highlight_button_sf1")) { }
doens't work because exists seems not to work on reactivevalues lists. (I've also tried evaluate(need(...the variable..., "text")) and if(!is.null(...the variable...)){...} but all failed. Also tried to put these in different places in the server but no succes. I'm lost and my knowledge of R shiny still is too limited for this complexity it seems.
SECOND Part of the problem
if I first enter i.e. 5, click something, and then recreate buttons for a number larger than 5 i.e. 6: BUTTON nr 6 works (gets blue etc), but buttons 1:5 DO NOT work.
I suspect the two problems are related to each other.
The UI and server are posted below. Have some fun trying it before you dive into the problem if you like.
NOTES:
- posted the "minimal example" but its a rather complex app in order to have the whole functionality here.
- the real app will spit the input NR out from a big modeling step rather than the input field in this demo
- I annotated as much as possible for clarity
- I left a little bit of code of my last attempt to solve the problem in the server.r at lines 18-25.
Thanks for any help you can offer!
UI.r
library(shiny)
library(shinydashboard)
library(shinyBS)
ui <- dashboardPage(
dashboardHeader(title = "My Test App"),
dashboardSidebar(
sidebarMenu(id = "tabs", menuItem("testpage", tabName = "testpage", icon = icon("book"))
)
),
dashboardBody(
tags$head(tags$style(HTML('.skin-blue .content-wrapper, .right-side {background-color: #ffffff; }, '))),
tabItems(
### test page ###_________
tabItem(tabName = "testpage",
h5("Enter desired nr of elements here"),
textInput(inputId ="NrOfClusters", label = NULL , placeholder = "NULL"),
fluidRow(
column(2,
uiOutput("buttons_highlight_sf1")),
column(1,
uiOutput("button_hightlight_all_sf1"),
uiOutput("multi_highlight"),
br(),
actionButton(inputId = "statuscheck", label = "status", style = "background-color: white")
))))))
SERVER.R
shinyServer = function(input, output, session) {
################# start functionality HOME TAB #############################
### create 2 reactive environment lists
values <- reactiveValues()
dynamicvalues_highlight_button_sf1 <- reactiveValues()
### set initial state of two buttons
values$HL_multi_switch_sf1 <- FALSE
values$HL_all_switch_sf1 <- FALSE
### if the user types in a value, then convert it to a reactive value of this nr
observeEvent (input$NrOfClusters, {
isolate(values$nrofelements <- paste0(input$NrOfClusters))
##TRY THERE TO REMOVE THE dynamiclist and all the reactive elements in dynamic_highlight_button_sf1
if (exists("dynamiclist")) {
rm(dynamiclist)
rm(dynamicvalues_highlight_button_sf1)
dynamicvalues_highlight_button_sf1 <- reactiveValues() }
isolate( dynamiclist <- as.character(unlist(reactiveValuesToList(dynamicvalues_highlight_button_sf1), use.names = FALSE)))
isolate( print(paste0("dl length = ", length(dynamiclist))))
})
#### RENDER DYNAMIC UI and DYNAMIC OBSERVERS
observeEvent(values$nrofelements, {
print(values$nrofelements == 1 | values$nrofelements >1)
### create a nr of buttons equal to the entered value
if (values$nrofelements == 1 | values$nrofelements >1) {
output$buttons_highlight_sf1 <- renderUI({
lapply(1:values$nrofelements, function(ab) {
if (!is.null(dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ab)]])) {
if(dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ab)]] == 0 ) {
div(br(), actionButton(inputId = paste0("highlight_button_sf1", ab), label = icon("lightbulb-o"),style = "color: grey;
background-color: white;
height: 35px;
width: 35px;
text-align:center;
text-highlight_buttonent: 0,5px;
border-radius: 6px;
display:block;
margin: auto;
border-width: 2px")) }
else { div(br(), actionButton(inputId = paste0("highlight_button_sf1", ab), label = icon("lightbulb-o"),style = "color: black;
background-color: white;
border-color: blue;
height: 35px;
width: 35px;
text-align:center;
text-highlight_buttonent: 0,5px;
border-radius: 6px;
display:block;
margin: auto;
border-width: 2px")) } }
else { div(br(), actionButton(inputId = paste0("highlight_button_sf1", ab), label = icon("lightbulb-o"),style = "color: grey;
background-color: white;
height: 35px;
width: 35px;
text-align:center;
text-highlight_buttonent: 0,5px;
border-radius: 6px;
display:block;
margin: auto;
border-width: 2px")) }
})
})
### create a button to highlight all
output$button_hightlight_all_sf1 <- renderUI({
if(values$HL_all_switch_sf1 == TRUE) {
div( br(), actionButton(inputId = "hightlight_all_button_sf1", label = "All", style = "color: blue; background-color:white"), br())}
else { div( br(), actionButton(inputId = "hightlight_all_button_sf1", label ="All", style = "color: grey; background-color:white"), br())}
})
### create a button to enable highlight multiple or sinle boxes
output$multi_highlight <- renderUI({
if(values$HL_multi_switch_sf1 == TRUE) {
div( br(), actionButton(inputId = "multi_highlight", label ="multi", style = "color: blue; background-color:white"), br())}
else { div( br(), actionButton(inputId = "multi_highlight", label ="single", style = "color: green; background-color:white"), br())}
})
### loop apply function over all dynamically created buttons
isolate(lapply(1:values$nrofelements, function(ob) {
observeEvent(input[[paste0("highlight_button_sf1", ob)]], {
### complex observer structure to check what to do depending on the ALL and MULTI status
### FALSE all FALSE multi
if (values$HL_all_switch_sf1 == FALSE) {
if (values$HL_multi_switch_sf1 == FALSE) {
for (each in 1:values$nrofelements) {
if ( ob != each) { dynamicvalues_highlight_button_sf1[[paste0("highlight_button", each)]] <- 0}
else if (ob == each) {
if (is.null(dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]])) {dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 1}
else if (dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] == 1) {dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 0}
else if (dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] == 0) {dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 1}
}}}
### FALSE all TRUE multi
if (values$HL_multi_switch_sf1 == TRUE){
if (is.null(dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]])) {dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 1}
else if (dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] == 1) {dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 0}
else if (dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] == 0) {dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 1}
}}
### TRUE all TRUE multi
if(values$HL_all_switch_sf1 == TRUE) {
if (values$HL_multi_switch_sf1 == TRUE) {
dynamicvalues_highlight_button_sf1[[paste0("highlight_button", ob)]] <- 0
isolate(values$HL_all_switch_sf1 <- FALSE)}
### TRUE all FALSE multi
else if (values$HL_multi_switch_sf1 == FALSE) { for (each in 1:values$nrofelements)
{if (ob != each) { dynamicvalues_highlight_button_sf1[[paste0("highlight_button", each)]] <- 0}
}
isolate(values$HL_all_switch_sf1 <- FALSE)
}}
dynamiclist <- as.character(unlist(reactiveValuesToList(dynamicvalues_highlight_button_sf1), use.names = FALSE))
print(paste0("dl = ", toString(dynamiclist)))
print(paste("ob =", ob ))
lastclicked_button_nr <- ob
colorpalette <- vector(mode="character", length=values$nrofelements)
colorpalette <- replace(colorpalette, colorpalette == "", "GREY")
colorpalette[values$button_nr_clicked]="RED"
print( "-----------next click event prints the below this line--------------------------------------------------------------")
})
}))
}
})
#### OBSERVE DYNAMIC UI
observeEvent(input$multi_highlight, {
if (values$HL_multi_switch_sf1 == TRUE) { values$HL_multi_switch_sf1 <- FALSE }
else if (values$HL_multi_switch_sf1 == FALSE) { values$HL_multi_switch_sf1 <- TRUE }
})
observeEvent(input$hightlight_all_button_sf1,{
if (values$HL_all_switch_sf1 == TRUE) { values$HL_all_switch_sf1 <- FALSE }
else if (values$HL_all_switch_sf1 == FALSE) {values$HL_all_switch_sf1 <- TRUE}
if (values$HL_all_switch_sf1 == TRUE) { for (any in 1:values$nrofelements) { dynamicvalues_highlight_button_sf1[[paste0("highlight_button", any)]] <- 1}}
else if (values$HL_all_switch_sf1 == FALSE) { for (any in 1:values$nrofelements) { dynamicvalues_highlight_button_sf1[[paste0("highlight_button", any)]] <- 0}}
colorpalette <- NULL
colorpalette <- vector(mode="character", length=values$nrofelements)
colorpalette <- replace(colorpalette, colorpalette == "", "RED")
})
### button to print the status of Multi and All on console to check what they are
observeEvent(input$statuscheck, {
print(paste("ALL switch: ", values$HL_all_switch_sf1))
print(paste("MULTI switch: ", values$HL_multi_switch_sf1))
})
}
additional bug 1:
if you change the numberinput to nothing we get an error
additional bug 2:
if I start with entering "0" it goes well and we get no buttons, if I enter any number higher than 0 we get that many buttons, but if I then change it to 0 buttons I get 2 buttons!:
eventough the dynamic renderUI in line 36 of the server is wrapped inside a condtion:
if (values$nrofelements == 1 | values$nrofelements >1) { ......
Okay, your problem is a tricky one that people have fallen for before, if you look at the documentation of reactiveValues (here reactiveValues docs) it says that
"Note that values taken from the reactiveValues object are reactive,
but the reactiveValues object itself is not."
So you should not be using dynamicvalues_highlight_button_sf1 the way your are, you should be using named elements of it. I got it to work by doing the following:
replacing dynamicvalues_highlight_button_sf1 with dhbs globally (not necssary but the lines were getting way too long for me to see what was going on).
replacing dhbs with dhbs$el globally.
getting rid of all the reactiveValuesToList calls.
getting rid of all the attempts to rm(...) things out of the reactive environment.
adding a dhbs$el <- NULL statement as the first line of the observeEvent(values$nrofelements, { node code.
added an extra output field to inspect dhbs with a renderTextVerbatum statement. This is a useful debugging technique when you get used to it.
eliminated a lot of redundant code.
eliminated all the isolate statements which were not doing anything.
added a clickcount to handle the reactivity better.
Seems to work now, although there might be a few other problems to fix up still as a result of those changes. I also think that many of those isolates are probably unnecessary and just a result of your debugging activities.
The code:
library(shiny)
library(shinydashboard)
library(shinyBS)
ui <- dashboardPage(
dashboardHeader(title = "My Test App"),
dashboardSidebar(
sidebarMenu(id = "tabs", menuItem("testpage", tabName = "testpage", icon = icon("book"))
)
),
dashboardBody(
tags$head(tags$style(HTML('.skin-blue .content-wrapper, .right-side {background-color: #ffffff; }, '))),
tabItems(
### test page ###_________
tabItem(tabName = "testpage",
h5("Enter desired nr of elements here"),
textInput(inputId ="NrOfClusters", label = NULL , placeholder = "NULL"),
verbatimTextOutput("values"),
verbatimTextOutput("clickcount"),
fluidRow(
column(2,
uiOutput("buttons_highlight_sf1")),
column(1,
uiOutput("button_hightlight_all_sf1"),
uiOutput("multi_highlight"),
br(),
actionButton(inputId = "statuscheck", label = "status", style = "background-color: white")
))))))
off_style <-
"color: grey;
background-color: white;
height: 35px;
width: 35px;
text-align:center;
text-highlight_buttonent: 0,5px;
border-radius: 6px;
display:block;
margin: auto;
border-width: 2px"
on_style <-
"color: grey;
background-color: white;
border-color: blue;
height: 35px;
width: 35px;
text-align:center;
text-highlight_buttonent: 0,5px;
border-radius: 6px;
display:block;
margin: auto;
border-width: 2px"
shinyServer = function(input, output, session) {
################# start functionality HOME TAB #############################
### create 2 reactive environment lists
values <- reactiveValues(clickcount=0)
dhbs <- reactiveValues(el=NULL)
### set initial state of two buttons
values$HL_multi_switch_sf1 <- FALSE
values$HL_all_switch_sf1 <- FALSE
### if the user types in a value, then convert it to a reactive value of this nr
observeEvent (input$NrOfClusters, {
values$nrofelements <- input$NrOfClusters
dynamiclist <- as.character(unlist(dhbs$el), use.names = FALSE)
print(paste0("dl length = ", length(dynamiclist)))
})
hibutname <- function(idx){
sprintf("highlight_button_sf1-%s-%d",values$nrofelements,idx)
}
atbutname <- function(idx){
sprintf("activate_button_sf1-%s-%d",values$nrofelements,idx)
}
fliphib <- function(idx){
hib <- hibutname(idx)
dhbs$el[hib] <- abs(1-dhbs$el[hib])
}
sethib <- function(idx,v){
hib <- hibutname(idx)
dhbs$el[hib] <- v
}
#### RENDER DYNAMIC UI and DYNAMIC OBSERVERS
observeEvent(values$nrofelements, {
req(input$NrOfClusters)
nel <- values$nrofelements
dhbs$el <- rep(0,nel)
names(dhbs$el) <- sapply(1:nel,hibutname)
print(names(dhbs$el))
output$buttons_highlight_sf1 <- renderUI({
values$clickcount
print("clickcount")
print(values$clickcount)
lapply(1:values$nrofelements, function(ab) {
if(dhbs$el[[hibutname(ab)]] == 0 ) {
print("gray")
div(br(), actionButton(inputId = hibutname(ab), label = icon("lightbulb-o"),style = off_style))
} else {
print("black")
div(br(), actionButton(inputId = hibutname(ab), label = icon("lightbulb-o"),style = on_style))
}
})
})
### create a button to highlight all
output$button_hightlight_all_sf1 <- renderUI({
if(values$HL_all_switch_sf1 == TRUE) {
div( br(), actionButton(inputId = "hightlight_all_button_sf1", label = "All", style = "color: blue; background-color:white"), br())
} else {
div( br(), actionButton(inputId = "hightlight_all_button_sf1", label ="All", style = "color: grey; background-color:white"), br())
}
})
### create a button to enable highlight multiple or single boxes
output$multi_highlight <- renderUI({
if(values$HL_multi_switch_sf1 == TRUE) {
div( br(), actionButton(inputId = "multi_highlight", label ="multi", style = "color: blue; background-color:white"), br())
} else {
div( br(), actionButton(inputId = "multi_highlight", label ="single", style = "color: green; background-color:white"), br())
}
})
lapply(1:values$nrofelements, function(ob) {
butname <- hibutname(ob)
observeEvent(input[[butname]], {
hibut <- hibutname(ob)
print(hibut)
values$clickcount <- values$clickcount+1
print("clicked")
print(values$clickcount)
### complex observer structure to check what to do depending on the ALL and MULTI status
### FALSE all FALSE multi
if (values$HL_all_switch_sf1 == FALSE) {
if (values$HL_multi_switch_sf1 == FALSE) {
for (each in 1:values$nrofelements) {
if ( ob != each) {
sethib(each,0)
} else {
fliphib(each)
}
}
}
### FALSE all TRUE multi
if (values$HL_multi_switch_sf1 == TRUE){
fliphib(ob)
}
}
### TRUE all TRUE multi
if(values$HL_all_switch_sf1 == TRUE) {
if (values$HL_multi_switch_sf1 == TRUE) {
sethib(ob,0)
values$HL_all_switch_sf1 <- FALSE
}
### TRUE all FALSE multi
else if (values$HL_multi_switch_sf1 == FALSE) {
for (each in 1:values$nrofelements) {
if (ob != each) { sethib(each,0) }
}
values$HL_all_switch_sf1 <- FALSE
}
}
dynamiclist <- as.character(unlist(dhbs$el), use.names = FALSE)
print(paste0("dl = ", toString(dynamiclist)))
print(paste("ob =", ob ))
lastclicked_button_nr <- ob
colorpalette <- vector(mode="character", length=values$nrofelements)
colorpalette <- replace(colorpalette, colorpalette == "", "GREY")
colorpalette[values$button_nr_clicked]="RED"
print( "-----------next click event prints the below this line--------------------------------------------------------------")
})
})
})
#### OBSERVE DYNAMIC UI
observeEvent(input$multi_highlight, { values$HL_multi_switch_sf1 <- !values$HL_multi_switch_sf1 })
observeEvent(input$hightlight_all_button_sf1,{
values$HL_all_switch_sf1 <- !values$HL_all_switch_sf1;
for (any in 1:values$nrofelements) { dhbs$el[[hibutname(any)]] <- as.integer(values$HL_all_switch_sf1) }
colorpalette <- NULL
colorpalette <- vector(mode="character", length=values$nrofelements)
colorpalette <- replace(colorpalette, colorpalette == "", "RED")
})
### button to print the status of Multi and All on console to check what they are
observeEvent(input$statuscheck, {
print(paste("ALL switch: ", values$HL_all_switch_sf1))
print(paste("MULTI switch: ", values$HL_multi_switch_sf1))
})
output$values <- renderPrint(as.character(unlist(dhbs$el), use.names = FALSE))
output$clickcount <- renderPrint(values$clickcount)
}
options(shiny.reactlog = TRUE)
shinyApp(ui,shinyServer)
Screenshot:

drop-down checkbox input in shiny

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!

Resources