Enterprise-ready dashboards with Shiny and databases

Quick example

If you are new to shinydashboard, please feel free to copy and paste the following code to see a very simple dashboard in your environment:

library(shinydashboard)
library(shiny)
ui <- dashboardPage(
  dashboardHeader(title = "Quick Example"),
  dashboardSidebar(textInput("text", "Text")),
  dashboardBody(
    valueBox(100, "Basic example"),
    tableOutput("mtcars")
  )
)
server <- function(input, output) {
  output$mtcars <- renderTable(head(mtcars))
}
shinyApp(ui, server)

A dashboard element is clicked

The following is one way that capturing a click event is possible. The idea is to display the top airport destinations for a given airline in a bar plot. When a bar is clicked, the desired result is for the plot to activate a drill-down. The highcharter package will be used in this example.

To capture a bar-click event in highcharter, a small JavaScript needs to be written. The example below could be used in most cases, so you can copy and paste it as-is into your code. The variable name and the input name (bar_clicked) would be the only two statements that would have to be changed to match your chart.

 js_bar_clicked <- JS("function(event) {Shiny.onInputChange('bar_clicked', [event.point.category]);}")

The command above creates a new JavaScript inside R that makes it possible to track when a bar is clicked. Here is a breakdown of the code:

• JS - Indicates that the following function is JavaScript
• function(event) - Creates a new function, and expect an event variable. The event that Highchart will pass is when a bar is clicked on, so the event will contain information about that given bar.
• Shiny.onInputChange - Is the function that JavaScript will use to interact with Shiny
• bar_clicked - Is the name of a new Shiny input; its value will default to the next item
• [event.point.category] - Passes the category value of the point where the click was made

The next section will illustrate how to capture the change of the new input$bar_clicked, and perform the second part of the “drill down”.

In the renderHighchart() output function, the variable that contains the JavaScript is passed as part of a list of events: events = list(click = js_bar_clicked)). Because the event is inside the hc_add_series() that creates the bar plot, then such click-event is tied to when the bar is clicked.

output$top_airports <- renderHighchart({
  # Reuse the dplyr db_flights variable as the base query
  result <- db_flights %>%
    filter(carrier == input$airline) 
  if(input$month != 99) result <- filter(result, month == input$month) 
  result <- result %>
    group_by(dest_name) %>%
    tally() %>%
    arrange(desc(n)) %>%                          
    collect %>%
    head(10)                                      
  highchart() %>%
    hc_add_series(
      data = result$n, 
      type = "bar",
      name = paste("No. of Flights"),
      events = list(click = js_bar_clicked)) %>%   # The JavaScript variable is called here
    hc_xAxis(
      categories = result$dest_name,               # Value in event.point.category
        tickmarkPlacement="on")})

Using appendTab() to create the drill-down report

The plan is to display a new drill-down report every time the end user clicks on a bar. To prevent pulling the same data unnecessarily, the code will be smart enough to simply switch the focus to an existing tab if the same bar has been clicked on before.

The new, and really cool, appendTab() function is used to dynamically create a new Shiny tab with a DataTable that contains the first 100 rows of the selection. A simple vector, called tab_list, is used to track all existing detail tabs. The updateTabsetPanel() function is used to switch to the newly or previously created tab.

The observeEvent() function is the one that “catches” the event executed by the JavaScript, because it monitors the bar_clicked Shiny input. Comments are added to the code below to cover more aspects of how to use these features.

tab_list <- NULL

observeEvent(input$bar_clicked,{  
       airport <- input$bar_clicked[1]              # Selects the first value sent in [event.point.category]
       tab_title <- paste(input$airline,            # tab_title is the tab's name and unique identifier
                          "-", airport ,            
                          if(input$month != 99)     
                            paste("-" , month.name[as.integer(input$month)]))
       
       if(tab_title %in% tab_list == FALSE){        # Checks to see if the title already exists
         details <- db_flights %>%                  # Reuses the db_flights dbplyr variable
           filter(dest_name == airport,             # Uses the [event.point.category] value for the filter
                  carrier == input$airline)         # Matches the current airline filter
         
         if(input$month != 99)                      # Matches the current month selection
            details <- filter(details, month == input$month) 
         details <- details %>%
           head(100) %>%                            # Select only the first 100 records
           collect()                                # Brings the 100 records into the R environment 
           
         appendTab(inputId = "tabs",                # Starts a new Shiny tab inside the tabsetPanel named "tabs"
                   tabPanel(
                     tab_title,                     # Sets the name & ID
                     DT::renderDataTable(details)   # Renders the DataTable with the 100 newly collected rows
                   ))
         tab_list <<- c(tab_list, tab_title)        # Adds the new tab to the list, important to use <<- 
         }
         
       # Switches over to a panel that matched the name in tab_title.  
       # Notice that this function sits outside the if statement because
       # it still needs to run to select a previously created tab
       updateTabsetPanel(session, "tabs", selected = tab_title)  
     })

Remove all tabs using removeTab() and purrr

Creating new tabs dynamically can clutter the dashboard. So a simple actionLink() button can be added to the dashboardSidebar() in order to remove all tabs except the main dashboard tab.

# This code runs in ui
  dashboardSidebar(
       actionLink("remove", "Remove detail tabs"))

The observeEvent() function is used once more to catch when the link is clicked. The walk() command from purrr is then used to iterate through each tab title in the tab_list vector and proceeds to execute the Shiny removeTab() command for each name. After that, the tab list variable is reset. Because of environment scoping, make sure to use double less than ( <<- ) when resetting the variable, so it knows to reset the variable defined outside of the observeEvent() function.

# This code runs in server
  observeEvent(input$remove,{
    # Use purrr's walk command to cycle through each
    # panel tabs and remove them
    tab_list %>%
      walk(~removeTab("tabs", .x))
    tab_list <<- NULL
  })