Adjust size of Shiny progress bar and center it - css

I'm working with a Shiny app where I need to calculate processes and while the calc progress is executing, I'm using a progressBar to show the process.
The problem is that the progress bar is too small, and I don't like the way is shown.
So, I was thinking that maybe there's a way to implement a progress bar using a Shiny modal (there's a function called modalDialog).
My idea is that when the user runs the calc, a modal will be opened showing a progressBar.
This is the progress code:
withProgress(message = 'Runing GSVA', value = 0, {
incProgress(1, detail = "This may take a while...")
functionToGenerate()
})
Any idea?

I would suggest customizing the CSS class of the notification:
If you inspect the element of the notifier you see that it has the class "shiny-notification". So you can overwrite some properties of that class with tags$style(). In the example below (for the template: see ?withProgress) i decided to adjust height+width to make it bigger and top+left to center it.
ui <- fluidPage(
tags$head(
tags$style(
HTML(".shiny-notification {
height: 100px;
width: 800px;
position:fixed;
top: calc(50% - 50px);;
left: calc(50% - 400px);;
}
"
)
)
),
plotOutput("plot")
)
server <- function(input, output) {
output$plot <- renderPlot({
withProgress(message = 'Calculation in progress',
detail = 'This may take a while...', value = 0, {
for (i in 1:15) {
incProgress(1/15)
Sys.sleep(0.25)
}
})
plot(cars)
})
}
runApp(shinyApp(ui, server), launch.browser = TRUE)

I wrote a progress bar function in the package shinyWidgets, you can put it in a modal, but it's tricky to use with shiny::showModal, so you can create your own modal manually like the below. It's more code to write but it works fine.
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)

Related

Shiny R : What is the problem with nested observEvent?

I am new to shiny and am currently trying to develop my first shinyapp.
This apps contains multiple actionButtons and nested observeEvents statements, which I think are the cause of my problem.
The app should allow the user to add observations of species by clicking on a add button, that updates the UI. Within each observation, more details can be asked, but I only showed the species name in the REPREX below (textinput).
Each observation can be deleted individually via a delete button.
Until here, it works! However, I also want a modal dialog to confirm the deletion when the delete button is clicked. To do this, I used a nested observeEvent and it doesn't seem to work (or maybe only for the first time). What am I doing wrong ?
Thanks in advance to anyone who tries to help me.
library(shiny)
library(random)
ui <- fluidPage(
fluidRow(br(), br(), actionButton("adder",
label = "Add an observation"),
align="center")
)
server <- function(input, output,session) {
rv <- reactiveValues()
rv$GridId_list <- c()
observeEvent(input$adder,{
# create random ID for each added species
GridId <- as.character(randomStrings(1, 10))
# store the new ID
rv$GridId_list <- c(rv$GridId_list,GridId)
# ID for the textinput
SpId <- paste(GridId, "sp", sep="_")
# ID of the button used to remove this species
removeSpeciesId <- paste(GridId,'remover', sep="_")
#Update of the UI
insertUI(
selector = '#adder',
where = "beforeBegin",
ui = tags$div(
id = GridId,
fluidRow(
column(6,
h5("Species name : "),
textInput(SpId,label = NULL)
),
column(6, align = "center",
br(),br(),
actionButton(removeSpeciesId,
label = "Delete")
)
)
)
)
# Remove an observation when the "delete" button is clicked (and after confirmation)
observeEvent(input[[removeSpeciesId]], {
#Confirmation modal
showModal(
modalDialog(
"Are you sure ?",
title = "Delete",
footer = tagList(
actionButton("cancel", "Cancel"),
actionButton("confirm", "Confirm", class = "btn btn-danger")
)
)
)
# Delete observation if user confirms
observeEvent(input$confirm, {
id_to_remove <- substring(removeSpeciesId,1, nchar(removeSpeciesId)-8)
rv$GridId_list <- rv$GridId_list[rv$GridId_list!=id_to_remove]
removeUI(selector = paste("#", id_to_remove, sep = ""))
showNotification("Observation deleted !")
removeModal()
})
# Just remove the modal if user cancels
observeEvent(input$cancel, {
removeModal()
})
})
})
}
shinyApp(ui = ui, server = server, options = list(launch.browser = T))
Referencing dynamic input id's is a pain. I find it best to add a last clicked input identifier to reference. You can add a class to those inputs to just listen to them and not others in your app:
tags$head(tags$script(HTML("$(document).on('click', '.needed', function () {
Shiny.onInputChange('last_btn',this.id);
});")))
That little piece of code will allow you to get an input$last_btn id, that you can use for your event listeners. In this case you don't need to nest your event listeners; it is better to think about the events in sequence and program those reactions. So, with some tweakings in your code, your app now looks like this:
library(shiny)
library(random)
ui <- fluidPage(
tags$head(tags$script(HTML("$(document).on('click', '.needed', function () {
Shiny.onInputChange('last_btn',this.id);
});"))),
fluidRow(br(), br(), actionButton("adder",
label = "Add an observation"),
align="center")
)
server <- function(input, output,session) {
rv <- reactiveValues()
rv$GridId_list <- c()
observeEvent(input$adder,{
# create random ID for each added species
GridId <- as.character(randomStrings(1, 10))
# store the new ID
rv$GridId_list <- c(rv$GridId_list,GridId)
# ID for the textinput
SpId <- paste(GridId, "sp", sep="_")
# ID of the button used to remove this species
removeSpeciesId <- paste(GridId,'remover', sep="_")
#Update of the UI
insertUI(
selector = '#adder',
where = "beforeBegin",
ui = tags$div(
id = GridId,
fluidRow(
column(6,
h5("Species name : "),
textInput(SpId,label = NULL)
),
column(6, align = "center",
br(),br(),
actionButton(removeSpeciesId,
label = "Delete", class="needed")
)
)
)
)
})
# Remove an observation when the "delete" button is clicked (and after confirmation)
observeEvent(input$last_btn, {
observeEvent(input[[input$last_btn]] > 0,{#We want the modal to show when any "remover" id is clicked
#Confirmation modal
showModal(
modalDialog(
"Are you sure ?",
title = "Delete",
footer = tagList(
actionButton("cancel", "Cancel"),
actionButton("confirm", "Confirm", class = "btn btn-danger")
)
)
)
})
}, ignoreNULL = TRUE, ignoreInit = TRUE)
# Delete observation if user confirms
observeEvent(input$confirm, {
#The following selector is for the parent id of the parent id of the last_btn id
removeUI(selector = paste0("div:has(>div:has(>#", input$last_btn, "))"))
showNotification("Observation deleted !")
removeModal()
})
# Just remove the modal if user cancels
observeEvent(input$cancel, {
removeModal()
})
}
shinyApp(ui = ui, server = server, options = list(launch.browser = T))

Why is removeUI leaving behind the UI label?

I am trying to increase and decrease the number of UI elements based on user input. This MRE code kind of works but it is leaving behind the UI label when I use removeUI, which I did not expect. Any ideas on how to make the label go away along with the input box?
## Only run this example in interactive R sessions
if (interactive()) {
# Define UI
ui <- fluidPage(
numericInput(inputId = "assessors",label = "Number of Assessors",value = 1,min = 1,step = 1),
textInput(inputId = "assessor1",label = "Assessor 1 Columns")
)
# Server logic
server <- function(input, output, session) {
tot_app<-0
observeEvent(input$assessors, {
num<-input$assessors
if(num>tot_app){#add
adds<-seq(tot_app+1,num)
for(i in adds){
here<-paste0("#assessor",i-1)
insertUI(
selector = here,
where = "afterEnd",
ui = textInput(paste0("assessor", i),
paste0("Assessor ",i," columns"))
)
}
tot_app<<-num
} else if(num<tot_app){#subtract
subs<-seq(num+1,tot_app)
for(i in subs){
removeUI(selector = paste0("#assessor",i))
}
tot_app<<-num
}
})
}
# Complete app with UI and server components
shinyApp(ui, server)
}
As in the help example, it works if you use use this syntax:
removeUI(selector = paste0("div:has(> #assessor",i,")"))

RShiny: Hiding / Showing a Table based on Radio Buttons

I have two tables and I'm trying to show one at a time based on user input in radio buttons. If the input from the radio buttons is "table", i'd like to show table1. If the input is else i'd like to show table2.
observeEvent(input$visuBtn,{
req(input$visuBtn)
print(input$visubtn)
if(input$visuBtn == "table"){
hide("table2")
#DT::dataTableOutput("table1")
renderUI(
DT::dataTableOutput("table1")
)
}else{
print("Should show table2")
# removeUI(
# selector = "table"
# )
renderUI(
DT::dataTableOutput("table2")
)
#DT::dataTableOutput("table2")
#show("table2")
}
})
I've tried doing this by showing and hiding the two tables and can't figure out how to get that to work. I"ve also tried using renderUI as well. What would be the best methodology to go about this?
mainPanel(
tabsetPanel(id = "sim.tabset",
tabPanel(title = "Results",
# tableOutput("table")
DT::dataTableOutput("table"),
DT::dataTableOutput("table2")
),
)
Depending on your app, you can toggle the visibility of the table in the frontend with a little bit of javascript. In the UI, create a button and wrap the dataTableOutput in a generic container.
# some where in your UI
actionButton("toggleTable", "Toggle Table"),
tags$div(
id = "tableContainer",
DT::dataTableOutput("table")
)
...
There are many ways to toggle the visibility of an element (changing the display properties, toggling css classes, modifying other attributes, etc.). The following function toggles the html attribute hidden when the button is clicked. This can be defined in the UI using the tags$script function or loaded from an external javascript file.
const btn = document.getElementById('toggle');
const elem = document.getElementById('tableContainer');
btn.addEventListener('click', function(event) {
if (elem.hasAttribute('hidden')) {
elem.removeAttribute('hidden');
} else {
elem.setAttribute('hidden', '');
}
});
In the server, render the datatable as normal and you can remove the toggling (unless you need additional things to happen when the button is clicked).
Here is the full example.
library(shiny)
shinyApp(
ui = tagList(
tags$main(
id = "main",
tags$h1("Collapsible Table Example"),
actionButton("toggleTable", "Toggle Table"),
tags$div(
id = "tableContainer",
DT::dataTableOutput("table")
)
),
tags$script(
type = "text/javascript",
"
const btn = document.getElementById('toggleTable');
const elem = document.getElementById('tableContainer');
btn.addEventListener('click', function(event) {
if (elem.hasAttribute('hidden')) {
elem.removeAttribute('hidden');
} else {
elem.setAttribute('hidden', '');
}
});
"
)
),
server = function(input, output, session) {
output$table <- DT::renderDataTable({
data.frame(
group = sample(c("A", "B"), 20, replace = TRUE),
x = rnorm(n = 20, mean = 50, sd = 2),
y = rnorm(n = 20, mean = 50, sd = 2)
)
})
}
)
I opted to go with a simple solution, just having one table that renders based on the choice of the radiobuttons. Meaning the if/else is just within the renderDataTable function
library(shiny)
library(DT)
ui <- fluidPage(
radioButtons("Buttons", "CHOOSE!", choices = c("MTCARS", "IRIS")),
DT::dataTableOutput("THETABLE")
)
server <- function(input, output, session) {
output$THETABLE<-DT::renderDataTable({
req(input$Buttons)
if(input$Buttons == "MTCARS") {
DT::datatable(mtcars)
} else {
DT::datatable(iris)
}
})
}
shinyApp(ui, server)
Alternatively, you could use conditional panel, so it shows the table based on the radiobutton selection:
library(shiny)
library(DT)
ui <- fluidPage(
radioButtons("Buttons", "CHOOSE!", choices = c("MTCARS", "IRIS")),
conditionalPanel("input.Buttons == 'MTCARS'",
DT::dataTableOutput("TABLEMTCARS")
),
conditionalPanel("input.Buttons == 'IRIS'",
DT::dataTableOutput("TABLEIRIS"))
)
server <- function(input, output, session) {
output$TABLEMTCARS<-DT::renderDataTable({
DT::datatable(mtcars)
})
output$TABLEIRIS<-DT::renderDataTable({
DT::datatable(iris)
})
}
shinyApp(ui, server)

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;
}

How to set up an independent progress bar

I'm trying to include a progress bar during the computations in my shiny application. Description of my problem:
My computation takes a while, like 30 seconds
I'm able to evaluate in advance the exact time a computation will take
however, the computation is in one chunk, not splitable in small parts that I could use to manually increment the progress bar, think of it as a large model fitting process.
Currently there are some questions related to the problem but no satisfying answer:
here, here for instance.
Is there a way to implement an bar that progresses on top of a calculation, independently and continuously, for a fixed amount of time (or maybe insert an animation of the bar in a pop-up that mimics the bar?)
Thanks
Edit: I tried to mimic a progress bar with an animated sliderInput, but I couldn't find how programmatically trigger the animation...
I think this would be a lot easier when Shiny releases its async support. But for now, it'd have to be a custom, client-side JavaScript solution.
My take on it uses the same Bootstrap 3 progress bars that Shiny uses. Out of laziness, I also leveraged Shiny's progress bar CSS classes (top bar style), so this will conflict with Shiny's progress bars. Ideally it'd be a widget with its own styles.
I used jQuery's animate to set the width of the progress bar over a fixed duration. animate has some nice options out of the box like easing. I also let the progress bar linger after 100% by default, thinking it'd be better for the server to explicitly close the progress bar in case the timing isn't exact.
library(shiny)
progressBarTimer <- function(top = TRUE) {
progressBar <- div(
class = "progress progress-striped active",
# disable Bootstrap's transitions so we can use jQuery.animate
div(class = "progress-bar", style = "-webkit-transition: none !important;
transition: none !important;")
)
containerClass <- "progress-timer-container"
if (top) {
progressBar <- div(class = "shiny-progress", progressBar)
containerClass <- paste(containerClass, "shiny-progress-container")
}
tagList(
tags$head(
tags$script(HTML("
$(function() {
Shiny.addCustomMessageHandler('progress-timer-start', function(message) {
var $progress = $('.progress-timer-container');
var $bar = $progress.find('.progress-bar');
$bar.css('width', '0%');
$progress.show();
$bar.animate({ width: '100%' }, {
duration: message.duration,
easing: message.easing,
complete: function() {
if (message.autoClose) $progress.fadeOut();
}
});
});
Shiny.addCustomMessageHandler('progress-timer-close', function(message) {
var $progress = $('.progress-timer-container');
$progress.fadeOut();
});
});
"))
),
div(class = containerClass, style = "display: none;", progressBar)
)
}
startProgressTimer <- function(durationMsecs = 2000, easing = c("swing", "linear"),
autoClose = FALSE, session = getDefaultReactiveDomain()) {
easing <- match.arg(easing)
session$sendCustomMessage("progress-timer-start", list(
duration = durationMsecs,
easing = easing,
autoClose = autoClose
))
}
closeProgressTimer <- function(session = getDefaultReactiveDomain()) {
session$sendCustomMessage("progress-timer-close", list())
}
ui <- fluidPage(
numericInput("seconds", "how many seconds your calculation will last?", value = 6),
progressBarTimer(top = TRUE),
actionButton("go", "Compute")
)
server <- function(input, output, session) {
observeEvent(input$go, {
startProgressTimer(input$seconds * 1000, easing = "swing")
Sys.sleep(input$seconds) # simulate computation
closeProgressTimer()
showNotification("Computation finished!", type = "error")
})
}
shinyApp(ui, server)
Not a complete answer, since my suggestion would be to use progress bars, but I hope it helps a bit.
Here's a way to trigger clicking a slider animate button using some javascript with the shinyjs package:
library(shiny)
library(shinyjs)
jscode <- "
shinyjs.play = function() {
$('.slider-animate-button').trigger('click');
}
"
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jscode),
sliderInput("slider", label = "", width = '600px',
min = 0,
max = 20,
value = 0,
step = 1,
animate = animationOptions(
interval = 100,
playButton = "Play",
pauseButton = "Pause"
)
)
)
server <- function(input, output,session) {
observe( {
js$play()
})
}
shinyApp(ui, server)
Please note that the js code references the slider-animate-button class, so it will trigger every slider animation option in the app.
Thanks to the answer of #GyD, I now propose an improved solution (that has something of a hack I admit).
The long computation is simulated here by a sys.sleep of the desired duration. You see that there is still slider movement during the 'sleep'. I put the animated slider into a RenderUI so we can control the speed:
library(shiny); library(shinyjs); library(shinyWidgets)
jscode <- "
shinyjs.play = function() {
$('.slider-animate-button').trigger('click');
}
"
ui <- fluidPage(
tags$head(tags$style(HTML('.irs-from, .irs-to, .irs-min, .irs-max, .irs-grid-text, .irs-grid-pol, .irs-slider {visibility:hidden !important;}'))),
useShinyjs(), extendShinyjs(text = jscode),
numericInput("seconds", "how many seconds your calculation will last?", value=6),
uiOutput("UI"),
actionButton("go", "Compute"))
server <- function(input, output,session) {
disable("slider")
observeEvent(input$go, priority=10, {
js$play()
Sys.sleep(input$seconds) # simulate computation
showNotification("Computation finished!", type="error")})
output$UI = renderUI({
sliderInput("slider", label = "", width = '300px',min = 0,max = 100,value = 0,step = 1,
post="% done",
animate = animationOptions(
interval = (as.numeric(input$seconds)*8),
playButton = "",
pauseButton = ""))})}
shinyApp(ui, server)
The slider really looks like a bar, doesn't it?

Resources