Merge pull request #4 from blmoore/auto-legends

merge legends branch

Author: blmoore

debug.R

@@ -0,0 +1,42 @@
+library("leaflet")
+
+
+ax <- readRDS("data/accidents.rds")
+
+input <- list()
+input$color <- "none"
+title <- input$color
+
+col <- switch(input$color,
+  "Severity"    = list(var="severity", type="factor"),
+  "Casualties"  = list(var="no_casualt", type="int"),
+  "Time"        = list(var="a_time_hr", type="int"),
+  "Vehicles"    = list(var="no_vehicle", type="int"),
+  "Speed limit" = list(var="speed_limi", type="int"),
+  list(var="none", type="none"))
+message(col)
+
+col_fn <- function(col){
+  if(col$type != "none"){
+    if(col$type == "int") {
+      return(colorNumeric("Set1", domain=ax[[col$var]]))
+    } else {
+      return(colorFactor("Set1", domain=ax[[col$var]]))
+    }} else return( function(...) "black" )
+}
+
+map <- leaflet(ax) %>% addTiles()
+
+pal <- colorNumeric("Set1", ax$speed_limi)
+
+if(col[[1]] == "none"){
+  map %>%
+    addCircleMarkers(data=ax, ~long, ~lat, radius=8, fillOpacity=.3,
+      color=NA, fillColor = ~col_fn(col)(ax[[col$var]])) 
+  } else {
+    map %>%
+      addCircleMarkers(data=ax, ~long, ~lat, radius=8, fillOpacity=.3,
+        color=NA, fillColor = ~col_fn(col)(ax[[col$var]])) %>%
+      addLegend("bottomleft", pal=col_fn(col), values=ax[[col$var]], title=title,
+        layerId="legend")
+}

server.R

@@ -11,15 +11,17 @@ accidents <- readRDS("data/accidents.rds")
 accidents <- accidents[sample(1:nrow(accidents), 2000),]
 
 accident_desc <- function(row)
-  with(as.list(row), paste0(strong(
-    format.Date(a_date, "%a %d %B %Y"), ": "), "A ", 
+  with(as.list(row), paste0("<b>",
+    format.Date(a_date, "%a %d %B %Y"), ":</b> A ", 
     tolower(severity), " collision in a ", speed_limi, 
     " MPH zone, involving ", no_vehicle, " vechicle(s) with ",
     no_casualt, " casualtie(s). Weather was ", tolower(weather)))
 
 strs <- apply(accidents, 1, accident_desc)
 names(strs) <- NULL
 
+accidents$text <- strs
+
 # summary plot munging
 d2 <- accidents %>% group_by(as.factor(ym)) %>%
   summarise(n=n())
@@ -38,37 +40,99 @@ colnames(clean) <- c("Severity", "No. vehicles",
   "Road conditions", "Special conditions", "Postcode")
 
 shinyServer(function(input, output, session) {
-
+  
+  getData <- reactive({
+    subset(accidents, a_date >= input$dates[[1]] & a_date <= input$dates[[2]])
+  })
+  
+  getAlpha <- reactive({
+    #message("alpha changed : ", input$alpha)
+    input$alpha
+  })
+  
+  legend <- reactive({
+    proxy <- leafletProxy("mymap", session, data=accidents)
+    if(input$color == "Speed limit"){
+      message("triggered")
+      pal <- colorFactor(palette="Set1", domain=factor(accidents$speed_limi))
+      l <- proxy %>% 
+        addLegend("bottomleft", pal=pal, values=~speed_limi, 
+          labFormat=labelFormat(suffix=" mph"), title="Speed limit")
+      return(l)
+    } else {
+      return(proxy)
+    }
+  })
+  
   output$mymap <- renderLeaflet({
-    accidents <- subset(accidents, a_date >= input$dates[[1]] & a_date <= input$dates[[2]])
+    # build base map on load
+    ax <- getData()
+        
+    l <- leaflet(data=ax) %>% 
+      addTiles(urlTemplate="http://openmapsurfer.uni-hd.de/tiles/roadsg/x={x}&y={y}&z={z}") %>%
+      addTiles('http://{s}.tile.openstreetmap.se/hydda/roads_and_labels/{z}/{x}/{y}.png', 
+        attribution='&copy; <a href="http://www.openstreetmap.org/copyright">OpenStreetMap</a>') %>%
+      setView(lng=-3.19, lat=55.95, zoom=13) #%>%
 
-    fillv <- if(input$color == "None") "black" else 
-      if(input$color == "Severity") pal[as.factor(accidents$severity)] else
-        if(input$color == "Casualties") pal[as.factor(accidents$no_casualt)] else
-          if(input$color == "Time") cont_pal[accidents$a_time_hr] else
-            if(input$color == "Vehicles") pal[as.factor(accidents$no_vehicle)] else
-              pal[as.factor(accidents$speed_limi)]
+    # stop spinner    
+    session$sendCustomMessage(type = "map_done", "done")
 
-      l <- leaflet(data=accidents) %>% 
-        addTiles(urlTemplate="http://openmapsurfer.uni-hd.de/tiles/roadsg/x={x}&y={y}&z={z}") %>%
-        addTiles('http://{s}.tile.openstreetmap.se/hydda/roads_and_labels/{z}/{x}/{y}.png', 
-          attribution='&copy; <a href="http://www.openstreetmap.org/copyright">OpenStreetMap</a>') %>%
-        setView(lng=-3.19, lat=55.95, zoom=13) %>%
-        addCircleMarkers(~long, ~lat, radius=~(no_vehicle+.8)**1.5, fillOpacity=input$alpha,
-          color=NA, popup=strs, weight=2, fillColor = fillv)
-      
-      session$sendCustomMessage(type = "map_done", "done")
+    l
+  })
+  
+  observe({
+    # modify map of changed input i.e. colour by
+    ax <- getData()
+    title <- input$color
+    
+    col <- switch(input$color,
+      "Severity"    = list(var="severity", type="factor"),
+      "Casualties"  = list(var="no_casualt", type="int"),
+      "Time"        = list(var="a_time_hr", type="int"),
+      "Vehicles"    = list(var="no_vehicle", type="int"),
+      "Speed limit" = list(var="speed_limi", type="int"),
+      list(var="none", type="none"))
+        
+    col_fn <- function(col){
+      if(col$type != "none"){
+        if(col$type == "int") {
+          return(colorNumeric("Set1", domain=ax[[col$var]]))
+        } else {
+          return(colorFactor("Set1", domain=ax[[col$var]]))
+        }} else return( function(...) "black" )
+    }
+    
+    if(col$var == "none"){
+      l <- leafletProxy("mymap", session, data=ax) %>%
+        addCircleMarkers(~long, ~lat, radius=~1+(no_vehicle**1.5), fillOpacity=getAlpha(),
+          color=NA, popup=~text, fillColor = "black",
+          layerId=paste0("p", 1:nrow(ax))) %>%
+        removeControl(layerId="legend")
+  
+    } else {
 
-      l
+    l <- leafletProxy("mymap", session, data=ax) %>%
+      addCircleMarkers(~long, ~lat, radius=~1+(no_vehicle**1.5), fillOpacity=getAlpha(),
+        color=NA, popup=~text, fillColor = ~col_fn(col)(ax[[col$var]]),
+        layerId=paste0("p", 1:nrow(ax))) %>%
+      addLegend("bottomleft", pal=col_fn(col), values=ax[[col$var]], 
+        title=title, layerId="legend")
+    }
+    
+    l
   })
 
   output$monthTotals <- renderPlot({
-    ggplot(d2, aes(x=zoo::as.Date(zoo::as.yearmon(ym)), y=n)) + 
-      geom_area() + theme_minimal() + 
-      labs(x="", y="Recorded collisions\nper month") +
-      scale_y_continuous(expand=c(0,0))
+    d2 <- getData() %>% group_by(as.factor(ym)) %>%
+      summarise(n=n())
+    colnames(d2) <- c("ym", "n")
+    
+    print(ggplot(d2, aes(x=zoo::as.Date(zoo::as.yearmon(ym)), y=n)) + 
+        geom_area() + theme_minimal() + 
+        labs(x="", y="Recorded collisions\nper month") +
+        scale_y_continuous(expand=c(0,0)))
   })
-
+  
   output$table <- DT::renderDataTable({
     DT::datatable(clean, filter = 'top', options = list(
       pageLength = 10, autoWidth = TRUE))

styles.css

@@ -27,13 +27,13 @@ h1, h2, h3, h4 { font-weight: 400; }
   padding: 0 20px 20px 20px;
   cursor: move;
   /* Fade out while not hovering */
-  opacity: 0.65;
+  opacity: 0.7;
   zoom: 0.9;
   transition: opacity 500ms 1s;
 }
 #controls:hover {
   /* Fade in while hovering */
-  opacity: 0.95;
+  opacity: 1;
   transition-delay: 0;
 }
 

ui.R

@@ -39,11 +39,11 @@ $( 'div#mymap' ).append(spinner.el);"),
           label = 'Occurred between:',
           start = as.Date("2010-01-01"), end = as.Date("2013-07-01")),
 
-        selectInput("color", "Color by:", 
+        selectInput("color", "Colour by:", 
           choices=c("None", "Severity", "Casualties", "Time", "Vehicles", "Speed limit")),
 
         sliderInput("alpha", "Opacity:",
-          min=0, max=1, value=.3),
+          min=0, max=1, value=.4, step=.025, ticks=T),
 
         hr(),
         h4("Summary plots"),
@@ -65,10 +65,10 @@ $( 'div#mymap' ).append(spinner.el);"),
           $( "div#mymap" ).remove(spinner);
         });')
 
-      ),
+      )#,
 
-      tags$div(id="cite",
-        a("@benjaminlmoore", href="http://twitter.com/benjaminlmoore"))
+     # tags$div(id="cite",
+      #  a("@benjaminlmoore", href="http://twitter.com/benjaminlmoore"))
     )
   ), tabPanel("Table", DT::dataTableOutput("table"))
 )