avoid data duplication in R leaflet

nymap.R

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")
)

nymap.Rmd

---
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)
```

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
  )
}