Shinydashboard box input/output

I am working on shinydashboard box feature. I want to achieve following points.

  1. On rendering output table the input box should be collapsed. Is there any way I can achieve this ?

  2. When I want to print table from "Second Box" after "First Box" eventReactive of second submit button is not responding. What needs to be done in order to fix this ?

  3. Progress Bar is shown on loading of page but it should be shown only on rendering output table. How to fix this ?

ui.R

library(shiny)
library(shinyjs)
library(shinydashboard)
library(DT)
shinyUI(
   dashboardPage(title = "My Page",  
   dashboardHeader(
     title = "My Header",
     titleWidth = 200
   ),
   dashboardSidebar(
     width = 200,
     sidebarMenu(
       menuItem("My Data", selected = FALSE, 
         menuSubItem(text = "My Data", tabName = "my_data", newtab = TRUE, selected = FALSE)
       )
     )
   ),
   dashboardBody(
     useShinyjs(),
     tabItems(
       # First tab content
       tabItem(tabName = "my_data",
          h2("Please select fields"),
          div(
            fluidRow
            (
              box(title = 'First Box', background = 'green', collapsible = TRUE, collapsed = TRUE,
              column(2,
              actionButton("sub_mt", "Show MT Cars")
            )),
            box(title = 'Second Box', background = 'yellow', collapsible = TRUE, collapsed = TRUE,   
            column(2,
            actionButton("sub_iris","Show Iris Data")
            ))   
            )
           )
       ) 
     ),
    DT::dataTableOutput('optable'),
    textOutput('message')
    ) 
))

server.R

library(shiny)
library(shinydashboard)
library(DT)
library(shinyjs)
if (interactive()) {
shinyServer(function(session,input,output){
  dt_mtcars <- eventReactive(input$sub_mt, 
                  {
                   mtcars
                  })
  dt_iris <- eventReactive(input$sub_iris, 
                  {
                 iris
                  })
  output$optable <- DT::renderDataTable({
    withProgress(message = 'Data Loading...',value = 0, {
      for (i in 1:15) {
        incProgress(1/15)
        Sys.sleep(0.25)
      }
    })
    if(input$sub_mt == TRUE)
    {
      dt_tab=dt_mtcars()
    } else{
      dt_tab=dt_iris()
    }
    datatable(dt_tab, rownames = FALSE, filter = 'top', 
              style = 'bootstrap', selection = 'single')}
  )
 }
)
}

  1. On rendering output table the input box should be collapsed. Is there any way I can achieve this ?

I don't immediately see an R method that can be called or a javascript id that can be used to collapse the box at will. There could be a method, but I don't know of it.

  1. When I want to print table from "Second Box" after "First Box" eventReactive of second submit button is not responding. What needs to be done in order to fix this ?

My approach is to use a middle dataset. Then this new data should be printed. If a button is pressed, the middle data is set to that buttons data. Since it is a reactiveVal, same values do not update reactively.

  1. Progress Bar is shown on loading of page but it should be shown only on rendering output table. How to fix this ?

At the beginning of renderDataTable, be sure to req (require) all variables that are necessary to function. If any of the req arguments are falsey, then computation will stop for that method.

Updated code below.

library(shiny)
library(shinyjs)
library(shinydashboard)
library(DT)
ui <- fluidPage(
   dashboardPage(title = "My Page",
   dashboardHeader(
     title = "My Header",
     titleWidth = 200
   ),
   dashboardSidebar(
     width = 200,
     sidebarMenu(
       menuItem("My Data", selected = FALSE,
         menuSubItem(text = "My Data", tabName = "my_data", newtab = TRUE, selected = FALSE)
       )
     )
   ),
   dashboardBody(
     useShinyjs(),
     tabItems(
       # First tab content
       tabItem(tabName = "my_data",
          h2("Please select fields"),
          div(
            fluidRow
            (
              box(title = 'First Box', background = 'green', collapsible = TRUE, collapsed = TRUE,
              column(2,
              actionButton("sub_mt", "Show MT Cars")
            )),
            box(title = 'Second Box', background = 'yellow', collapsible = TRUE, collapsed = TRUE,
            column(2,
            actionButton("sub_iris","Show Iris Data")
            ))
            )
           )
       )
     ),
    DT::dataTableOutput('optable'),
    textOutput('message')
    )
))


server <- function(session,input,output) {
  # initialize the data to nothing
  data_to_show <- reactiveVal(NULL)
  # set susspend to TRUE to NOT run the first time
  observe(suspended = TRUE, {
    input$sub_mt
    # set data to mtcars
    data_to_show(mtcars)
  })
  observe(suspended = TRUE, {
    input$sub_iris
    # set data to iris
    data_to_show(iris)
  })
  output$optable <- DT::renderDataTable({
    # require that the data exist
    req(data_to_show())
    withProgress(message = 'Data Loading...',value = 0, {
      for (i in 1:15) {
        incProgress(1/15)
        Sys.sleep(0.25)
      }
    })
    datatable(data_to_show(), rownames = FALSE, filter = 'top',
              style = 'bootstrap', selection = 'single')}
  )
 }

shinyApp(ui, server)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(DT)
ui <- fluidPage(
   dashboardPage(title = "My Page",
   dashboardHeader(
     title = "My Header",
     titleWidth = 200
   ),
   dashboardSidebar(
     width = 200,
     sidebarMenu(
       menuItem("My Data", selected = FALSE,
         menuSubItem(text = "My Data", tabName = "my_data", newtab = TRUE, selected = FALSE)
       )
     )
   ),
   dashboardBody(
     useShinyjs(),
     tabItems(
       # First tab content
       tabItem(tabName = "my_data",
          h2("Please select fields"),
          div(
            fluidRow
            (
              box(title = 'First Box', background = 'green', collapsible = TRUE, collapsed = TRUE,
              column(2,
              actionButton("sub_mt", "Show MT Cars")
            )),
            box(title = 'Second Box', background = 'yellow', collapsible = TRUE, collapsed = TRUE,
            column(2,
            actionButton("sub_iris","Show Iris Data")
            ))
            )
           )
       )
     ),
    DT::dataTableOutput('optable'),
    textOutput('message')
    )
))


server <- function(session,input,output) {
  # initialize the data to nothing
  data_to_show <- reactiveVal(NULL)
  # set susspend to TRUE to NOT run the first time
  observe(suspended = TRUE, {
    input$sub_mt
    # set data to mtcars
    data_to_show(mtcars)
  })
  observe(suspended = TRUE, {
    input$sub_iris
    # set data to iris
    data_to_show(iris)
  })
  output$optable <- DT::renderDataTable({
    # require that the data exist
    req(data_to_show())
    withProgress(message = 'Data Loading...',value = 0, {
      for (i in 1:15) {
        incProgress(1/15)
        Sys.sleep(0.25)
      }
    })
    datatable(data_to_show(), rownames = FALSE, filter = 'top',
              style = 'bootstrap', selection = 'single')}
  )
 }

shinyApp(ui, server)
1 Like

Thank you Barret,

Unfortunately it didn't work on my system. Please find below session info of my system.

R version 3.5.1 (2018-07-02)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows >= 8 x64 (build 9200)

Matrix products: default

locale:
[1] LC_COLLATE=English_India.1252  LC_CTYPE=English_India.1252    LC_MONETARY=English_India.1252 LC_NUMERIC=C                  
[5] LC_TIME=English_India.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] dplyr_0.8.0.1        DT_0.5               shinydashboard_0.7.1 shinyjs_1.0          shiny_1.2.0         

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.1        rstudioapi_0.10   magrittr_1.5      tidyselect_0.2.5  xtable_1.8-3      R6_2.3.0          rlang_0.3.2      
 [8] tools_3.5.1       data.table_1.12.0 htmltools_0.3.6   sourcetools_0.1.7 crosstalk_1.0.0   yaml_2.2.0        digest_0.6.18    
[15] assertthat_0.2.1  tibble_2.1.1      crayon_1.3.4      purrr_0.3.2       later_0.7.5       htmlwidgets_1.3   promises_1.0.1   
[22] glue_1.3.1        mime_0.6          pillar_1.3.1      compiler_3.5.1    jsonlite_1.5      httpuv_1.4.5      pkgconfig_2.0.2  

I used @barret's suggestion of using reactiveValues and added some points for how to collapse the box and switch between datasets:

ui.R

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

# from SO post https://stackoverflow.com/questions/49659804/r-shinyjs-shinydashboard-box-uncollapse-on-action-button-input
# javascript code to collapse box 
jscode <- "
shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"

shinyUI(
  dashboardPage(
    title = "My Page",
    dashboardHeader(title = "My Header",
                    titleWidth = 200),
    dashboardSidebar(width = 200,
                     sidebarMenu(
                       menuItem(
                         "My Data",
                         selected = FALSE,
                         menuSubItem(
                           text = "My Data",
                           tabName = "my_data",
                           newtab = TRUE,
                           selected = FALSE
                         )
                       )
                     )),
    dashboardBody(
      useShinyjs(),
# use extendJS to bring in JS code and collapse function
      extendShinyjs(text = jscode, functions = "collapse"),
      tabItems(# First tab content
        tabItem(
          tabName = "my_data",
          h2("Please select fields"),
          div(fluidRow
              (
                box(
# JS function requires boxes to have ids, which I've added here to both boxes
                  id = 'box-mt',
                  title = 'First Box',
                  background = 'green',
                  collapsible = TRUE,
                  collapsed = TRUE,
                  column(2,
                         actionButton("sub_mt", "Show MT Cars"))
                ),
                box(
                  id = 'box-iris',
                  title = 'Second Box',
                  background = 'yellow',
                  collapsible = TRUE,
                  collapsed = TRUE,
                  column(2,
                         actionButton("sub_iris", "Show Iris Data"))
                )
              ))
        )),
      DT::dataTableOutput('optable'),
      textOutput('message')
    )
  )
)

server.R

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

if (interactive()) {
    shinyServer(function(session, input, output) {
        # Create reactive value where we'll assign data
        value <- reactiveValues(data = NULL)
        
        # Use observeEvent instead of eventReactive to
        # check which button is pushed
        observeEvent(input$sub_mt,
                     {
                         # assign dataset to data value
                         value$data <-  mtcars
                         # call JS function to collapse box
                         js$collapse("box-mt")
                     })
        observeEvent(input$sub_iris,
                     {
                         value$data <-   iris
                         js$collapse("box-iris")
                     })
        
        
        output$optable <- DT::renderDataTable({
            # only create DT if the reactive value is not null
            if (!is.null(value$data)) {
# Only show progress bar if data is not null
                withProgress(message = 'Data Loading...', value = 0, {
                    for (i in 1:15) {
                        incProgress(1 / 15)
                        Sys.sleep(0.25)
                    }
                })
                
                datatable(
                    value$data,
                    rownames = FALSE,
                    filter = 'top',
                    style = 'bootstrap',
                    selection = 'single'
                )
            }
        })
    })
}

My packages info:

package        * version date       lib source        
 assertthat       0.2.0   2017-04-11 [1] RSPM (R 3.5.0)
 cli              1.0.1   2018-09-25 [1] RSPM (R 3.5.2)
 crayon           1.3.4   2017-09-16 [1] RSPM (R 3.5.0)
 crosstalk        1.0.0   2016-12-21 [1] RSPM (R 3.5.0)
 digest           0.6.18  2018-10-10 [1] RSPM (R 3.5.2)
 DT             * 0.5     2018-11-05 [1] RSPM (R 3.5.2)
 htmltools        0.3.6   2017-04-28 [1] RSPM (R 3.5.0)
 htmlwidgets      1.3     2018-09-30 [1] RSPM (R 3.5.2)
 httpuv           1.5.0   2019-03-15 [1] RSPM (R 3.5.2)
 jsonlite         1.6     2018-12-07 [1] RSPM (R 3.5.2)
 later            0.8.0   2019-02-11 [1] RSPM (R 3.5.2)
 magrittr         1.5     2014-11-22 [1] RSPM (R 3.5.0)
 mime             0.6     2018-10-05 [1] RSPM (R 3.5.2)
 promises         1.0.1   2018-04-13 [1] RSPM (R 3.5.0)
 R6               2.4.0   2019-02-14 [1] RSPM (R 3.5.2)
 Rcpp             1.0.1   2019-03-17 [1] RSPM (R 3.5.2)
 rlang            0.3.3   2019-03-29 [1] RSPM (R 3.5.2)
 rstudioapi       0.9.0   2019-01-09 [1] RSPM (R 3.5.2)
 sessioninfo      1.1.1   2018-11-05 [1] RSPM (R 3.5.2)
 shiny          * 1.2.0   2018-11-02 [1] RSPM (R 3.5.2)
 shinydashboard * 0.7.1   2018-10-17 [1] RSPM (R 3.5.0)
 shinyjs        * 1.0     2018-01-08 [1] RSPM (R 3.5.2)
 sourcetools      0.1.7   2018-04-25 [1] RSPM (R 3.5.0)
 withr            2.1.2   2018-03-15 [1] RSPM (R 3.5.0)
 xtable           1.8-2   2016-02-05 [1] RSPM (R 3.5.0)
 yaml             2.2.0   2018-07-25 [1] RSPM (R 3.5.0)
2 Likes

Thank you very much JDB... I will apply this to complex application.

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.