From bc256f6da6760b7a3ec3584df2d46cea3fffba0f Mon Sep 17 00:00:00 2001
From: Nathan Stephens <nathan@rstudio.com>
Date: Tue, 8 Jan 2019 03:35:22 +0000
Subject: [PATCH] adding sqlite to quickstart

---
 .internal.yml       |   4 +-
 sqlite/bar_plot.js  | 119 ++++++++++++++++++
 sqlite/col_plot.js  | 117 ++++++++++++++++++
 sqlite/sqlite_app.R | 295 ++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 533 insertions(+), 2 deletions(-)
 create mode 100644 sqlite/bar_plot.js
 create mode 100644 sqlite/col_plot.js
 create mode 100644 sqlite/sqlite_app.R

diff --git a/.internal.yml b/.internal.yml
index e227880..b135445 100644
--- a/.internal.yml
+++ b/.internal.yml
@@ -1,8 +1,8 @@
 default:
   content:
     - name: "Enterprise Ready Dashboards"
-      path: "./local"
-      description: "Dashboard with drill downs."
+      path: "./sqlite"
+      description: "Use databases with Shiny."
       tag:
         - "Demo Content|Enterprise"
       url: "/enterprise/"
\ No newline at end of file
diff --git a/sqlite/bar_plot.js b/sqlite/bar_plot.js
new file mode 100644
index 0000000..3b68991
--- /dev/null
+++ b/sqlite/bar_plot.js
@@ -0,0 +1,119 @@
+// !preview r2d3 data= data.frame(label = c("Austin Bergstrom Intl", "Chicago Ohare Intl", "Dallas Fort Worth Intl", "Eagle Co Rgnl", "Fort Lauderdale Hollywood Intl", "General Edward Lawrence Logan Intl"), y = c(365, 1455, 7257,  103,  182,  274), x = c("GPT", "GPT", "GPT","GPT","GPT","GPT"))
+
+var layer_left      = 0.35;
+    layer_left_text = 0.01;
+    layer_top       = 0.1;
+    layer_height    = 0.85;
+    layer_width     = 0.55;
+
+var col_left_text   = width * layer_left_text;
+
+function svg_height() {return parseInt(svg.style('height'))}
+function svg_width()  {return parseInt(svg.style('width'))}
+
+function col_top()  {return svg_height() * layer_top; }
+function col_left() {return svg_width()  * layer_left;}
+
+function actual_max() {return d3.max(data, function (d) {return d.y; }); }
+function col_width()  {return (svg_width() / actual_max()) * layer_width; }
+function col_heigth() {return svg_height() / data.length * layer_height; }
+
+var bars = svg.selectAll('rect').data(data);
+
+bars.enter().append('rect')
+    .attr('width', function(d) { return d.y * col_width(); })
+    .attr('height',col_heigth() * 0.9)
+    .attr('y', function(d, i) { return i * col_heigth() + col_top(); })
+    .attr('x', col_left())
+    .attr('fill', '#0072B2')
+    .attr('opacity', function(d) { return d.y / actual_max(); })
+    .attr('tip', function(d) { return (d.y * col_width()) + col_left(); })
+    .attr("d", function(d) { return d.x; })
+    .on("click", function(){
+      Shiny.setInputValue(
+        "bar_clicked", 
+        d3.select(this).attr("d"),
+        {priority: "event"}
+      );
+    })    
+    .on("mouseover", function(){
+        d3.select(this)
+          .attr('fill', '#ffb14e');
+    })
+    .on("mouseout", function(){
+        d3.select(this)
+          .attr('fill', '#0072B2');
+    });
+
+bars.exit().remove();
+
+bars.transition()
+  .duration(500)
+    .attr('width', function(d) { return d.y * col_width(); })
+    .attr('height',col_heigth() * 0.9)
+    .attr('y', function(d, i) { return i * col_heigth() + col_top(); })
+    .attr('x', col_left())
+    .attr('opacity', function(d) { return d.y / actual_max(); })
+    .attr('tip', function(d) { return (d.y * col_width()) + col_left(); });
+
+// Identity labels
+
+var txt = svg.selectAll('text').data(data);
+
+txt.enter().append('text')
+      .attr('x', col_left_text)
+      .attr('y', function(d, i) { return i * col_heigth() + (col_heigth() / 2) + col_top(); })
+      .text(function(d) {return d.label; })
+      .style('font-size', '12px') 
+      .style('font-family', 'sans-serif');  
+      
+txt.exit().remove();
+
+txt.transition()
+  .duration(1000)
+      .attr('x', col_left_text)
+      .attr('y', function(d, i) { return i * col_heigth() + (col_heigth() / 2) + col_top(); })
+      .attr("d", function(d) { return d.x; })
+      .style('font-size', '12px') 
+      .style('font-family', 'sans-serif')
+      .text(function(d) {return d.label; });  
+
+// Numeric labels
+
+var totals = svg.selectAll().data(data);
+
+totals.enter().append('text')
+      .attr('x', function(d) { return ((d.y * col_width()) + col_left()) * 1.01; })
+      .attr('y', function(d, i) { return i * col_heigth() + (col_heigth() / 2) + col_top(); })
+      .style('font-size', '12px') 
+      .style('font-family', 'sans-serif')
+      .text(function(d) {return d.y; });  
+      
+totals.exit().remove();
+
+totals.transition()
+  .duration(1000)
+      .attr('x', function(d) { return ((d.y * col_width()) + col_left()) * 1.01; })
+      .attr('y', function(d, i) { return i * col_heigth() + (col_heigth() / 2) + col_top(); })
+      .attr("d", function(d) { return d.x; })
+      .text(function(d) {return d.y; });
+      
+// Title
+      
+svg.append('text')
+  .attr('x', svg_width() * 0.01)             
+  .attr('y', svg_height() * 0.05)
+  .style('font-size', '18px') 
+  .style('font-family', 'sans-serif')
+  .text('Top 10 Destination Airports');
+  
+// Sub-title
+  
+svg.append('text')
+  .attr('x', svg_width() * 0.99)             
+  .attr('y', svg_height() * 0.05)
+  .attr('text-anchor', 'end')
+  .style('font-size', '12px') 
+  .style('font-family', 'sans-serif')
+  .text('Click bar for details');
+  
\ No newline at end of file
diff --git a/sqlite/col_plot.js b/sqlite/col_plot.js
new file mode 100644
index 0000000..3ecd272
--- /dev/null
+++ b/sqlite/col_plot.js
@@ -0,0 +1,117 @@
+// !preview r2d3 data=data.frame(y = c(5000,2000,3000,4000), x = c(1,2,4,5), label = c('jan', 'feb', 'mar', 'apr'))
+
+var layer_left   = 0.01;
+    layer_top    = 0.2;
+    layer_height = 0.7;
+    layer_width  = 0.97;
+
+function svg_height() {return parseInt(svg.style('height'))}
+function svg_width() {return parseInt(svg.style('width'))}
+function actual_max() {return d3.max(data, function (d) {return d.y; }); }
+function col_width()  {return svg_width()  / data.length * layer_width;}
+function col_heigth() {return (svg_height() /actual_max()) * layer_height; }
+
+function col_top()  {return svg_height() * layer_top; }
+function col_left() {return svg_width()  * layer_left;}
+
+var cols = svg.selectAll('rect').data(data);
+
+cols.enter().append('rect')
+  .attr('height', function(d) {return (d.y * col_heigth()); })
+  .attr('width', col_width())
+  .attr('x', function(d, i) {return (i * col_width()) + (svg_width()* layer_left); })
+  .attr('y', function(d) {return col_top() + ((actual_max() - d.y) * col_heigth()); })
+  .attr('fill', '#009E73')
+  .attr('opacity', 0.5)
+  .attr('stroke', 'white')
+  .attr('d', function(d) { return d.x; })
+  .on("click", function(){
+    Shiny.setInputValue(
+      "column_clicked", 
+      d3.select(this).attr("d"),
+      {priority: "event"}
+    );
+  })    
+  .on("mouseenter", function(){
+      d3.select(this)
+        .attr('opacity', 1)
+        .attr('fill', '#ffb14e');
+  })
+  .on("mouseleave", function(){
+      d3.select(this)
+        .attr('opacity', 0.5)
+        .attr('fill', '#009E73');
+  });      
+      
+cols.exit().remove();
+
+cols.transition()
+  .duration(500)
+  .attr('height', function(d) {return (d.y * col_heigth()); })
+  .attr('width', col_width())
+  .attr('x', function(d, i) {return (i * col_width()) + (svg_width()* layer_left); })
+  .attr('y', function(d) {return col_top() + ((actual_max() - d.y) * col_heigth()); })
+  .attr('fill', '#009E73')
+  .attr('opacity', 0.5)
+  .attr('stroke', 'white');
+
+// Identity labels
+
+var txt = svg.selectAll('text').data(data);
+
+txt.enter().append('text')
+    .attr('x', function(d, i) {return (i * col_width()) + (svg_width()* layer_left) + (col_width() * 0.5); })
+    .attr('y', function(d) {return svg_height()* 0.95;})
+    .style('font-size', '10px') 
+    .text(function(d) {return d.label;})
+    .style('font-family', 'sans-serif')
+    .attr('text-anchor', 'middle');
+      
+      
+txt.exit().remove();
+
+txt.transition()
+  .duration(500)
+    .attr('x', function(d, i) {return (i * col_width()) + (svg_width()* layer_left) + (col_width() * 0.5); })
+    .attr('y', function(d) {return svg_height()* 0.95;})
+    .style('font-size', '10px') 
+    .text(function(d) {return d.label;})
+    .style('font-family', 'sans-serif')
+    .attr('text-anchor', 'middle');
+
+// Numeric labels
+
+var totals = svg.selectAll('totals').data(data);
+
+totals.enter().append('text')
+      .attr('x', function(d, i) {return (i * col_width()) + (svg_width()* layer_left) + (col_width() * 0.5); })
+      .attr('y', function(d) {return (col_top() * 0.9) + ((actual_max() - d.y) * col_heigth()); })
+      .attr('text-anchor', 'middle')
+      .style('font-size', '10px') 
+      .style('font-family', 'sans-serif')
+      .text(function(d) {return d.y; });  
+      
+totals.exit().remove();
+
+totals.transition()
+  .duration(500)
+      .attr('x', function(d, i) {return (i * col_width()) + (svg_width()* layer_left) + (col_width() * 0.5); })
+      .attr('y', function(d) {return col_top() + ((actual_max() - d.y) * col_heigth()); })
+      .text(function(d) {return d.y; });
+
+// Title
+svg.append('text')
+  .attr('x', svg_width()* 0.01)             
+  .attr('y', svg_height()* 0.05)
+  .style('font-size', '18px') 
+  .style('font-family', 'sans-serif')
+  .text('Total flights');
+  
+//Sub-title
+svg.append('text')
+  .attr('x', svg_width()* 0.99)             
+  .attr('y', svg_height()* 0.05)
+  .attr('text-anchor', 'end')
+  .style('font-size', '12px') 
+  .style('font-family', 'sans-serif')
+  .text('Click bar for details');
diff --git a/sqlite/sqlite_app.R b/sqlite/sqlite_app.R
new file mode 100644
index 0000000..619c2c8
--- /dev/null
+++ b/sqlite/sqlite_app.R
@@ -0,0 +1,295 @@
+library(shiny)
+library(shinydashboard)
+
+library(dplyr)
+library(purrr)
+library(rlang)
+library(stringr)
+
+library(DT)
+library(r2d3)
+
+library(DBI)
+library(dbplyr)
+library(RSQLite)
+
+con <- DBI::dbConnect(RSQLite::SQLite(), ":memory:")
+dbWriteTable(con, "airlines", nycflights13::airlines)
+dbWriteTable(con, "airports", nycflights13::airports)
+dbWriteTable(con, "flights", nycflights13::flights)
+
+airlines <- tbl(con, "airlines")
+airports <- tbl(con, "airports")
+flights  <- tbl(con, "flights")
+
+# Use purrr's split() and map() function to create the list
+# needed to display the name of the airline but pass its
+# Carrier code as the value
+
+airline_list <- airlines %>%
+  collect() %>%
+  split(.$name) %>%
+  map(~ .$carrier)
+
+# Use rlang's set_names() to easily create a valide "choices"
+# argument of the dropdown where the displayed text has to be
+# different than the value passed as the input selection
+
+month_list <- as.list(1:12) %>%
+  set_names(month.name)
+
+month_list$`All Year` <- 99
+
+ui <- dashboardPage(
+  dashboardHeader(
+    title = "Flights Dashboard",
+    titleWidth = 200
+  ),
+  dashboardSidebar(
+    selectInput(
+      inputId = "airline",
+      label = "Airline:",
+      choices = airline_list,
+      selected = "DL",
+      selectize = FALSE
+    ),
+    sidebarMenu(
+      selectInput(
+        inputId = "month",
+        label = "Month:",
+        choices = month_list,
+        selected = 99,
+        size = 13,
+        selectize = FALSE
+      ),
+      actionLink("remove", "Remove detail tabs")
+    )
+  ),
+  dashboardBody(
+    tabsetPanel(
+      id = "tabs",
+      tabPanel(
+        title = "Main Dashboard",
+        value = "page1",
+        fluidRow(
+          valueBoxOutput("total_flights"),
+          valueBoxOutput("per_day"),
+          valueBoxOutput("percent_delayed")
+        ),
+        fluidRow(),
+        fluidRow(
+          column(
+            width = 6,
+            d3Output("group_totals")
+          ),
+          column(
+            width = 6,
+            d3Output("top_airports")
+          )
+        )
+      )
+    )
+  )
+)
+
+server <- function(input, output, session) {
+  tab_list <- NULL
+
+  # Use a reactive() function to prepare the base
+  # SQL query that all the elements in the dashboard
+  # will use. The reactive() allows us to evaluate
+  # the input variables
+  base_flights <- reactive({
+    res <- flights %>%
+      filter(carrier == input$airline) %>%
+      left_join(airlines, by = "carrier") %>%
+      rename(airline = name) %>%
+      left_join(airports, by = c("origin" = "faa")) %>%
+      rename(origin_name = name) %>%
+      select(-lat, -lon, -alt, -tz, -dst) %>%
+      left_join(airports, by = c("dest" = "faa")) %>%
+      rename(dest_name = name)
+    if (input$month != 99) res <- filter(res, month == input$month)
+    res
+  })
+
+  # Total Flights (server) ------------------------------------------
+  output$total_flights <- renderValueBox({
+    # The following code runs inside the database.
+    # pull() bring the results into R, which then
+    # it's piped directly to a valueBox()
+    base_flights() %>%
+      tally() %>%
+      pull() %>%
+      as.integer() %>%
+      prettyNum(big.mark = ",") %>%
+      valueBox(subtitle = "Number of Flights")
+  })
+
+  # Avg per Day (server) --------------------------------------------
+  output$per_day <- renderValueBox({
+    # The following code runs inside the database
+    base_flights() %>%
+      group_by(day, month) %>%
+      tally() %>%
+      ungroup() %>%
+      summarise(avg = mean(n, na.rm = TRUE)) %>%
+      pull() %>%
+      round() %>%
+      prettyNum(big.mark = ",") %>%
+      valueBox(
+        subtitle = "Average Flights per day",
+        color = "blue"
+      )
+  })
+
+  # Percent delayed (server) ----------------------------------------
+  output$percent_delayed <- renderValueBox({
+    base_flights() %>%
+      filter(!is.na(dep_delay)) %>%
+      mutate(delayed = ifelse(dep_delay >= 15, 1, 0)) %>%
+      summarise(
+        delays = sum(delayed, na.rm = TRUE),
+        total = n()
+      ) %>%
+      mutate(percent = (delays / total) * 100) %>%
+      pull() %>%
+      round() %>%
+      paste0("%") %>%
+      valueBox(
+        subtitle = "Flights delayed",
+        color = "teal"
+      )
+  })
+
+  # Montly/daily trend (server) -------------------------------------
+  output$group_totals <- renderD3({
+    grouped <- ifelse(input$month != 99, expr(day), expr(month))
+
+    res <- base_flights() %>%
+      group_by(!!grouped) %>%
+      tally() %>%
+      collect() %>%
+      mutate(
+        y = n,
+        x = !!grouped
+      ) %>%
+      select(x, y)
+
+    if (input$month == 99) {
+      res <- res %>%
+        inner_join(
+          tibble(x = 1:12, label = substr(month.name, 1, 3)),
+          by = "x"
+        )
+    } else {
+      res <- res %>%
+        mutate(label = x)
+    }
+    r2d3(res, "col_plot.js")
+  })
+
+  # Top airports (server) -------------------------------------------
+  output$top_airports <- renderD3({
+    # The following code runs inside the database
+    base_flights() %>%
+      group_by(dest, dest_name) %>%
+      tally() %>%
+      collect() %>%
+      arrange(desc(n)) %>%
+      head(10) %>%
+      arrange(dest_name) %>%
+      mutate(dest_name = str_sub(dest_name, 1, 30)) %>%
+      rename(
+        x = dest,
+        y = n,
+        label = dest_name
+      ) %>%
+      r2d3("bar_plot.js")
+  })
+
+  # Get details (server) --------------------------------------------
+  get_details <- function(airport = NULL, day = NULL) {
+    # Create a generic details function that can be called
+    # by different dashboard events
+    res <- base_flights()
+    if (!is.null(airport)) res <- filter(res, dest == airport)
+    if (!is.null(day)) res <- filter(res, day == !!as.integer(day))
+
+    res %>%
+      head(100) %>%
+      select(
+        month, day, flight, tailnum,
+        dep_time, arr_time, dest_name,
+        distance
+      ) %>%
+      collect() %>%
+      mutate(month = month.name[as.integer(month)])
+  }
+
+  # Month/Day column click (server) ---------------------------------
+  observeEvent(input$column_clicked != "", {
+    if (input$month == "99") {
+      updateSelectInput(session, "month", selected = input$column_clicked)
+    } else {
+      day <- input$column_clicked
+      month <- input$month
+      tab_title <- paste(
+        input$airline, "-", month.name[as.integer(month)], "-", day
+      )
+      if (!(tab_title %in% tab_list)) {
+        appendTab(
+          inputId = "tabs",
+          tabPanel(
+            tab_title,
+            DT::renderDataTable(
+              get_details(day = day)
+            )
+          )
+        )
+        tab_list <<- c(tab_list, tab_title)
+      }
+      updateTabsetPanel(session, "tabs", selected = tab_title)
+    }
+  },
+  ignoreInit = TRUE
+  )
+
+
+  # Bar clicked (server) --------------------------------------------
+  observeEvent(input$bar_clicked, {
+    airport <- input$bar_clicked
+    month <- input$month
+    tab_title <- paste(
+      input$airline, "-", airport,
+      if (month != 99) {
+        paste("-", month.name[as.integer(month)])
+      }
+    )
+    if (!(tab_title %in% tab_list)) {
+      appendTab(
+        inputId = "tabs",
+        tabPanel(
+          tab_title,
+          DT::renderDataTable(
+            get_details(airport = airport)
+          )
+        )
+      )
+
+      tab_list <<- c(tab_list, tab_title)
+    }
+    updateTabsetPanel(session, "tabs", selected = tab_title)
+  })
+
+  # Remote tabs (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
+  })
+}
+
+shinyApp(ui, server)