shinydashboard box collapse

Question

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

trtall <- rbind(rep("A",100),rep("B",100), rep("C",100))
trt <- sample(trtall,80)
agecat.temp <- c(rep("18-40",100), rep("> 40", 100))
agecat <- sample(agecat.temp, 80)
sex <- sample(rbind(rep("M",100),rep("F",100)),80)
race <- sample(rbind(rep("Asian",50),rep("Hispanic",50),rep("Other",50)),80)

df <- data.frame(trt, agecat, sex, race)

 
body <- dashboardBody(
  fluidRow(box(width=12,collapsed=F, collapsible = T, title="Filters", solidHeader = T,status="primary",
               box(width=5, height="220px", status="primary",
                   fluidRow(column(6,uiOutput("uivr1")),
                            column(6,uiOutput("uivl1")))))))
 
ui <- dashboardPage(
  dashboardHeader(disable = T),
  dashboardSidebar(disable = T),
  body, skin = "green"
)

 server = function(input, output) {
  reacui1 <- reactiveVal()

   observeEvent(input$vr1,{
      reacui1(as.list(df %>% distinct(!!input$vr1) %>% arrange(!!input$vr1)))
  })

  output$uivr1 <- renderUI(varSelectInput(width = "200px", "vr1",NULL,df))
  output$uivl1 <- renderUI(selectInput("vl1",width="200px",multiple=T,NULL,choices=reacui1()))
  
}

shinyApp(ui,server)

Hi,

I am dynamically trying to create UI in shiny app. The logic works fine until I collapse the box in shiny dashboard.

I did following steps and got unexpected results.

1. I select 'trt' in "vr1" and choose "A" from "vl1".
2. I collapsed the box.
3. Then un-collapsed the box.
4. I select 'agecat' in "vr1" - now I still see various treatments (A,B,C) but not distinct age categories (18-40, >40) in "vl1"

Can you please help.

Answer 1

The problem comes from the fact that the shown event is not passed down to the elements which are in a box inside the collapsed box.

Compare this to this slightly changed example:

body <- dashboardBody(
  fluidRow(
    box(width = 12, collapsed = FALSE, collapsible = TRUE,
        title = "Filters", solidHeader = TRUE, status = "primary",
        # box(width=5, height="220px", status="primary",
            fluidRow(column(6, uiOutput("uivr1")),
                     column(6, uiOutput("uivl1"))
        #     )
        )
    )
  )
)

and you see that in this case the second input is properly updated.

You can also use your example, go to the JS console and type $('.box').trigger('shown') and you will see that the select input is suddenly updated.

That means the problem is, that shiny still believes that the inputs are hidden and because hidden inputs are not updated you observe this behavior.

But this tells us how we can fix it:

1. Workaround is to switch off the suspendWhenHidden property. Add this to your server:

     session$onFlushed(function() {
       outputOptions(output, "uivl1", suspendWhenHidden = FALSE)
     })
   

   This is however, just fixing the symptom and not solving the issue.
2. Another approach would be to make sure the shown.bs.collapse event is also triggered at the box inside the box. For this we can listen to the shown.bs.collapse event and once received, wait a bit (800ms) such that the box is fully visible and then inform all shiny-bound-output children that they should be shown:

   js <- "$(() => $('body').on('shown.bs.collapse', '.box', function(evt) { 
         setTimeout(function(){
            $(evt.target).find('.shiny-bound-output').trigger('shown.bs.collapse');
         }, 800);
      }))"
   
   body <- dashboardBody(
     tags$head(tags$script(HTML(js))),
     fluidRow(
       box(width = 12, collapsed = FALSE, collapsible = TRUE,
           title = "Filters", solidHeader = TRUE, status = "primary",
           box(width = 5, height = "220px", status = "primary",
               fluidRow(column(6, uiOutput("uivr1")),
                        column(6, uiOutput("uivl1"))
               )
           )
       )
     )
   )
   

This is, BTW, already reported as bug: https://github.com/rstudio/shinydashboard/issues/234