Skip to content

Instantly share code, notes, and snippets.

@timelyportfolio

timelyportfolio/nymap.R

Last active Aug 7, 2020
Embed
What would you like to do?
avoid data duplication in R leaflet
library(tidycensus)
library(leaflet)
library(tidyr)
library(dplyr)
library(purrr)
library(sf)
library(htmlwidgets)
library(svglite)
ny_counties <- get_acs(
geography = "county", survey = "acs5", variables = c(population = "B01003_001", pop_under_5 = "B01001_003"), year = 2018, geometry = TRUE, state = 36
) %>%
as_tibble() %>%
select(-moe) %>%
pivot_wider(names_from = variable, values_from = estimate) %>%
st_as_sf() %>%
mutate(svgimage = map2_chr(population, pop_under_5, function(x, y) {
s <- svgstring(standalone = FALSE)
barplot(c(x,y))
dev.off()
paste('<div class="popgraph">',
sub("line, polyline, polygon, path, rect, circle",
".popgraph line, .popgraph polyline, .popgraph polygon, .popgraph path, .popgraph rect, .popgraph circle",
s()),
'</div>'
)
}))
pal1 <- colorNumeric("viridis", domain = ny_counties$population)
pal2 <- colorNumeric("plasma", domain = ny_counties$pop_under_5)
nymap <- leaflet(ny_counties) %>%
addPolygons(
fillColor = ~pal1(population),
popup = ~svgimage,
fillOpacity = 1,
group = "population") %>%
addPolygons(
fillColor = ~pal2(pop_under_5),
popup = ~svgimage,
fillOpacity = 1,
group = "population under 5") %>%
addLayersControl(
baseGroups = c("population", "population under 5"),
options = layersControlOptions(collapsed = FALSE))
# this will serve as or size benchmark
htmlwidgets::saveWidget(nymap, file = "nymap.html")
file.size("nymap.html")
# to estimate size of the map we can use lobstr::obj_size
lobstr::obj_size(as.character(nymap))
# you would expect crosstalk to reduce size by referencing rather than copying
# but unfortunately that is not the case
library(crosstalk)
shared_data <- SharedData$new(ny_counties)
nymap_crosstalk <- leaflet(shared_data) %>%
addPolygons(
fillColor = ~pal1(population),
popup = ~svgimage,
fillOpacity = 1,
group = "population") %>%
addPolygons(
fillColor = ~pal2(pop_under_5),
popup = ~svgimage,
fillOpacity = 1,
group = "population under 5") %>%
addLayersControl(
baseGroups = c("population", "population under 5"),
options = layersControlOptions(collapsed = FALSE))
lobstr::obj_size(as.character(nymap_crosstalk))
# so I would propose that we reference rather than copy the data
# by some manual manipulation (could build some functions eventually)
# and use of htmlwidgets::JS()
# I think constructing in R/leaflet is still easier so let's start
# with a normal leaflet map
nymap_smaller <- leaflet(ny_counties) %>%
addPolygons(
fillColor = ~pal1(population),
popup = ~svgimage,
fillOpacity = 1,
group = "population") %>%
addPolygons(
fillColor = ~pal2(pop_under_5),
popup = ~svgimage,
fillOpacity = 1,
group = "population under 5") %>%
addLayersControl(
baseGroups = c("population", "population under 5"),
options = layersControlOptions(collapsed = FALSE))
# if we look at the calls we can see the data duplication
# calls 1 and 2 are addPolygons
str(purrr::map(nymap_smaller$x$calls[1:2],~pluck(.x$args[[1]])), max.level=1)
# so let's try to construct a data source in JavaScript with JSON
data_json <- jsonlite::toJSON(nymap_smaller$x$calls[[1]]$args[[1]], dataframe="columns", auto_unbox=TRUE)
# uncomment the listviewer to see what we are making
# but we should have an arrray of arrays of coordinates; 62 elements or nrow(counties)
#listviewer::reactjson(data_json)
# this is where it gets manual but we could clean up and make generic
# we will need a script to add the data as global or we could follow better practices
# if necessary
scr <- htmltools::tags$script(htmltools::HTML(
sprintf("var data = %s", data_json)
))
nymap_smaller$x$calls[[1]]$args[[1]] <- htmlwidgets::JS("data")
nymap_smaller$x$calls[[2]]$args[[1]] <- htmlwidgets::JS("data")
# combine the script and the widget
tl <- htmltools::tagList(scr, nymap_smaller)
# see if it works
htmltools::browsable(tl)
# see if file size is smaller
sprintf(
"nymap size: %s while nymap_smaller size: %s saving %s",
lobstr::obj_size(as.character(nymap)),
lobstr::obj_size(as.character(nymap_smaller)),
lobstr::obj_size(as.character(nymap)) - lobstr::obj_size(as.character(tl))
)
# if in markdown this will save by default standalone and our job is mostly done
# however if we want to save standalone html from tags we need to use a function
# happy to share options but I think we are in markdown context so possibly not necessary
# the file will still be big since dependencies are included in standalone
# we can make smaller by using CDN if internet is available
substitute_data <- function(map, js_name = NULL) {
# make possible bad assumption that first addPolygons will
# contain the same data as all other addPolygons
dat <- Filter(
function(call) {
call$method == "addPolygons"
},
map$x$calls
)[[1]]$args[[1]]
data_json <- jsonlite::toJSON(
dat,
dataframe="columns",
auto_unbox=TRUE
)
scr <- htmltools::tags$script(htmltools::HTML(
sprintf("var %s = %s", js_name, data_json)
))
map$x$calls <- Map(
function(call) {
if(call$method == "addPolygons" && identical(dat, call$args[[1]])) {
call$args[[1]] <- htmlwidgets::JS(js_name)
call
} else {
call
}
},
map$x$calls
)
htmltools::tagList(
scr,
map
)
}
htmltools::browsable(
substitute_data(nymap, "data")
)
---
title: "avoid leaflet data duplication"
author: "Kent Russell"
date: "8/7/2020"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
```{r "get_data"}
library(tidycensus)
library(leaflet)
library(tidyr)
library(dplyr)
library(purrr)
library(sf)
library(htmlwidgets)
library(svglite)
ny_counties <- get_acs(
geography = "county", survey = "acs5", variables = c(population = "B01003_001", pop_under_5 = "B01001_003"), year = 2018, geometry = TRUE, state = 36
) %>%
as_tibble() %>%
select(-moe) %>%
pivot_wider(names_from = variable, values_from = estimate) %>%
st_as_sf() %>%
mutate(svgimage = map2_chr(population, pop_under_5, function(x, y) {
s <- svgstring(standalone = FALSE)
barplot(c(x,y))
dev.off()
paste('<div class="popgraph">',
sub("line, polyline, polygon, path, rect, circle",
".popgraph line, .popgraph polyline, .popgraph polygon, .popgraph path, .popgraph rect, .popgraph circle",
s()),
'</div>'
)
}))
pal1 <- colorNumeric("viridis", domain = ny_counties$population)
pal2 <- colorNumeric("plasma", domain = ny_counties$pop_under_5)
```
```{r "make_map"}
# so I would propose that we reference rather than copy the data
# by some manual manipulation (could build some functions eventually)
# and use of htmlwidgets::JS()
# I think constructing in R/leaflet is still easier so let's start
# with a normal leaflet map
nymap_smaller <- leaflet(ny_counties) %>%
addPolygons(
fillColor = ~pal1(population),
popup = ~svgimage,
fillOpacity = 1,
group = "population") %>%
addPolygons(
fillColor = ~pal2(pop_under_5),
popup = ~svgimage,
fillOpacity = 1,
group = "population under 5") %>%
addLayersControl(
baseGroups = c("population", "population under 5"),
options = layersControlOptions(collapsed = FALSE))
```
```{r "remove_duplication"}
# so let's try to construct a data source in JavaScript with JSON
data_json <- jsonlite::toJSON(nymap_smaller$x$calls[[1]]$args[[1]], dataframe="columns", auto_unbox=TRUE)
scr <- htmltools::tags$script(htmltools::HTML(
sprintf("var data = %s", data_json)
))
nymap_smaller$x$calls[[1]]$args[[1]] <- htmlwidgets::JS("data")
nymap_smaller$x$calls[[2]]$args[[1]] <- htmlwidgets::JS("data")
# combine the script and the widget
htmltools::tagList(scr, nymap_smaller)
```
@timelyportfolio

This comment has been minimized.

Copy link
Owner Author

@timelyportfolio timelyportfolio commented Aug 7, 2020

function for doing the above


substitute_data <- function(map, js_name = NULL) {
  # make possible bad assumption that first addPolygons will
  #   contain the same data as all other addPolygons
  dat <- Filter(
    function(call) {
      call$method == "addPolygons"
    },
    map$x$calls
  )[[1]]$args[[1]]
  data_json <- jsonlite::toJSON(
    dat,
    dataframe="columns",
    auto_unbox=TRUE
  )
  scr <- htmltools::tags$script(htmltools::HTML(
    sprintf("var %s = %s", js_name, data_json)
  ))
  
  map$x$calls <- Map(
    function(call) {
      if(call$method == "addPolygons" && identical(dat, call$args[[1]])) {
        call$args[[1]] <- htmlwidgets::JS(js_name)
        call
      } else {
        call
      }
    },
    map$x$calls
  )
  
  htmltools::tagList(
    scr,
    map
  )
}

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment