automatic legends now working

Author: Ben Moore

debug.R

@@ -4,7 +4,7 @@ library("leaflet")
 ax <- readRDS("data/accidents.rds")
 
 input <- list()
-input$color <- "Speed limit"
+input$color <- "none"
 title <- input$color
 
 col <- switch(input$color,
@@ -13,7 +13,7 @@ col <- switch(input$color,
   "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="speed_limi", type="int"))
+  list(var="none", type="none"))
 message(col)
 
 col_fn <- function(col){
@@ -22,18 +22,21 @@ col_fn <- function(col){
       return(colorNumeric("Set1", domain=ax[[col$var]]))
     } else {
       return(colorFactor("Set1", domain=ax[[col$var]]))
-    }} else return( function() "black" )
+    }} else return( function(...) "black" )
 }
 
 map <- leaflet(ax) %>% addTiles()
 
 pal <- colorNumeric("Set1", ax$speed_limi)
 
-# map %>%
-#   addCircleMarkers(data=ax, ~long, ~lat, radius=8, fillOpacity=.3,
-#     color=NA, fillColor = ~pal(speed_limi)) 
-
-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)
+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

@@ -20,6 +20,8 @@ accident_desc <- function(row)
 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,13 +40,13 @@ 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)
+    #message("alpha changed : ", input$alpha)
     input$alpha
   })
 
@@ -63,38 +65,23 @@ shinyServer(function(input, output, session) {
   })
 
   output$mymap <- renderLeaflet({
+    # 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(ax$severity)] else
-#         if(input$color == "Casualties") pal[as.factor(ax$no_casualt)] else
-#           if(input$color == "Time") cont_pal[ax$a_time_hr] else
-#             if(input$color == "Vehicles") pal[as.factor(ax$no_vehicle)] else
-#               pal[as.factor(ax$speed_limi)]
-    
-      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) #%>%
-        #addCircleMarkers(~long, ~lat, radius=~(no_vehicle+.8)**1.5, fillOpacity=input$alpha,
-         # color=NA, popup=strs, weight=2, fillColor = fillv)
-      
+    # stop spinner    
+    session$sendCustomMessage(type = "map_done", "done")
 
-      session$sendCustomMessage(type = "map_done", "done")
-      
-      l
+    l
   })
 
-#   observe({
-#     ax <- getData()
-#     alpha <- getAlpha()
-#     leafletProxy("mymap", session, data=ax) %>%
-#       addCircleMarkers(~long, ~lat, radius=~(no_vehicle+.8)**1.5, fillOpacity=alpha,
-#        color=NA, popup=strs, fillColor = "black")
-#   })
-    
   observe({
+    # modify map of changed input i.e. colour by
     ax <- getData()
     title <- input$color
 
@@ -104,32 +91,48 @@ shinyServer(function(input, output, session) {
       "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="speed_limi", type="int"))
-    message(col)
-    
+      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" )
+        }} else return( function(...) "black" )
     }
 
-    leafletProxy("mymap", session, data=ax) %>%
-      clearMarkers() %>%
-      addCircleMarkers(~long, ~lat, radius=~1+(no_vehicle**2), fillOpacity=getAlpha(),
-        color=NA, popup=strs, fillColor = ~col_fn(col)(ax[[col$var]])) %>%
-      addLegend("bottomleft", pal=col_fn(col), values=ax[[col$var]], title=title)
+    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 <- 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({
+    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)))
+        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=.2, step=.01, ticks=F),
+          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"))
 )