We Keep Coding

Set an alert when all boxes are closed or collapsed in shinydashboardPlus

I have a shinydashboard with 10 boxes, and which can be closed or collapsed. All the box id starts with "box". I was trying set an alert button when all boxes are closed or collapsed.
Below is the code of the dashboard:
library(shiny)
library(shinydashboardPlus)
box_create <- function(i){
shinydashboardPlus::box(tags$p(paste0("Box",i)),
id = paste0("box", i),
closable = TRUE,
collapsible = TRUE)
}
all_box <- purrr::map(1:10, ~box_create(.x))
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
all_box
)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
I have noticed on pressing close or collapse button shiny sets the display = 'none' for that box.
So is it possible to extract all styles associated with the id which starts with 'box' and check if all the style property sets as 'none' using jQuery?

Using shinydashboardPlus's dev version you can access the box state via it's id (pattern: input$mybox$collapsed).
Please see this related article.
Install it via devtools::install_github("RinteRface/shinydashboardPlus")
library(shiny)
library(tools)
library(shinydashboard)
library(shinydashboardPlus)
box_ids <- paste0("box", 1:10)
box_create <- function(box_id){
shinydashboardPlus::box(tags$p(toTitleCase(box_id)),
id = box_id,
closable = TRUE,
collapsible = TRUE)
}
all_boxes <- lapply(box_ids, box_create)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
all_boxes
)
)
server <- function(input, output, session) {
observe({
if(all(sapply(box_ids, function(box_id){input[[box_id]]$collapsed}))){
showModal(modalDialog("All boxes are collapsed!"))
}
})
# observe({
# print(paste("Is box1 collapsed?", input$box1$collapsed))
# })
}
shinyApp(ui, server)

I thought you wanted a button when all were collapsed OR all were closed. Here is a solution for that.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
box_create <- function(i){
shinydashboardPlus::box(tags$p(paste0("Box",i)),
id = paste0("box", i),
closable = TRUE,
collapsible = TRUE)
}
all_box <- purrr::map(1:10, ~box_create(.x))
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
all_box,
div(id = "alert_button")
)
)
server <- function(input, output, session) {
observe({
boxes <- paste0("box", 1:10)
visible_status <- sapply(boxes, \(x) input[[x]]$visible)
collapsed_status <- sapply(boxes, \(x) input[[x]]$collapsed)
if (!any(visible_status) || all(collapsed_status)) {
insertUI(
selector = "#alert_button",
ui = div(id = "added", actionButton("btn","all hidden OR all collapsed"))
)
} else {
removeUI(selector = "#added")
}
})
}
shinyApp(ui, server)

Onclick feature on the action button to slide the slidebar [duplicate]

This question already has an answer here:
Toggle display of sidebar menu in shinydashboard programmatically
(1 answer)
Closed 7 months ago.
Below application has sidebar open by default. Is there a way to make it close by default and slide when the user clicks on "Release" button.
So when the user clicks again on teh button, the side bar should slide inside and this is on and off type. Can we achieve this
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
),
box(actionButton("release", "Release"))
)
)
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
}
shinyApp(ui, server)

A version using the onclick event:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(collapsed = TRUE),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
),
box(actionButton("release", "Release", onclick = "$('body').toggleClass('sidebar-collapse');"))
)
)
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
}
shinyApp(ui, server)

Disable selectInput and menu while shiny is busy

I would like to disable menu items and selectInput, while my Shiny app is loading. I have managed to disable buttons and textInput with some javacript (cf. Disable elements when Shiny is busy), but I can't get it to work with selectInput and menus. I'm not interested in alternatives solutions.
library(shiny)
js <- "$(document).on('shiny:busy', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', false);
});"
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
tags$head(tags$script(js)),
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
actionButton("buttonID","This adds 10 seconds of Sys.sleep"),
textInput("textID","Write text here..."),
selectInput("selectID","This should be disables while loading",choices=c("A","B","C"))
)
)
)
server <- function(input, output) {
observeEvent(input$buttonID,{
Sys.sleep(10)
})
}
shinyApp(ui, server)

Theres easier way of disabling widgets using shinyjs package. theres a reactiveValuesToList function which will collect all the reactivesinputs you have within the session and you can simply use that:
library(shiny)
library(shinyjs)
ui <- fluidPage(
titlePanel("Hello Shiny!"),
useShinyjs(),
sidebarLayout(
sidebarPanel(
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
actionButton("buttonID","This adds 5 seconds of Sys.sleep"),
textInput("textID","Write text here..."),
selectInput("selectID","This should be disables while loading",choices=c("A","B","C"))
)
)
)
server <- function(input, output) {
observeEvent(input$buttonID,{
myinputs <- names(reactiveValuesToList(input))
print(myinputs)
for(i in 1:length(myinputs)){
disable(myinputs[i])
}
Sys.sleep(5)
for(i in 1:length(myinputs)){
enable(myinputs[i])
}
})
}
shinyApp(ui, server)

ANSWER A)
The simple answer to your question is to set selectize = FALSE in your selectInput.
In the shiny docs, it's stated that the selectInput function uses the selectize.js JavaScript library by default (see below).
"By default, selectInput() and selectizeInput() use the
JavaScript library selectize.js
(https://github.com/brianreavis/selectize.js) to instead of the basic
select input element. To use the standard HTML select input element,
use selectInput() with selectize=FALSE."
By setting selectize = FALSE you are instead using the standard HTML select input element. This, in turn, is now picked up by your jquery var $inputs = $('button,input,select,ul');. I'm not sure why the element is not picked up when using the selectize.js library.
See the below example. Note that the selectInput options look different when using the html standard (not as nice aesthetically imo).
# ANSWER A)
library(shiny)
js <- "$(document).on('shiny:busy', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', false);
});"
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
tags$head(tags$script(js)),
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
actionButton("buttonID", "This adds 3 seconds of Sys.sleep"),
textInput("textID", "Write text here..."),
selectInput("selectID", "This should be disables while loading", choices=c("A","B","C"), selectize = FALSE)
)
)
)
server <- function(input, output) {
observeEvent(input$buttonID,{
Sys.sleep(3)
})
}
shinyApp(ui, server)
ANSWER B)
Below is how I got the selectize.js selectInput to disable when shiny is busy, as per your question, using the conditionalPanel. It's a bit of a hacky solution, but works well.
Note that I am creating two selectInputs which are similar. One is initialised as disabled using the shinyjs package. This is the one that is displayed when shiny is busy. Using jquery snippet $('html').hasClass('shiny-busy') we make use of the shiny-busy class applied when shiny is busy performing logic on the server side. When this class is removed (i.e. when shiny is idle) the conditionalPanel swaps in the other selectInput UI element that is not disabled.
# EXAMPLE B)
library(shiny)
library(shinyjs)
js <- "$(document).on('shiny:busy', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', false);
});"
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
tags$head(tags$script(js)),
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
useShinyjs(),
actionButton("buttonID", "This adds 3 seconds of Sys.sleep"),
textInput("textID", "Write text here..."),
#selectInput("selectID", "This should be disables while loading", choices=c("A","B","C"), selectize = FALSE)
div(
conditionalPanel(
condition="$('html').hasClass('shiny-busy')",
shinyjs::disabled(
selectInput(
inputId = 'selectID_disabled', # note the addition of "_disabled" as IDs need to be unique
label = "This should be disables while loading",
choices = "Loading...",
selected = NULL,
selectize = TRUE,
width = 250,
size = NULL
)
)
),
conditionalPanel(
condition="$('html').hasClass('')",
selectInput(
inputId = 'selectID',
label = "This should be disables while loading",
choices = c("A","B","C"),
selected = NULL,
selectize = TRUE,
width = 250,
size = NULL
)
),
style = "margin-top:20px;"
),
)
)
)
shinyServer(function(input, output, session) {
observeEvent(input$buttonID,{
Sys.sleep(3)
})
})
shinyApp(ui, server)

Shiny - dashboardPage - how can I add a button to box header

Using dashboardPage I made a dashboard made out of boxes.
I would like to be able to click somewhere on the header of a box to trigger some action. The only case I know where the header has a button is the case of expandable boxes. Would it be possible to generalize that so that, upon a click somewhere in the header of a box, some action is triggered?
My design goal is to have the info in the box update when the user clicks on this button, i.e., to have the content of the box change.
Thanks!
body <- dashboardBody(
fluidRow(
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "primary",
"Box content"
),
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "warning",
"Box content"
)
)
)
# We'll save it in a variable `ui` so that we can preview it in the console
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(),
body
)
# Preview the UI in the console
shinyApp(ui = ui, server = function(input, output) { })

If you want a button in the right corner of the box header you could modify the original box function or you could use some JavaScript to add the button after the creation of the box.
An even simpler solution is to create a box title with an actionLink or with an actionButton. Bellow is a example for both cases. The first box has an actionLink as title, when the user clicks on it, the content of the box is updated. On the second box the title is created with plain text and with a small actionButton that will also update the box content. For the second box you could add some custom style to create a header of the same size of a normal box.
library(shiny)
library(shinydashboard)
body <- dashboardBody(
fluidRow(
box(
title = actionLink("titleId", "Update", icon = icon("refresh")),
width = 4, solidHeader = TRUE, status = "primary",
uiOutput("boxContentUI")
),
box(
title = p("Title 1",
actionButton("titleBtId", "", icon = icon("refresh"),
class = "btn-xs", title = "Update")
),
width = 4, solidHeader = TRUE, status = "warning",
uiOutput("boxContentUI2")
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(),
body
)
server = function(input, output, session) {
output$boxContentUI <- renderUI({
input$titleId
pre(paste(sample(letters,10), collapse = ", "))
})
output$boxContentUI2 <- renderUI({
input$titleBtId
pre(paste(sample(LETTERS,10), collapse = ", "))
})
}
shinyApp(ui = ui, server = server)

update column visibility in DT::datatable while using DT::replaceData

Is there a way (other than a 'colvis' button) to dynamically update which columns are visible in a DT::datatabe while using the DT::replaceData to update the table?
(The reason I can not use the 'colvis' button (as shown here:https://rstudio.github.io/DT/extensions.html) is I need to have a few different short cut convenient buttons that hide and show multiple complex patterns at once.)
This is an example of how I would initiate my app. Is there a way in js or the server-side to hide and show columns? Thanks!
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(2, actionButton('refresh', 'Refresh Data', icon = icon('refresh'))),
column(10, DT::dataTableOutput('foo'))
)
),
server = function(input, output, session) {
df = iris
n = nrow(df)
df$ID = seq_len(n)
loopData = reactive({
input$refresh
df$ID <<- c(df$ID[n], df$ID[-n])
df
})
output$foo = DT::renderDataTable(isolate(DT::datatable(loopData(),
options = list(
columnDefs = list(list(visible=FALSE,targets=c(0,1,2))))
)))
proxy = dataTableProxy('foo')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
}
)