R shinyjs shinydashboard box uncollapse on radionButtons input

Question

Based on this question R shinyjs shinydashboard box uncollapse on action button input and question How to manually collapse a box in shiny dashboard, I would like to substitute the actionButton with the radioButtons (or selectInput). Below a reproducible example. When I click yes I want box id=B2 and id=B3 to collapse, when I click no, box id =B1 and id =B3 to collapse, and when maybe is clicked, box id=B1 and id=B2 to collapse. With the code below, there is a collapse, but it does not work as intended.

library(shiny)
library(shinyBS)
library(dplyr)
library(shinydashboard)


# javascript code to collapse box
jscode <- "
shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"

#Design sidebar
sidebar <- dashboardSidebar(width = 225, collapsed=F, 
                            sidebarMenu(id="tabs",
                                        menuItem("zz", tabName = "zz", selected=TRUE)))

#Design body 
body <- dashboardBody(shinyjs:::useShinyjs(), 
                      shinyjs:::extendShinyjs(text = jscode),
                      tabItems(
                        tabItem(tabName = "zz", 
                                fluidRow(box(radioButtons('go','Go', choices = c("yes", "no", "maybe"))),
                                         box(id="B1", collapsible=T,  status = "primary", color="blue", solidHeader = T, 
                                             title="Test"),
                                         box(id="B2", collapsible=T,  status = "primary", color="blue", solidHeader = T, 
                                             title="Test2"),
                                         box(id="B3", collapsible=T,  status = "primary", color="blue", solidHeader = T, 
                                             title="Test3")

                                         ))
                        ))

Header <- dashboardHeader()

#Show title and the page (includes sidebar and body)
ui <- dashboardPage(Header, sidebar, body)


server <- shinyServer(function(input, output, session){

  observeEvent(input$go == "yes",

               {js$collapse("B2", "B3")}

  )
  #
  observeEvent(input$go == "no",

               {js$collapse("B1", "B3")}
  )

  observeEvent(input$go == "maybe",

               {js$collapse("B1", "B2")}
  )

})

shinyApp( ui = ui, server = server)

Your collapse function works. To check if a box is collapsed you can use the functionality described here: https://stackoverflow.com/questions/45462614/how-to-see-if-a-shiny-dashboard-box-is-collapsed-from-the-server-side — Wilmar van Ommeren, Mar 18 '19 at 09:45
@Wilmar van Ommeren, yes there is a collapse but it does not work as intended. For example, when yes is selected, only id=B2 and id=B3 should be collapsed. As it is id=B3 is not collapse. — MLavoie, Mar 18 '19 at 10:26
That is because this function does not collapse the boxes, but it toggles them. So if a box is already collapsed it will open instead of staying collapsed. Therefore, you should add a function which checks if the box is already collapsed. — Wilmar van Ommeren, Mar 18 '19 at 10:28
@Wilmar van Ommeren. The link you provided tell if it is collapsed or not. I added the code, but how this function can be implemented to help me fix my problem. I don't know anything about JS. — MLavoie, Mar 18 '19 at 11:18
check out https://cran.r-project.org/web/packages/shinydashboardPlus/vignettes/improved-boxes.html — Aaron C, Aug 16 '23 at 21:35

Wilmar van Ommeren · Accepted Answer · 2019-03-18T11:28:22.557

The collapse function you gave actually toggles the boxes instead of only collapsing them. So you first have to check if a box is already collapsed before you want apply this function. This can be done with the function described here: How to see if a shiny dashboard box is collapsed from the server side.

If you also want to open the remaining box you can use the same functionality.

In addition, you can put everything in a single observer to make your code a bit more consistent.

Working example:

library(shiny)
library(shinyBS)
library(dplyr)
library(shinydashboard)
library(shinyjs)

# javascript code to collapse box
jscode <- "
shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"

collapseInput <- function(inputId, boxId) {
  tags$script(
    sprintf(
      "$('#%s').closest('.box').on('hidden.bs.collapse', function () {Shiny.onInputChange('%s', true);})",
      boxId, inputId
    ),
    sprintf(
      "$('#%s').closest('.box').on('shown.bs.collapse', function () {Shiny.onInputChange('%s', false);})",
      boxId, inputId
    )
  )
}

#Design sidebar
sidebar <- dashboardSidebar(width = 225, collapsed=F, 
                            sidebarMenu(id="tabs",
                                        menuItem("zz", tabName = "zz", selected=TRUE)))

#Design body 
body <- dashboardBody(shinyjs:::useShinyjs(), 
                      shinyjs:::extendShinyjs(text = jscode),
                      tabItems(
                        tabItem(tabName = "zz", 
                                fluidRow(box(radioButtons('go','Go', choices = c("yes", "no", "maybe"))),
                                         box(id="B1", collapsible=T,  status = "primary", color="blue", solidHeader = T, 
                                             title="Test"),
                                         collapseInput(inputId = "iscollapsebox1", boxId = "B1"),
                                         box(id="B2", collapsible=T,  status = "primary", color="blue", solidHeader = T, 
                                             title="Test2"),
                                         collapseInput(inputId = "iscollapsebox2", boxId = "B2"),
                                         box(id="B3", collapsible=T,  status = "primary", color="blue", solidHeader = T, 
                                             title="Test3"),
                                         collapseInput(inputId = "iscollapsebox3", boxId = "B3")
                                ))
                      ))

Header <- dashboardHeader()

#Show title and the page (includes sidebar and body)
ui <- dashboardPage(Header, sidebar, body)

server <- shinyServer(function(input, output, session){
  observeEvent(input$go,{
    box1_collapsed = F
    box2_collapsed = F
    box3_collapsed = F
    if (!is.null(input$iscollapsebox1)){
      box1_collapsed <- input$iscollapsebox1
    }
    if (!is.null(input$iscollapsebox2)){
      box2_collapsed <- input$iscollapsebox2
    }
    if (!is.null(input$iscollapsebox3)){
      box3_collapsed <- input$iscollapsebox3
    }
    if (input$go == 'yes'){
      if (!box2_collapsed){
        js$collapse("B2")}
      if (!box3_collapsed){
        js$collapse("B3")}
      # if you want to open B1
      if (box1_collapsed){
        js$collapse("B1")}
    } else if (input$go == 'no'){
      if (!box1_collapsed){
        js$collapse("B1")}
      if (!box3_collapsed){
        js$collapse("B3")}
      # if you want to open B2
      if (box2_collapsed){
        js$collapse("B2")}
    } else if (input$go == 'maybe'){
      if (!box1_collapsed){
        js$collapse("B1")}
      if (!box2_collapsed){
        js$collapse("B2")}
      # if you want to open B3
      if (box3_collapsed){
        js$collapse("B3")}
    }
  })
})

shinyApp( ui = ui, server = server)

score 0 · Answer 2 · answered Oct 26 '20 at 10:18

You can add the following functions to an external www/custom.js file

closeBox = function(boxid) {
  var box = $('#' + boxid).closest('.box');
  if (!box.hasClass('collapsed-box')) {
    box.find('[data-widget=collapse]').click();
  }
};

openBox = function(boxid) {
  var box = $('#' + boxid).closest('.box');
  if (box.hasClass('collapsed-box')) {
    box.find('[data-widget=collapse]').click();
  }
};

Include the .js file in dashboardBody and call the function in your app script with shinyjs::runjs("openBox('box_id')") or shinyjs::runjs("closeBox('box_id')").

The following is a minimal working example (if you include the javascript above in a file called custom.js in a directory called www in the app directory).

library(shiny)
library(shinyjs)
library(shinydashboard)

ui <- dashboardPage(
    skin = "red",
    dashboardHeader(title = "Demo"),
    dashboardSidebar(
        actionButton("open", "Open Box"),
        actionButton("close", "Close Box")
    ),
    dashboardBody(
        shinyjs::useShinyjs(),
        tags$head(
            tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"),
            tags$script(src = "custom.js")
        ),
        box(id = 'x',
            collapsible = T,
            collapsed = T,
            solidHeader = TRUE,
            title = 'Box',
            p("Hello"))
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
    observeEvent(input$open, {
        shinyjs::runjs("openBox('x')")
    }, ignoreNULL = TRUE)

    observeEvent(input$close, {
        shinyjs::runjs("closeBox('x')")
    }, ignoreNULL = TRUE)
}

# Run the application
shinyApp(ui = ui, server = server)

R shinyjs shinydashboard box uncollapse on radionButtons input

2 Answers2

Linked