Expand/Collapse shiny box on header click

Question

I have developed a shiny app, where we are using various box object in the ui. Currently the boxes expand/Collapse by clicking on the "+/-" sign on the right of the box header, but we need the expand/collapse on click on the header (anywhere on the box header). Below code (sample code) If you look at the box with chart, I want the expansion & collapse to be performed on clicking the header i.e. "Histogram box title" and not just the "+/-" sign on right side of the header:

    ## Only run this example in interactive R sessions
    if (interactive()) {
      library(shiny)

      # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes
      body <- dashboardBody(
        # Boxes
        fluidRow(
          box(title = "Histogram box title",
              status = "warning", solidHeader = TRUE, collapsible = TRUE,
              plotOutput("plot", height = 250)
          )
        )


      )

      server <- function(input, output) {

        output$plot <- renderPlot({
          hist(rnorm(50))
        })
      }

      shinyApp(
        ui = dashboardPage(
          dashboardHeader(),
          dashboardSidebar(),
          body
        ),
        server = server
      )
    }

Answer 1

This is easily achievable using javascript. You just have to create a javascript function and call the same in your header code. Refer to below code for better understanding. I have provided 3 options, let me know if this works for you.

## Only run this example in interactive R sessions
if (interactive()) {
  library(shiny)

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

  # A dashboard body with a row of infoBoxes and valueBoxes, and two rows of boxes
  body <- dashboardBody(
    # Including Javascript
    useShinyjs(),
    extendShinyjs(text = jscode),
    # Boxes
    fluidRow(
      box(id="box1",title = actionLink("titleId", "Histogram box title",icon =icon("arrow-circle-up")), 
          status = "warning", solidHeader = TRUE, collapsible = T,
          plotOutput("plot", height = 250)
      ),
      box(id="box2",title = p("Histogram box title", 
                          actionButton("titleBtId", "", icon = icon("arrow-circle-up"),
                                       class = "btn-xs", title = "Update")), 
          status = "warning", solidHeader = TRUE, collapsible = T,
          plotOutput("plot1", height = 250)
      ),
      box(id="box3",title = actionButton("titleboxId", "Histogram box title",icon =icon("arrow-circle-up")), 
          status = "warning", solidHeader = TRUE, collapsible = T,
          plotOutput("plot2", height = 250)
      )
    )


  )

  server <- function(input, output) {

    output$plot <- renderPlot({
      hist(rnorm(50))
    })
    output$plot1 <- renderPlot({
      hist(rnorm(50))
    })
    output$plot2 <- renderPlot({
      hist(rnorm(50))
    })

    observeEvent(input$titleId, {
      js$collapse("box1")
    })
    observeEvent(input$titleBtId, {
      js$collapse("box2")
    })
    observeEvent(input$titleboxId, {
      js$collapse("box3")
    })
  }

  shinyApp(
    ui = dashboardPage(
      dashboardHeader(),
      dashboardSidebar(),
      body
    ),
    server = server
  )
}

Answer 2

You can do this for all boxes in an app with a few lines of external css and javascript.

The JS triggers a click on the widget when you click on the header title. It has to be the h3 element because the widget is inside .box-header, which would cause infinite recursion.

$('.box').on('click', '.box-header h3', function() {
    $(this).closest('.box')
           .find('[data-widget=collapse]')
           .click();
});

But then we need to make the h3 element fill the full .box-header, so get rid of the header padding (except on the right), add it to the h3, and make the h3 fill 100% of the width of the box.

.box-header {
  padding: 0 10px 0 0;
}
.box-header h3 {
  width: 100%;
  padding: 10px;
}

Answer 3

I think Lisa DeBruine answer is the better one since you can click the whole header and not just the title.

Pasted it into a small example:

if (interactive()) {
  body <- dashboardBody(
    useShinyjs(),
    
      tags$style(HTML("
      .box-header {
        padding: 0 10px 0 0;
      }
      .box-header h3 {
        width: 100%;
        padding: 10px;
      }")),
    
      fluidRow(
        box(id="box1", title = "Histogram box title",
            status = "warning", solidHeader = TRUE, collapsible = T,
            plotOutput("plot", height = 250)
        )
      )
    )
  
    server <- function(input, output) {
    
      output$plot <- renderPlot({
        hist(rnorm(50))
      })
    
      runjs("
      $('.box').on('click', '.box-header h3', function() {
          $(this).closest('.box')
                 .find('[data-widget=collapse]')
                 .click();
      });")
    }
  
  shinyApp(
    ui = dashboardPage(
      dashboardHeader(),
      dashboardSidebar(),
      body
    ),
    server = server
  )
}