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)