Previous chapter
DashboardsShinydashboard
Next chapter

Shiny Dashboard

  • Shinydashboard is a theme for Shiny, built on top of AdminLTE
  • Structurally the same as building a regular Shiny app, but with a different “vocabulary” of UI functions

Shiny Dashboard Example

Shiny Dashboard Elements

Exercise Earthquakes

  • Use the app from the script below
  • Turn this unstyled app into a Shiny Dashboard. Use the “Example App Earthquakes” from the Introduction chapter as a visual template.
  • The required CSV file can be downloaded here.
  • Refer to https://rstudio.github.io/shinydashboard/
library(shiny)
library(ggplot2)
library(leaflet)
library(dplyr)

# From https://earthquake.usgs.gov/earthquakes/feed/v1.0/summary/all_week.csv
earthquakes <- read.csv("earthquakes.csv", stringsAsFactors = FALSE)
earthquakes$time <- lubridate::parse_date_time(earthquakes$time, orders="ymd HMS")

ui <- fluidPage(
  titlePanel("USGS Earthquake Explorer"),
  sidebarLayout(
    sidebarPanel(
      dateRangeInput("dates", "Date range",
        start = as.Date(min(earthquakes$time)),
        end = as.Date(max(earthquakes$time)),
        min = as.Date(min(earthquakes$time)),
        max = as.Date(max(earthquakes$time))
      ),
      actionButton("reset_dates", "Reset date range")
    ),
    mainPanel(
      p("Number of quakes:", textOutput("count", inline = TRUE)),
      p("Median magnitude:", textOutput("median", inline = TRUE)),
      p("Mean time between quakes:", textOutput("mtbq", inline = TRUE)),
      leafletOutput("map"),
      plotOutput("scatter"),
      plotOutput("mag_hist")
    )
  )
)

server <- function(input, output, session) {
  observeEvent(input$reset_dates, {
    updateDateRangeInput(session, "dates",
      start = as.Date(min(earthquakes$time)),
      end = as.Date(max(earthquakes$time))
    )
  })
  
  quakes_subset <- reactive({
    earthquakes %>%
      filter(time >= input$dates[[1]] & as.Date(time) <= input$dates[[2]])
  })
  
  output$count <- renderText({
    nrow(quakes_subset())
  })
  
  output$median <- renderText({
    median(quakes_subset()$mag)
  })
  
  output$mtbq <- renderText({
    by_time <- quakes_subset()
    diffs <- difftime(head(by_time$time, -1), tail(by_time$time, -1), "minutes")
    mtbq <- mean(diffs)
    paste(formatC(mtbq), units(mtbq))
  })
  
  
  output$map <- renderLeaflet({
    labels = with(quakes_subset(), paste0(as.character(time), "<br/>Magnitude ", mag)) %>%
      lapply(HTML)
    
    pal <- colorBin("viridis", earthquakes$mag, bins = 4)
    leaflet(quakes_subset()) %>%
      addTiles() %>%
      addCircleMarkers(radius = ~mag, color = ~pal(mag),
        stroke = FALSE, fillOpacity = 0.7, label = labels) %>%
      addLegend(pal = pal, values = ~earthquakes$mag, opacity = 0.7,
        title = "Magnitude")
  })
  
  output$scatter <- renderPlot({
    ggplot(quakes_subset(), aes(time, mag, color = depth)) +
      geom_point(alpha = 0.4)
  })
  
  output$mag_hist <- renderPlot({
    ggplot(quakes_subset(), aes(mag)) +
      geom_histogram(fill = "#99BBFF")
  })
}

shinyApp(ui, server)

Next Steps

  1. Try to first run the exercise above based on the specifications ON YOUR OWN.
  2. Only as a last resort check out the solution in the next section.

Solution Earthquakes

library(shiny)
library(ggplot2)
library(leaflet)
library(dplyr)
library(shinydashboard)

# From https://earthquake.usgs.gov/earthquakes/feed/v1.0/summary/all_week.csv
earthquakes <- read.csv("earthquakes.csv", stringsAsFactors = FALSE)
earthquakes$time <- lubridate::parse_date_time(earthquakes$time, orders="ymd HMS")

ui <- dashboardPage(
  dashboardHeader(title = "USGS Earthquake Explorer"),
  dashboardSidebar(
    dateRangeInput("dates", "Date range",
      start = as.Date(min(earthquakes$time)),
      end = as.Date(max(earthquakes$time)),
      min = as.Date(min(earthquakes$time)),
      max = as.Date(max(earthquakes$time))
    ),
    actionButton("reset_dates", "Reset date range")
  ),
  dashboardBody(
    fluidRow(
      valueBoxOutput("count", width = 4),
      valueBoxOutput("median", width = 4),
      valueBoxOutput("mtbq", width = 4)
    ),
    fluidRow(
      box(width = 12,
        leafletOutput("map")
      )
    ),
    fluidRow(
      box(
        plotOutput("scatter")
      ),
      box(
        plotOutput("mag_hist")
      )
    )
  )
)

server <- function(input, output, session) {
  observeEvent(input$reset_dates, {
    updateDateRangeInput(session, "dates",
      start = as.Date(min(earthquakes$time)),
      end = as.Date(max(earthquakes$time))
    )
  })
  
  quakes_subset <- reactive({
    earthquakes %>%
      filter(time >= input$dates[[1]] & as.Date(time) <= input$dates[[2]])
  })
  
  output$count <- renderValueBox({
    valueBox(
      nrow(quakes_subset()),
      "Number of quakes",
      icon = icon("globe")
    )
  })
  
  output$median <- renderValueBox({
    valueBox(
      median(quakes_subset()$mag),
      "Median magnitude",
      icon = icon("line-chart")
    )
  })
  
  output$mtbq <- renderValueBox({
    by_time <- quakes_subset()
    diffs <- difftime(head(by_time$time, -1), tail(by_time$time, -1), "minutes")
    mtbq <- mean(diffs)
    valueBox(
      paste(formatC(mtbq), units(mtbq)),
      "Mean time between quakes",
      icon = icon("clock-o")
    )
  })

  output$scatter <- renderPlot({
    ggplot(quakes_subset(), aes(time, mag, color = depth)) +
      geom_point(alpha = 0.4)
  })
  
  output$mag_hist <- renderPlot({
    ggplot(quakes_subset(), aes(mag)) +
      geom_histogram(fill = "#99BBFF")
  })
  
  output$map <- renderLeaflet({
    labels = with(quakes_subset(), paste0(as.character(time), "<br/>Magnitude ", mag)) %>%
      lapply(HTML)
    
    pal <- colorBin("viridis", earthquakes$mag, bins = 4)
    leaflet(quakes_subset()) %>%
      addTiles() %>%
      addCircleMarkers(radius = ~mag, color = ~pal(mag),
        stroke = FALSE, fillOpacity = 0.7, label = labels) %>%
      addLegend(pal = pal, values = ~earthquakes$mag, opacity = 0.7,
        title = "Magnitude")
  })
}

shinyApp(ui, server)