How can I disable all action buttons while shiny is busy and loading text is displayed
I am not familiar with a simple way to do what you are describing, but of course that does not mean there is none ;) Here is a little workaround that I believe matches your requirements, and keeps your code relatively clean. We can use reactiveValuesToList(input) to get a list of our inputs, and then write a function that disables or enables them all. We can also decide to only toggle button inputs by subsetting the list based on attributes.
Working example below, hope this helps!
library(shiny)
library(shinyjs)
ui <- fluidPage(
h3('Disable all inputs while running'),
actionButton('btn_all_inputs','Run long process'),
h3('Disable only buttons while running'),
actionButton('btn_only_buttons','Run long process'),
hr(),
h3('Inputs'),
textInput('text1', 'Text1',"my text:"),
actionButton('btn1','Button 1'),
actionButton('btn2','Button 2'),
actionButton('btn3','Button 3'),
sliderInput('slid3','Slider 1',min=0,max=1,value=0.5),
useShinyjs()
)
server <- function(input, output, session){
# Function to toggle input elements.
# input_list: List of inputs, reactiveValuesToList(input)
# enable_inputs: Enable or disable inputs?
# Only buttons: Toggle all inputs, or only buttons?
toggle_inputs <- function(input_list,enable_inputs=T,only_buttons=FALSE)
{
# Subset if only_buttons is TRUE.
if(only_buttons){
buttons <- which(sapply(input_list,function(x) {any(grepl('Button',attr(x,"class")))}))
input_list = input_list[buttons]
}
# Toggle elements
for(x in names(input_list))
if(enable_inputs){
shinyjs::enable(x)} else {
shinyjs::disable(x) }
}
observeEvent(input$btn_all_inputs,{
input_list <- reactiveValuesToList(input)
toggle_inputs(input_list,F,F)
Sys.sleep(5)
toggle_inputs(input_list,T,F)
})
observeEvent(input$btn_only_buttons,{
input_list <- reactiveValuesToList(input)
toggle_inputs(input_list,F,T)
Sys.sleep(5)
toggle_inputs(input_list,T,T)
})
}
shinyApp(ui = ui, server = server)
Alternative solution
This solution uses custom JavaScript to enable/disable all inputs based on if Shiny is busy or idle. This will thus disable your inputs anytime Shiny is busy. I now set the script to disable all buttons, but you can easily extend it by adding more selections to document.getElementsByTagName(). Hope this comes closer to what you had in mind.
library(shiny)
ui <- fluidPage(
h3('Disable buttons while running'),
actionButton('btn_run','Run long process'),
hr(),
h3('Inputs'),
textInput('text1', 'Text1',"my text:"),
actionButton('btn1','Button 1'),
sliderInput('slid3','Slider 1',min=0,max=1,value=0.5),
includeScript('script.js')
)
server <- function(input, output, session){
observeEvent(input$btn_run,{
Sys.sleep(5)
})
}
shinyApp(ui = ui, server = server)
script.js
$(document).on("shiny:busy", function() {
var inputs = document.getElementsByTagName("button");
console.log(inputs);
for (var i = 0; i < inputs.length; i++) {
inputs[i].disabled = true;
}
});
$(document).on("shiny:idle", function() {
var inputs = document.getElementsByTagName("button");
console.log(inputs);
for (var i = 0; i < inputs.length; i++) {
inputs[i].disabled = false;
}
});
Disable elements when Shiny is busy
I cannot help you with the close button, though I found out that as soon as you set your shiny:idle handle, any call to JavaScript will fire shiny:idle and hence runs the handler instead of the JavaScript code behind toggleDropdownButton.
However, the first question of how to select more than one element in your JavaScript can be solved with a bit of jQuery. Change your code to
$(document).on('shiny:busy', function() {
var $inputs = $('button,input');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input');
console.log($inputs);
$inputs.prop('disabled', false);
})
With that you can select buttons and the text input. Now you can find out yourself which code to use to also disable the dropdown.
BTW: maybe you want to look at shinyjs::disable. With this function you can disable your controls from the R side. You would put that in the beginning of your long calculation and use shinyjs::enable at the end.
How to prevent user from doing anything on shiny app when app is busy
After analyzing yours answers and think more about it, I think I found the simpliest solution.
On "shiny busy" event, I display a div in the conditional panel which is 100% of the screen and on first plan, so it prevents any click on the inputs / outputs behind it. When the app is not busy anymore, the panel disappear. The panel is transparent so the user doesn't see it.
Also, it enables me to disable all inputs and output without being dependant of a timer, only on if the app is busy or not.
library(shiny)
ui <- fluidPage(
# spinner css
tags$head(
tags$style(HTML("
#loadmessage {
position:fixed; z-index:8; top:50%; left:50%; padding:10px;
text-align:center; font-weight:bold; color:#000000; background-color:#CCFF66;
}
.loader {
position:fixed; z-index:8; border:16px solid #999999;
border-top: 16px solid #8B0000; border-radius: 50%;
width: 120px; height: 120px; top:45%; left:45%;
animation: spin 2s linear infinite;
}
.prevent_click{
position:fixed;
z-index:9;
width:100%;
height:100vh;
background-color: transpare'nt;
}
@keyframes spin {
0% { transform: rotate(0deg); }
100% { transform: rotate(360deg); }
}"))
),
# display load spinner when shiny is busy
conditionalPanel(
condition = "$(\'html\').hasClass(\'shiny-busy\')",
tags$div(class = "loader"),
tags$div(class = "prevent_click")
),
actionButton(
inputId = "increment",
label = "Increment"
),
textOutput("result"),
actionButton(
inputId = "busy",
label = "Busy app"
)
)
server <- function(input, output, session) {
rv <- reactiveValues(counter = 0)
#increment counter
observeEvent(input$increment,{
rv$counter = rv$counter + 1
})
#display incremented counter
output$result <- renderText({
rv$counter
})
observeEvent(input$busy, {
Sys.sleep(5)
# during this time, the user should not be able to do anything on the app
})
}
shinyApp(ui = ui, server = server)
Only activate actionButton when Shiny app is not busy
You can disable button after it is clicked and enable it again on exit. It can be done manually but shinyjs already provides required helpers.
If function called on click may fail you can use tryCatch with finally to make sure that your app won't stay in the disabled state:
library(shiny)
library(shinyjs)
foo <- function() {
Sys.sleep(4)
x <- runif(1)
if(x < 0.5) stop("Fatal error")
print(x)
}
shinyApp(
ui=shinyUI(bootstrapPage(
useShinyjs(),
actionButton("go", "GO")
)),
server=shinyServer(function(input, output, session){
observe({
if(input$go == 0) return()
shinyjs::disable("go")
tryCatch(
foo(),
error = function(e) return(),
finally = shinyjs::enable("go")
)
})
})
)
disable actionButton until a new set of options are selected shiny
The observeEvent with the toggleState line is never triggered, which is weird.
It looks like there is an issue with using observeEvent with multiple inputs that are generated by renderUI.
There is a workaround, try using:
observeEvent({
input$SepalLength != NULL |
input$SepalWidth != NULL |
input$Species != NULL
},{
showNotification("triggered")
})
Here is your full code. I used shinyjs to enable/disable the button. In general I would suggest avoiding renderUI unless you can't do without it. You are already using updateSelectInput etc which can handle most things.
library(shiny)
library(vroom)
library(dplyr)
library(shinycssloaders)
library(shinydashboard)
library(shinydashboardPlus)
library(tidyr)
library(shinyjs)
header <- dashboardHeader()
sidebar <- dashboardSidebar(width = 450,
sidebarMenu(id = "tabs",
menuItem(
"Filtros",
tabName = "filtros",
icon = icon("bar-chart-o")
),
uiOutput("filtros")
))
body <- dashboardBody(tabItems(tabItem(tabName = "filtros",
fluidRow(
column(12,
DT::dataTableOutput("tabla_julio") # %>% withSpinner(color = "#0dc5c1")
)
))))
ui <-
dashboardPagePlus(
enable_preloader = FALSE,
sidebar_fullCollapse = TRUE,
header,
sidebar,
body,
useShinyjs()
)
server = function(input, output, session) {
# Create the choices for sample input
vals <- reactiveValues(data = iris, filtered_data = iris)
output$filtros <- renderUI({
datos <- isolate(vals$data)
conditionalPanel(
"input.tabs == 'filtros'",
tagList(
div(
style = "display: inline-block;vertical-align:top; width: 221px;",
numericInput(
inputId = "SepalLength",
label = "Sepal.Length",
value = NA,
min = NA,
max = NA,
step = NA
)
),
div(
style = "display: inline-block;vertical-align:top; width: 221px;",
numericInput(
inputId = "SepalWidth",
label = "Sepal.Width",
value = NA,
min = NA,
max = NA,
step = NA
)
),
div(
div(
style = "display: inline-block;vertical-align:top; width: 224px;",
selectInput(
inputId = "Species",
label = "Species",
width = "220",
choices = unique(isolate(datos$Species)),
selected = NULL,
multiple = TRUE,
selectize = TRUE,
size = NULL
)
)
)
),
actionButton("filtrar", "Filter", style = "width: 100px;"),
actionButton("reset", "Reset", style = "width: 100px;")
)
})
# Filter data
observeEvent(input$filtrar, {
tib <- vals$data
if (!is.na(input$SepalLength)) {
tib <- tib %>% dplyr::filter(Sepal.Length < input$SepalLength)
print(head(tib))
} else {
tib
}
if (!is.na(input$SepalWidth)) {
tib <- tib %>% dplyr::filter(Sepal.Width > input$SepalWidth)
print(head(tib))
} else {
tib
}
# Filter
if (!is.null(input$Species)) {
tib <- tib %>% dplyr::filter(Species %in% input$Species)
} else {
tib
}
print(head(tib, n = 15))
vals$filtered_data <- tib
updateSelectInput(session, inputId = "Species", selected = input$Species, choices = unique(vals$filtered_data$Species))
#Disable filter button
shinyjs::disable("filtrar")
})
observeEvent(input$reset, {
updateNumericInput(session, inputId = "SepalLength", value = NA)
updateNumericInput(session, inputId = "SepalWidth", value = NA)
updateSelectInput(session, inputId = "Species", selected = "")
})
observeEvent({
input$SepalLength != NULL |
input$SepalWidth != NULL |
input$Species!= NULL
},{
shinyjs::enable("filtrar")
})
# Reactive function creating the DT output object
output$tabla_julio <- DT::renderDataTable({
DT::datatable(vals$filtered_data)
}, server = FALSE)
}
shinyApp(ui, server)
How to disable button based on a condition in a R Markdown document with shiny elements?
Took me awhile to find it, but you have to enable shinyjs to use R-markdown explicitly, it needs to setup its javascript differently in this case.
You do this by calling: useShinyjs(rmd=T) in the chunk where you are using it.
---
title: "Disable Button"
runtime: shiny
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(shinyjs)
library(shiny)
```
```{r, echo=FALSE}
useShinyjs(rmd=T)
checkboxGroupInput("param_group", label = h3("Letters"),
choices = LETTERS[1:8])
actionButton('action', "Print")
result<-reactive({
length(input$param_group)
})
observe({
useShinyjs()
if(result()>1 & result()<=5){
enable("action")
} else {
disable("action")
}
})
txt<-eventReactive(input$action,{
cat("Number of letters selected: ",length(input$param_group))
})
renderPrint({
txt()
})
Screen shot:
R shiny: display loading... message while function is running
I'm already using a simpler and more reliable way than the one I posted before.
A combination of
tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 0px;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
")
with
conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage")
)
Example:
runApp(list(
ui = pageWithSidebar(
headerPanel("Test"),
sidebarPanel(
tags$head(tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 0px;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
")),
numericInput('n', 'Number of obs', 100),
conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage"))
),
mainPanel(plotOutput('plot'))
),
server = function(input, output) {
output$plot <- renderPlot({ Sys.sleep(2); hist(runif(input$n)) })
}
))
tags$head() is not required, but it's a good practice to keep all the styles inside head tag.
Enabling and disabling ActionButton dynamically in RShiny
Updated the code with disable and enable of shinyjs and also to account the condition of work week selection.
require(shiny)
require(shinyjs)
#install.packages("shinyjs")
ui = fluidPage( useShinyjs(),
inlineCSS(list('.lightpink' = "background-color: lightpink", ".hide1"="display:none",'.red' = "background-color: red", "textarea" = 'text-align: center', '#text3 ' = 'text-align: center', '.form-control' = 'padding:8.5px ')),
fluidRow(
column(3,numericInput("count", "No. of boxes",value = 3, min = 2, max = 10),actionButton("View","view")
),
column(3, actionButton("submit", "Complete"))
),
fluidRow(
column(3,tags$h3("Actual Work Hours")
),
column(3, wellPanel(
numericInput("current", "Current Week",value = 40, min = 40, max = 80)
)),
column(3, wellPanel(
numericInput("next1", "Next Week", value = 40, min = 40, max = 80)
)),
column(3, wellPanel(
numericInput("next2", "Two weeks from now", value = 40, min = 40, max = 80)
))),
fluidRow(
column(3,tags$h3("About Your Work-Week")
),
column(3, wellPanel(
selectizeInput("sel1", "How was your current week?",
choices = c("aa",
"bb",
"cc"),
options = list(
placeholder = "Current week",
onInitialize = I('function() { this.setValue(""); }')
)))),
column(3, wellPanel(
selectizeInput("sel2", "How busy will be the next week?",
choices = c("aa",
"bb",
"cc"),
selected = NULL,
options = list(
placeholder = "Next week",
onInitialize = I('function() { this.setValue(""); }')
)))),
column(3, wellPanel(
selectizeInput("sel3", "How busy will be the next two weeks?",
choices = c("aa",
"bb",
"cc"),
options = list(
placeholder = "Next two week",
onInitialize = I('function() { this.setValue(""); }')
))))),
fluidRow(uiOutput("inputGroup")),
fluidRow(column(3,wellPanel(textOutput("text3")),
tags$head(tags$style("#text3{color: white;
font-style: italic;
}"
)
)))
)
# takes in two arguments
sumN <- function(a, x){
a <- sum(a, as.numeric(x),na.rm=T)
return(a)
}
server <- function(input, output, session) {
Widgets <- eventReactive(input$View,{ input_list <- lapply(1:(input$count),
function(i) {
inputName <- paste("id", i, sep = "")
textInputRow <- function (inputId,value) {
textAreaInput(inputName,"", width = "200px", height = "43px", resize = "horizontal" )
#numericInput(inputName,"",1,0,100)
}
column(4,textInputRow(inputName, "")) })
do.call(tagList, input_list)},ignoreInit = T)
output$inputGroup = renderUI({Widgets()})
getvalues <- reactive({
val <- 0
for(lim in 1:input$count){
observeEvent(input[[paste0("id",lim)]], {
updateTextAreaInput(session,paste0("id",lim), value = ({
x = as.numeric(input[[paste0("id",lim)]])
if(!(is.numeric(x))){0}
else if(!(is.null(x) || is.na(x))){
if(x < 0){
0
}else if(x > 100){
100
} else{
return (isolate(input[[paste0("id",lim)]]))
}
}
else if((is.null(x) || is.na(x))){
0
}
})
)
})
req(as.numeric(input[[paste0("id",lim)]]) >= 0 & as.numeric(input[[paste0("id",lim)]]) <= 100)
val <- sumN(val,as.numeric(input[[paste0("id",lim)]]))
}
val
})
output$text3 <- renderText({
getvalues()
})
observeEvent(getvalues(), {
nn <- getvalues()
if(is.numeric(as.numeric(nn)) & !is.na(as.numeric(nn)) & nn == 100) {
removeClass("text3", 'red')
addClass('text3','lightpink')
if(input$sel1 != "" & input$sel2 != "" & input$sel3 != "") {
enable('submit')
}
#removeClass('submit','hide1')
} else { addClass('text3','red'); #addClass('submit','hide1');
disable('submit')
}
})
}
shinyApp(ui=ui, server = server)
Related Topics
External Style Sheets, Specifying Absolute or Relative Paths
Why Does Vertical-Align: Text-Top Make Element Go Down
How to Change Bootstrap Select Arrows to Glyphicon
How Does the "Display: Contents" Property Value Work
What CSS Should I Use to Get a Border Around an Option Tag in Both Firefox and Ie
Display: Flex - Not Working in Firefox 21
Css: Borders with Negative Radius
Like Whatsapp, How to Make an Input That Extends to Upwards as You Type
Listitem Disc Displaying at Vertical Bottom
Set Child Width Relative to Its Parents Height in Pure CSS
How to Collapse/Expand a Div Within an Email? What Clients Support This
Make Flex Item Wrap to the Next Row with Following Items Continuing the Flow
How to Apply a Fade Away Effect (Not Animation) Across All the Content of a Div
Aligning Elements in Last Flexbox Row
How to Center Something If I Don't Know Ahead of Time What the Width Is