plotlyProxy on map in shiny

We have a plotly map that receives points to plot from a series of plotly events in preceeding charts. We want the user to be able to change the points on the map by clicking a crime category, then zipcode, then weekday. Currently, this causes the map to be completely redrawn, which is a problem with big datasets, as well as the zoom resetting. How can we set up our data and plotlyProxy to change points on the map, without completely re-rendering it?


library(rio)
library(shiny)
library(data.table)
library(tidyverse)
library(lubridate)
library(sf)
library(plotly)

# data source: 
# https://data.cityofchicago.org/Public-Safety/Crimes-2001-to-present/ijzp-q8t2 (file size: 1.8GB)

#---- data ----
df <- rio::import(here::here("Crimes_-_2001_to_present.csv"))

picklist_options <- c("nibrs_crime_category", "nibrs_crime")

df <- df %>%
  janitor::clean_names() %>%
  filter(!is.na(latitude),
         !is.na(longitude)) %>%
  transmute(longitude,
            latitude,
            zip_code = fct_lump(as.factor(zip_codes), 20),
            date_occurred = as.Date(lubridate::mdy_hms(date)),
            nibrs_crime_category = primary_type,     # renamed to match a different dataset
            nibrs_crime = location_description) %>%  # renamed to match a different dataset
  filter(lubridate::year(date_occurred) == 2018) %>%
  filter(nibrs_crime_category != "",
         nibrs_crime != "") %>%
  filter(!is.na(zip_code),
         !is.na(longitude),
         !is.na(latitude),
         !is.na(nibrs_crime_category),
         !is.na(nibrs_crime)) %>%
  mutate(zip_code = as.factor(as.character(zip_code))) %>%
  mutate(zip_code = fct_lump(zip_code, 20)) %>%
  filter(zip_code != "Other") %>%
  mutate_at(vars(c({{picklist_options}})), ~as.character(.)) %>%
  mutate_at(vars(c({{picklist_options}})), ~str_replace_all(., "[:punct:]", " ")) %>%
  mutate_at(vars(c({{picklist_options}})), ~str_remove_all(., '"')) %>%
  mutate_at(vars(c({{picklist_options}})), ~str_replace_all(., "\\s{2,10}", " ")) %>%
  mutate_at(vars(c({{picklist_options}})), ~str_trim(.)) %>%
  mutate_at(vars(c({{picklist_options}}, zip_code)), ~as.factor(.)) %>%
  mutate_at(vars(c({{picklist_options}}, zip_code)), ~fct_explicit_na(., "Missing")) %>%
  mutate(week_day = lubridate::wday(date_occurred,
                                    label = TRUE,
                                    abbr = FALSE))

df_sf <- st_as_sf(df, coords = c("longitude", "latitude"), crs = 4326)

cats <- df %>% 
  count(nibrs_crime_category, sort = TRUE) %>% 
  mutate(nibrs_crime_category = ordered(nibrs_crime_category, levels = nibrs_crime_category))

types <- df %>% 
  count(nibrs_crime, sort = TRUE) %>% 
  mutate(nibrs_crime = ordered(nibrs_crime, levels = nibrs_crime))

zip_cat_counts <- df %>%
  count(zip_code, nibrs_crime_category, sort = TRUE) %>%
  drop_na() %>%
  mutate(zip_code = ordered(zip_code, levels = unique(zip_code)))

zip_type_counts <- df %>%
  count(zip_code, nibrs_crime, sort = TRUE) %>%
  drop_na() %>%
  mutate(zip_code = ordered(zip_code, levels = unique(zip_code)))

# pieces to build dataframes below
zips <- unique(as.character(df$zip_code))
ec <- unique(as.character(df$nibrs_crime_category))
et <- unique(as.character(df$nibrs_crime))

cat_counts_base <- 
  data.frame(
    zip_code = sort(rep(zips, length(ec))),
    nibrs_crime_category = ec,
    n = 0,
    stringsAsFactors = FALSE
  ) %>% 
  as_tibble() %>% 
  arrange(zip_code)

type_counts_base <- 
  data.frame(
    zip_code = sort(rep(zips, length(et))),
    nibrs_crime = et,
    n = 0,
    stringsAsFactors = FALSE
  ) %>% 
  as_tibble() %>% 
  arrange(zip_code)

zip_cat_counts <-
  cat_counts_base %>% 
  left_join(zip_cat_counts, by = c("zip_code", "nibrs_crime_category")) %>% 
  replace_na(list(n.y = 0)) %>% 
  select(-n.x) %>% 
  rename(n = n.y) %>% 
  as.data.table()

setkey(zip_cat_counts, nibrs_crime_category)

zip_type_counts <-
  type_counts_base %>% 
  left_join(zip_type_counts, by = c("zip_code", "nibrs_crime")) %>% 
  replace_na(list(n.y = 0)) %>% 
  select(-n.x) %>% 
  rename(n = n.y) %>% 
  as.data.table()

setkey(zip_type_counts, nibrs_crime)

#---- ui ----

ui <- fluidPage(
  fluidRow(
    column(
      width = 3,
      titlePanel("click Events"),
      wellPanel(
        selectInput(
          inputId = "variable_choice",
          label = "Choose a crime variable", 
          choices = c("nibrs_crime",
                      "nibrs_crime_category"),
          selected = "nibrs_crime_category"
        ),
        tags$p("click over a bar to see how those events a distributed across zips")
      )
    ),
    column(
      style = "padding-top: 50px;",
      width = 9,
      fluidRow(
        column(
          width = 7,
          # h5("Police Incidents"),
          div(style = "height: 375px;",
              plotlyOutput("category_counts"))
        ),
        column(
          width = 5,
          # h5("Time Distribution"),
          div(style = "height: 375px;",
              plotlyOutput("event_timeline")
          )
        )
      ),
      fluidRow(
        column(
          width = 7,
          # h5("Geographic Distribution"),
          div(style = "height: 375px;",
              plotlyOutput("zip_code_counts")
          )
        ),
        column(
          width = 5,
          # h5("Weekday Distribution"),
          div(style = "height: 375px;",
              plotlyOutput("wday_counts")
          )
        )
      ),
      fluidRow(
        column(
          width = 12,
          # h5("map"),
          div(style = "height: 400px;",
              plotlyOutput("weekday_map")
          )
        )
      )
    )
  )
)


#---- server ----

server <- function(session, input, output) {
  
  data <- eventReactive(input$variable_choice, {
    
    if (input$variable_choice == "nibrs_crime_category") {
      cats
    } else {
      types
    }
    
  })
  
  my_height <- 300
  
  #---- plotly category counts ----
  output$category_counts <- renderPlotly({
    
    m <- list(
      t = 75,
      r = 50,
      l = 50,
      b = 120
    )
    
    plot_ly(
      height = my_height,
      data = data(),
      source = "categories",
      x = data()[[1]],
      y = data()[[2]],
      type = "bar",
      marker = list(
        color = "#b3cccc",
        line = list(
          color = "#ffffff",
          width = 1
        )
      )
    ) %>%
      layout(
        title = "Police Incidents",
        margin = m,
        xaxis = list(
          tickangle = 90,
          range = list(
            0,
            20
          ),
          tickfont = list(
            size = 9
          )
        )
      )
    
  })
  
  # capture category click event
  category_click <- reactive({
    
    event_data("plotly_click",
               source = "categories")
    
  })
  
  
  # filter data based on name of bar
  zip_data <- eventReactive(category_click(), {
    
    cat(file = stderr(), "\n... category_click()[['x']] is ", category_click()[["x"]], "\n")
    
    if(input$variable_choice == "nibrs_crime_category") {
      zip_cat_counts[nibrs_crime_category == category_click()[["x"]],]
    } else {
      zip_type_counts[nibrs_crime == category_click()[["x"]],]
    }
    
  })
  
  #---- plotly zip_code counts ----
  output$zip_code_counts <- renderPlotly({
    
    m <- list(
      t = 75,
      r = 50,
      l = 50,
      b = 75
    )
    
    p <- plot_ly(
      height = my_height,
      data = zip_data(),
      source = "zips",
      x = zip_data()[[1]],
      y = zip_data()[[3]],
      type = "bar",
      marker = list(color = "#b3cccc")
    ) %>%
      layout(
        dragmode = "pan",
        title = "Zipcode Distribution",
        margin = m,
        yaxis = list(
          rangemode = list(
            0,
            max(zip_data()$n)
          )
        ),
        xaxis = list(
          tickangle = 90,
          range = list(
            0,
            20
          ),
          tickfont = list(
            size = 9
          )
        )
      ) %>% 
      config(
        displayModeBar = TRUE
      )
    
    p <- event_register(p, event = 'plotly_click')
    
    p
    
  })
  
  
  # filter data based on name of bar
  time_data <- eventReactive(category_click(), {
    
    if(input$variable_choice == "nibrs_crime_category") {
      df %>% 
        select(nibrs_crime_category, date_occurred) %>% 
        filter(nibrs_crime_category == category_click()[["x"]]) %>% 
        arrange(date_occurred) %>% 
        mutate(date_occurred = lubridate::floor_date(date_occurred, "week")) %>% 
        count(date_occurred)
    } else if(input$variable_choice == "nibrs_crime") {
      df %>% 
        select(nibrs_crime, date_occurred) %>% 
        filter(nibrs_crime == category_click()[["x"]]) %>% 
        arrange(date_occurred) %>% 
        mutate(date_occurred = lubridate::floor_date(date_occurred, "week")) %>% 
        count(date_occurred)
    }
    
  })
  
  
  #---- plotly timeline ----
  output$event_timeline <- renderPlotly({
    
    m <- list(
      t = 75,
      l = 50,
      r = 50,
      b = 50
    )
    
    plot_ly(
      height = my_height * .75,
      data = time_data(),
      x = time_data()[[1]],
      y = time_data()[[2]],
      type = "scatter",
      mode = "lines",
      line = list(
        color = '#94b8b8',
        width = 1
      )
    ) %>%
      layout(
        title = "Time Distribution",
        margin = m,
        xaxis = list(
          tickfont = list(
            size = 9
          )
        )
      ) %>% 
      config(
        displayModeBar = TRUE
      )
    
  })
  
  # capture zip_code click event
  zip_code_click <- reactive({
    
    pclick <- event_data("plotly_click",
                         source = "zips")
    
    cat(file = stderr(), "\n...inside zip_code_click: ", pclick[["x"]], "...\n")
    
    pclick
    
  })
  
  
  
  # weekday counts
  wday_data <- eventReactive(zip_code_click(), {
    
    if(input$variable_choice == "nibrs_crime_category") {
      dat <- df %>% 
        select(zip_code, nibrs_crime_category, week_day) %>% 
        filter(nibrs_crime_category == category_click()[["x"]],
               zip_code == zip_code_click()[["x"]]) %>% 
        count(week_day)
    } else if(input$variable_choice == "nibrs_crime") {
      dat <- df %>% 
        select(zip_code, nibrs_crime, week_day) %>% 
        filter(nibrs_crime == category_click()[["x"]],
               zip_code == zip_code_click()[["x"]]) %>% 
        count(week_day)
    }
    
    dat
    
    
  })
  
  
  # #---- plotly weekday counts ----
  output$wday_counts <- renderPlotly({
    
    m <- list(
      t = 75,
      r = 50,
      l = 50,
      b = 75
    )
    
    plot_ly(
      height = 300,
      data = wday_data(),
      source = "wday",
      x = ~week_day,
      y = 1,
      type = "scatter",
      mode = "markers",
      marker = list(
        color = ~n,
        colors = "PiYG",
        size = 35,
        symbol = 1,
        line = list(
          color = "white",
          width = 1
        )
      )
    ) %>% 
      layout(
        title = "\n Weekday Distribution",
        xaxis = list(
          anchor = "free",
          position = 0.38,
          tickangle = 90,
          title = "",
          zeroline = FALSE,
          showticklabels = TRUE,
          showgrid = FALSE,
          tickfont = list(
            size = 9
          )
        ),
        yaxis = list(
          title = "",
          zeroline = FALSE,
          showline = FALSE,
          showticklabels = FALSE,
          showgrid = FALSE
        )
      ) %>% 
      config(
        displayModeBar = TRUE
      )
    
  })
  
  # capture zip_code click event
  wday_click <- reactive({
    
    dayclick <- event_data("plotly_click",
                           source = "wday")
    
    cat(file = stderr(), "\n...inside wday_click: ", dayclick[["x"]], "...\n")
    
    dayclick
    
  })
  
  #---- observers ----
  
  observe({
    
    category_click()
    
    plotlyProxy("zip_code_counts") %>%
      plotlyProxyInvoke(method = "react",
                        "y",
                        zip_data()$n) %>% 
      plotlyProxyInvoke(method = "relayout",
                        list(
                          modebar = list(
                            orientation = "h"
                          )
                        ))
    
  })
  
  observe({
    
    category_click()
    
    plotlyProxy("event_timeline") %>%
      plotlyProxyInvoke(
        method = "react",
        "y",
        time_data()[[2]]
      ) 
    
  })
  
  
  observe({
    
    zip_code_click()
    
    plotlyProxy("wday_counts") %>%
      plotlyProxyInvoke(
        method = "react",
        "color",
        wday_data()$n
      )
    
  })
  
  
  map_df <- eventReactive(wday_click(), {
    
    if(input$variable_choice == "nibrs_crime_category") {
      dat <- df_sf %>%
        filter(nibrs_crime_category == category_click()[["x"]]) %>%
        filter(zip_code == zip_code_click()[["x"]]) %>%
        filter(week_day == wday_click()[["x"]])
    } else if(input$variable_choice == "nibrs_crime") {
      dat <- df_sf %>%
        filter(nibrs_crime == category_click()[["x"]]) %>%
        filter(zip_code == zip_code_click()[["x"]]) %>%
        filter(week_day == wday_click()[["x"]])
    }
    cat(file = stderr(), "\n... nrow of map_df(): ", nrow(dat), "\n")
    
    cat(file = stderr(), "\n... : ", nrow(dat), "\n")
    
    dat
  })
  
  #---- plotly weekday map ----
  output$weekday_map <- renderPlotly({
    
    # req(wday_click(), cancelOutput = TRUE)
    
    plot_mapbox() %>% 
      add_sf(
        data = map_df(),
        mode = "markers",
        color = I("red")
      ) %>% 
      layout(
        title = paste0(wday_click()[["x"]], " Distribution"),
        mapbox = list(
          zoom = 5,
          style = "light",
          center = list(
            lat = 32.7767,
            lon = -96.7970
          )
        ),
        legend = list(
          itemsizing = "constant"
        )
      ) %>% 
      config(
        displayModeBar = TRUE
      )
    
  })
  
  # The user clicks a bar to select a zipcode, then selects a weekday, 
  # which generates the points to be plotted
  
  # we want the click on the weekday boxes to trigger the plotlyProxy 
  # to add our points for the selected weekdday, without re-rendering the map.
  
  observeEvent(wday_click(), {
    
    cat(file = stderr(), "\n... starting plotlyProxy \n")
    
    plotlyProxy("weekday_map") %>%
      # plotlyProxyInvoke(
      #   method = "deleteTraces",
      #   list(as.integer(0))
      # ) %>%
      plotlyProxyInvoke(
        method = "react",
        list(
          data = map_df()
        )
      )
    
  })
  
  
  
}


shinyApp(ui, server)

Hi,

Welcome to the RStudio community!

Along with sharing your code, you should also provide us with a minimal dataset that can recreate the issue if you want the highest chance of someone being able to solve your issue. Also, try and slim down the code to the minimum needed to recreate the issue. You can find ways to do this here:

Good luck!
PJ

Unfortunately we have a fairly long and specific example in which every component is necessary to achieve the desired result.