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)