Faster loading!!

Courtesy timelyportforlio on github

scratch.R

@@ -96,10 +96,17 @@ tencols[which.max(work_from[1, 5:14])]
 
 
 work_from$MAX <- work_from %>% select(home:other) %>% as.matrix() %>% 
-  apply(1, which.max)
+  apply(1, function(x) {
+    ifelse(max(x) <= 0, NA, which.max(x))
+    })
 work_to$MAX <- work_to %>% select(home:other) %>% as.matrix() %>% 
-  apply(1, which.max)
+  apply(1, function(x) {
+    ifelse(max(x) <= 0, NA, which.max(x))
+    })
 work_simp$MAX <- work_simp %>% select(home:other) %>% as.matrix() %>% 
-  apply(1, which.max)
+  apply(1, function(x) {
+    ifelse(max(x) <= 0, NA, which.max(x))
+    })
+
+save(work_simp, work_to, work_from, tencols, file="viz/datasets.RData")
 
-save(work_simp, work_to, work_from, tencols, file="datasets.RData")

viz/app.R

@@ -5,6 +5,8 @@ library(rgdal)
 library(dplyr)
 library(leaflet.extras)
 
+source("leafletfunctions.R")
+
 # work_travel <- read_csv("../travel-work.csv")
 load(file="datasets.RData")
 shpf <- readOGR(dsn="../shapefiles/sa20025WGSfilcth")
@@ -27,6 +29,7 @@ startcols <- ifelse(is.na(startcols), "#808080", startcols)
 # Define UI
 ui <- fluidPage(
   useShinyjs(),
+  leafletjs,
   tags$style(type = "text/css", 
   "html, body {
     width:100%;
@@ -42,10 +45,10 @@ ui <- fluidPage(
     cursor: progress !important;
   }
   #loading p {
-    border-radius: 25px;
-    background: #FFFFFF;
-    padding: 10px;
-    border: 2px solid #000000;
+    border-radius: 5px;
+    background-color: rgba(255, 255, 255, 0.8);
+    padding: 6px 8px;
+    box-shadow: 0 0 15px rgba(0,0,0,0.2);
     font-size: 1.5em;
     font-weight: bold;
   }
@@ -79,8 +82,9 @@ server <- function(input, output) {
   p.layers <- c("polya", "polyb")
   output$map <- renderLeaflet({
     leaf <- leaflet(shpf, options = leafletOptions(minZoom = 3, maxZoom = 13)) %>% 
-      addPolygons(group = p.layers[1] ,color="#000", opacity = 1, weight=1,
+      addPolygons(color="#000", opacity = 1, weight=1,
                                 fillColor = startcols, 
+                  layerId = ~SA22018_V1,
                   label = shpf@data$SA22018__1,
                   fillOpacity = 1) %>%
       setView(174, -41, 5) %>%
@@ -93,24 +97,27 @@ server <- function(input, output) {
     leaf
   })
   updateMap <- function() {
+    selcode <- sel.SA2.code()
+    selcode <- ifelse(is.na(selcode), 0, selcode)
     shinyjs::showElement(selector="#loading p", asis = TRUE, 
                          anim=TRUE, animType = "slide")
     fcols <- startcols
-    if (sel.SA2.code() != 0) {
-      codvs <- work_simp %>% filter(work_code == sel.SA2.code())
+    
+    if (selcode != 0) {
+      codvs <- work_simp %>% filter(work_code == selcode)
       codvs <- codelist %>% left_join(codvs, by=c("sa2_code" = "res_code"))
       codvs <- tencols[codvs$MAX]
       fcols <- ifelse(is.na(codvs), "#808080", codvs)
     }
     leafletProxy("map", data = shpf) %>%
-      addPolygons(group = p.layers[2] ,color="#000", opacity = 1, weight=1,
-                                fillColor = fcols,
-                  label = shpf@data$SA22018__1,
-                  fillOpacity = 1) %>%
-      clearGroup(p.layers[1])
+      setShapeStyle(layerId = ~SA22018_V1, fillColor = fcols) %>%
+      clearControls() %>%
+      addLegend(position = "topleft",
+                colors = c(tencols, "#808080"),
+                labels = transport.t, opacity = 1)
     p.layers <<- rev(p.layers)
     shinyjs::hideElement(selector="#loading p", asis=TRUE, 
-                         anim=TRUE, animType = "slide", time = 7)
+                         anim=TRUE, animType = "slide")
   }
   observeEvent(input$map_shape_click, {
     p <- input$map_shape_click
@@ -120,11 +127,13 @@ server <- function(input, output) {
     proj4string(pdat) <- proj4string(shpf)
     ppoly <- over(pdat, shpf)
     codetmp <- as.numeric(as.character(ppoly[1,"SA22018_V1"]))
+    codetmp <- ifelse(is.na(codetmp), 0, codetmp)
     sel.SA2.code(ifelse(sel.SA2.code() == codetmp, 0, codetmp))
     updateMap()
   })
   output$lochtml <- renderUI({
     seled <- sel.SA2.code()
+    seled <- ifelse(is.na(seled), 0, seled)
     if (seled == 0) {
       HTML("")
     } else {

viz/leafletfunctions.R

@@ -0,0 +1,125 @@
+# Courtesy timelyportfolio on github: 
+# https://github.com/rstudio/leaflet/issues/496#issuecomment-650122985
+### R functions
+# add in methods from https://github.com/rstudio/leaflet/pull/598
+setCircleMarkerRadius <- function(map, layerId, radius, data=getMapData(map)){
+  options <- list(layerId = layerId, radius = radius)
+  # evaluate all options
+  options <- evalFormula(options, data = data)
+  # make them the same length (by building a data.frame)
+  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
+  leaflet::invokeMethod(map, data, "setRadius", options$layerId, options$radius)
+}
+
+setCircleMarkerStyle <- function(map, layerId
+                                 , radius = NULL
+                                 , stroke = NULL
+                                 , color = NULL
+                                 , weight = NULL
+                                 , opacity = NULL
+                                 , fill = NULL
+                                 , fillColor = NULL
+                                 , fillOpacity = NULL
+                                 , dashArray = NULL
+                                 , options = NULL
+                                 , data = getMapData(map)
+){
+  if (!is.null(radius)){
+    setCircleMarkerRadius(map, layerId = layerId, radius = radius, data = data)
+  }
+  
+  options <- c(list(layerId = layerId),
+               options,
+               filterNULL(list(stroke = stroke, color = color,
+                               weight = weight, opacity = opacity,
+                               fill = fill, fillColor = fillColor,
+                               fillOpacity = fillOpacity, dashArray = dashArray
+               )))
+  
+  if (length(options) < 2) { # no style options set
+    return()
+  }
+  # evaluate all options
+  options <- evalFormula(options, data = data)
+  
+  # make them the same length (by building a data.frame)
+  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
+  layerId <- options[[1]]
+  style <- options[-1] # drop layer column
+  
+  #print(list(style=style))
+  leaflet::invokeMethod(map, data, "setStyle", "marker", layerId, style);
+}
+
+setShapeStyle <- function( map, data = getMapData(map), layerId,
+                           stroke = NULL, color = NULL,
+                           weight = NULL, opacity = NULL,
+                           fill = NULL, fillColor = NULL,
+                           fillOpacity = NULL, dashArray = NULL,
+                           smoothFactor = NULL, noClip = NULL,
+                           options = NULL
+){
+  options <- c(list(layerId = layerId),
+               options,
+               filterNULL(list(stroke = stroke, color = color,
+                               weight = weight, opacity = opacity,
+                               fill = fill, fillColor = fillColor,
+                               fillOpacity = fillOpacity, dashArray = dashArray,
+                               smoothFactor = smoothFactor, noClip = noClip
+               )))
+  # evaluate all options
+  options <- evalFormula(options, data = data)
+  # make them the same length (by building a data.frame)
+  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
+  
+  layerId <- options[[1]]
+  style <- options[-1] # drop layer column
+  
+  #print(list(style=style))
+  leaflet::invokeMethod(map, data, "setStyle", "shape", layerId, style);
+}
+
+### JS methods
+leafletjs <-  tags$head(
+  # add in methods from https://github.com/rstudio/leaflet/pull/598
+  tags$script(HTML(
+    '
+window.LeafletWidget.methods.setStyle = function(category, layerId, style){
+  var map = this;
+  if (!layerId){
+    return;
+  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
+    layerId = [layerId];
+  }
+
+  //convert columnstore to row store
+  style = HTMLWidgets.dataframeToD3(style);
+  //console.log(style);
+
+  layerId.forEach(function(d,i){
+    var layer = map.layerManager.getLayer(category, d);
+    if (layer){ // or should this raise an error?
+      layer.setStyle(style[i]);
+    }
+  });
+};
+
+window.LeafletWidget.methods.setRadius = function(layerId, radius){
+  var map = this;
+  if (!layerId){
+    return;
+  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
+    layerId = [layerId];
+    radius = [radius];
+  }
+
+  layerId.forEach(function(d,i){
+    var layer = map.layerManager.getLayer("marker", d);
+    if (layer){ // or should this raise an error?
+      layer.setRadius(radius[i]);
+    }
+  });
+};
+'
+  ))
+)