Speed up filtering in Shiny app

[ramhiser]

After the Shiny app is launched via shiny_choro, the rendering after a dropdown has been selected needs to be sped up. Currently, this delay can take 2-3 seconds and should be closer to instantaneous. It's possible that the bottleneck is the leaflet package, but it's unclear at the moment.

Example to replicate behavior:

library(noncensus)
example(shiny_choro)

[ramhiser]

Similar to #26, a speedup can be had by replacing base::merge. The obvious replacement is to use dplyr::left_join, but the latter does not produce the same exact same outcome. Moreover, the speed gains to be had are quite small.

Based on example(shiny_choro), I first ran global.r from the Shiny app. Then from server.r, I ran the following code to mimic the Shiny app's filtering behavior:

input <- list(cats="0 - 4")
comp_data <- filter(comp_two, categories == input$cats | is.na(categories))

fips_colors <- comp_data %>% dplyr::filter(!is.na(color)) %>%
  dplyr::select(fips, color, group) %>%
  unique(.)

Here is the benchmark based on the original base::merge and a slightly faster alternative.

library(microbenchmark)
microbenchmark(old_code={
    max_group <- max(comp_data$group, na.rm=TRUE)
    groups_df <- tbl_df(data.frame(group=seq_len(max_group)))
    foo <- merge(groups_df, fips_colors, by = "group", all.x = T)
  },
  new_code={
    seq_group <- seq_len(max(comp_data$group, na.rm=TRUE))
    group_no_color <- which(!(seq_group %in% fips_colors$group))
    group_no_color <- data.frame(group=group_no_color, fips=NA, color=NA)
    bar <- rbind(fips_colors, group_no_color)
  },
  times=1000
)
> Unit: milliseconds
     expr      min       lq   median       uq      max neval
 old_code 4.448579 4.612098 4.687042 4.878248 32.15603  1000
 new_code 2.235753 2.316671 2.498932 2.585444 31.43021  1000

Although the newer approach is approximately 2.3 milliseconds faster on average, this is not much of a gain. Clearly, the performance improvement should happen elsewhere.

[ramhiser]

The above was wasted yak shaving. Instead, I realized that no merge step was needed. Moreover, the code was simplified by updating the code for fips_colors to:

fips_colors <- comp_data %>%
  dplyr::select(fips, color, group) %>%
  unique %>%
  arrange(group)

[ramhiser]

The time to render is now due to two sources.

1. The filter time
2. The render time

The filter requires approximately 800 milliseconds and is due to:

companyToUse <- reactive({
  if (is.null(comp_two$categories)) {
    comp_two
  } else {
    filter(comp_two, categories == input$cats | is.na(categories))
  }
})

The render time is about 2-3 seconds and occurs when map$addPolygon is called. The driver code is:

map$addPolygon(comp_data$lat, comp_data$long,
               fips_colors$group,
               lapply(fips_colors$color, function(x) {
                 list(fillColor = x)
           }),
               list(fill=T, fillOpacity=1,
                    stroke=TRUE, opacity=1, color="white", weight=1)
)

While the filter could likely be improved further, the render code is the largest source of delay.