add shiny-based crossfiltering example apps

Author: cpsievert

inst/examples/shiny/crossfilter/app.R

@@ -0,0 +1,84 @@
+library(shiny)
+library(plotly)
+library(dplyr)
+library(nycflights13)
+# install from https://github.com/hadley/ggstat
+library(ggstat)
+
+# Collect numeric variables to be shown as histograms in the crossfilter
+d <- select(flights, arr_time, dep_time, arr_delay, dep_delay, air_time, distance)
+
+# Generate an output container per variable
+ui <- fluidPage(
+  lapply(names(d), function(nm) plotlyOutput(nm, height = 200, width = "49%", inline = TRUE))
+)
+
+server <- function(input, output, session) {
+  
+  # These reactive values track the set of active brushes 
+  # Each reactive value corresponds to a different variable 
+  brush_ranges <- reactiveValues()
+  
+  # Filter the dataset based on every active brush range except for one (var)
+  d_filter <- function(d, var = "arr_time") {
+    for (nm in setdiff(names(d), var)) {
+      rng <- brush_ranges[[nm]]
+      if (is.null(rng)) next
+      d <- filter(d, between(d[[nm]], min(rng), max(rng)))
+    }
+    d
+  }
+  
+  # Implement same render logic for each variable
+  lapply(names(d), function(nm) {
+    
+    counts <- d[[nm]] %>%
+      bin_fixed(bins = 150) %>%
+      compute_stat(d[[nm]]) %>%
+      filter(!is.na(xmin_)) %>%
+      mutate(xmid = (xmin_ + xmax_) / 2)
+    
+    output[[nm]] <- renderPlotly({
+      
+      plot_ly(counts, source = nm) %>%
+        add_bars(x = ~xmid, y = ~count_) %>%
+        layout(
+          dragmode = "select", 
+          selectdirection = "h",
+          xaxis = list(
+            title = nm,
+            range = range(d[[nm]], na.rm = TRUE)
+          ),
+          yaxis = list(title = "")
+        )
+    })
+    
+    observeEvent(event_data("plotly_brushing", source = nm), ignoreNULL = FALSE, {
+      
+      # inform the world about the new brush range
+      brush_ranges[[nm]] <- event_data("plotly_brushing", source = nm)$x
+      
+      # update the bar heights of every view (except for the one being brushed)
+      for (var in setdiff(names(d), nm)) {
+        
+        # views respect every brush except for their own 
+        d_filtered <- d_filter(d, var)
+        
+        # bin the filtered data based on the global binning definition
+        counts_filter <- d[[var]] %>%
+          bin_fixed(bins = 150) %>%
+          compute_stat(d_filtered[[var]]) %>%
+          filter(!is.na(xmin_)) %>%
+          mutate(xmid = (xmin_ + xmax_) / 2)
+        
+        # finally, update the bar heights
+        plotlyProxy(var, session) %>%
+          plotlyProxyInvoke("restyle", "y", list(counts_filter$count_), 0) 
+      }
+    })
+    
+  })
+  
+}
+
+shinyApp(ui, server)

inst/examples/shiny/crossfilter_compare/app.R

@@ -0,0 +1,133 @@
+library(shiny)
+library(dplyr)
+library(nycflights13)
+library(colourpicker)
+# install from https://github.com/hadley/ggstat
+library(ggstat)
+
+# Select all the (numeric) variables to be shown as histograms
+# in the crossfilter
+d <- select(flights, arr_time, dep_time, arr_delay, dep_delay, air_time, distance)
+
+# Determing a color palette for the brush
+n_colors <- 5
+color_codes <- RColorBrewer::brewer.pal(n_colors, "Dark2")
+
+# Generate an output container per variable
+ui <- fluidPage(
+  fluidRow(
+    tags$div(
+      style = "display:inline-block; max-width:150px; margin-left:50px",
+      colourInput("brush_color", "Pick a brush color", color_codes[1], palette = "limited", allowedCols = color_codes)
+    ),
+    tags$div(
+      style = "display:inline-block",
+      actionButton("clear", "Clear Selection")
+    )
+  ),
+  lapply(names(d), function(nm) plotlyOutput(nm, height = 200, width = "49%", inline = TRUE))
+)
+
+server <- function(input, output, session) {
+  
+  # Implement same render logic for each variable
+  lapply(names(d), function(nm) {
+    
+    # By letting R handle the binning, there is less data to send over the
+    # wire (and, thus, a more responsive app over back connections)
+    counts <- d[[nm]] %>%
+      bin_fixed(bins = 150) %>%
+      compute_stat(d[[nm]]) %>%
+      filter(!is.na(xmin_)) %>%
+      mutate(
+        xmid = (xmin_ + xmax_) / 2,
+        prop_ = count_ / sum(count_), 
+        zeros = 0
+      )
+    
+    output[[nm]] <- renderPlotly({
+      
+      # Draw two layers of bars, one for the overall (black)
+      # distribution, and one for the filtered data (red)
+      p <- plot_ly(
+        counts, x = ~xmid, alpha = I(0.5), 
+        source = nm, unselected = list(marker = list(opacity = 1))
+      ) %>%
+        add_bars(y = ~prop_, color = I("black")) %>%
+        layout(
+          dragmode = "select", 
+          selectdirection = "h",
+          xaxis = list(
+            title = nm,
+            range = range(d[[nm]], na.rm = TRUE) 
+          ),
+          yaxis = list(
+            title = "",
+            showticks = FALSE, 
+            showticklabels = FALSE, 
+            showgrid = FALSE
+          ),
+          barmode = "overlay",
+          showlegend = FALSE
+        )
+      
+      for (col in color_codes) {
+        p <- add_bars(p, y = ~zeros, color = I(col))
+      }
+      
+      p
+    })
+    
+    # when the selection is cleared, return the selection layer bars to 0
+    observeEvent(input$clear, {
+      plotlyProxy(nm, session) %>%
+        plotlyProxyInvoke("restyle", "y", list(counts$zeros), seq_along(color_codes))
+    })
+    
+    # each brush color code corresponds to a different trace index
+    trace_index <- reactive(match(input$brush_color, color_codes))
+    
+    observe({
+      b <- event_data("plotly_brushing", source = nm)$x
+      in_bounds <- between(d[[nm]], min(b), max(b))
+      
+      lapply(names(d), function(var) {
+        p <- plotlyProxy(var, session)
+        
+        if (is.null(b)) {
+          
+          # brush has been cleared, return the selection bars to a zero height
+          plotlyProxyInvoke(p, "restyle", "y", list(counts$zeros), trace_index())
+          
+        } else {
+          
+          # if the brush originates from the proxy target
+          # then don't compute a new marginal distribution, 
+          # just highlight the range of interest
+          props <- if (nm == var) {
+            if_else(
+              between(counts$xmin_, min(b), max(b)) & 
+                between(counts$xmax_, min(b), max(b)),
+              counts$prop_,
+              0
+            )
+          } else {
+            d[[var]] %>%
+              bin_fixed(bins = 150) %>%
+              compute_stat(d[[var]][in_bounds]) %>%
+              filter(!is.na(xmin_)) %>%
+              mutate(prop_ = count_ / sum(count_)) %>%
+              pull(prop_)
+          }
+          
+          plotlyProxyInvoke(p, "restyle", "y", list(props), trace_index())
+        }
+      })
+      
+    })
+    
+  })
+  
+}
+
+shinyApp(ui, server)