I have created a shiny app where the user can select from a date range to show crimes that occurred in Chicago by Longitude and Latitude.
The problem I am having is to make the dateRangeInput reactive within the leafletOutput. I have looked up a LOT of different option and found that these work the best but the problems I am having are:
Map generates with markers but is not reactive (when commenting out the clearMarkers())
Map generates without markers so I cant even tell if its reactive or not (when using clearMarkers())
I have tried both approaches of using observe() and observeEvent().
Please help... what am I missing.
Data can be found at https://data.cityofchicago.org/Public-Safety/Crimes-2001-to-Present/ijzp-q8t2
**** Interested in date range 01/01/20 to 09/30/20.... the file referenced in a data
crimes.df <- read.csv("Crimes_2020.csv", stringsAsFactors = TRUE)
#Seprating Date and Time into multiple columns
dup_crimes.df$datetime <- as.POSIXct(dup_crimes.df$Date, format = "%m/%d/%Y %H:%M")
dup2_crimes.df <- transform(dup_crimes.df, time = format(dup_crimes.df$datetime, "%T"),
date = format(dup_crimes.df$datetime, "%m/%d/%Y"))
class(dup2_crimes.df$date)
dup2_crimes.df$Month <- as.numeric(format(as.Date(dup2_crimes.df$date), format = "%y"))
dup2_crimes.df$Month.Name <- month.abb[dup2_crimes.df$Month]
#Filter out locations NOT related to Chicago
dup3_crimes.df <- filter(dup2_crimes.df, dup2_crimes.df$Latitude >= 41)
unique(dup3_crimes.df$Primary.Type)
ui <- fluidPage(
titlePanel("2020 Crimes in Chicago"),
tabsetPanel(type = "tabs",
tabPanel("Map of Location of crimes by date",
dateRangeInput(inputId = "date",
label = "Date",
start = '2020-02-25',
end = '2020-07-04',
min = '2020-01-01',
max = '2020-09-30'
),
leafletOutput("Map"))
)
)
server <- function(input,output){
datefileter1 <- reactive({
dup3_crimes.df[
dup3_crimes.df$date >= input$date[1] &
dup3_crimes.df$date <= input$date[2],]
})
#https://www.youtube.com/watch?v=G5BDubIyQZY
#Static Map
output$Map <- renderLeaflet({
leaflet(data = dup3_crimes.df) %>%
addTiles() %>%
addCircleMarkers(lng = ~Longitude, lat = ~Latitude)
})
#Put Dynamic Content
# observe(leafletProxy("Map", data = datefileter1()) %>%
# clearMarkers() %>%
# addCircleMarkers(lng = ~Longitude, lat = ~Latitude)
# )
observeEvent(input$date,
leafletProxy("Map", data = datefileter1()) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~Longitude, lat = ~Latitude)
)
# observe({
#
# leafletProxy("Map", data = datefilter()) %>%
# clearShapes() %>%
# addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
# fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
# )
# })
#
}
#Run Shiny App
shinyApp(ui = ui , server =server)
---->> With clearMarkers()
---->> Without clearMarkers() - shows all the locations and NOT reactive (intentionally selected 7/4/20)
Try this, it should work. You can include the reactive df in a simple leaflet call:
ui <- fluidPage(
titlePanel("2020 Crimes in Chicago"),
tabsetPanel(type = "tabs",
tabPanel("Map of Location of crimes by date",
dateRangeInput(inputId = "date",
label = "Date",
start = '2020-02-25',
end = '2020-07-04',
min = '2020-01-01',
max = '2020-09-30'
),
leafletOutput("Map"),
tableOutput("tab"))
)
)
server <- function(input,output){
datefileter1 <- reactive({
dup3_crimes.df[
dup3_crimes.df$date >= input$date[1] &
dup3_crimes.df$date <= input$date[2],]
})
output$tab <- renderTable(datefileter1())
output$Map <- renderLeaflet({
leaflet(data = datefileter1()) %>%
addTiles() %>%
addCircleMarkers(lng = ~Longitude, lat = ~Latitude)
})
}
#Run Shiny App
shinyApp(ui = ui , server =server)
Related
I have a map which has a series of lines with associated values, which is rendered based on a reactive dataframe, filtered by a sliderInput.
When a line is clicked, the map view is updated with new lng, lat and zoom values, based on that line. What I would like is that the view does not reset when the slider is updated. I understand that it's resetting to the values in the initial setView() because the map is rerendering when the slider is changed, but I'm unsure how I can prevent this behaviour.
In short, when a user clicks on the line, I want it to stay at that lng/lat/zoom even as the slider changes. How can I accomplish this?
Below is a simplified reproducible example, with only one line:
library(shiny)
library(leaflet)
library(tidyverse)
library(RColorBrewer)
# Example data frame
line1 <- data.frame(
lng = rep(c(13.35011, 13.21514), 4),
lat = rep(c(52.51449, 52.48042), 4),
id = rep("10351A", 8),
period = rep(c(1, 2, 3, 4), each = 2),
value = rep(c(1200, 2300, 3140, 1111), each = 2)
)
ui <- fluidPage(
sidebarPanel(
sliderInput(
inputId = "period_picker",
label = "Period",
min = 1,
max = 4,
value = 1
),
uiOutput("clicked_info")
),
mainPanel(
leafletOutput("map")
)
)
server <- function(input, output) {
# Reactive dataframe based on period_picker
dat <- reactive({
filtered <- line1 %>%
filter(period == input$period_picker)
return(filtered)
})
# Render map
output$map <- renderLeaflet({
# Create color palette based on reactive frame
pal <- colorNumeric(palette = "Purples", domain = c(0, max(line1$value)))
# Render leaflet map
leaflet(data = dat()) %>%
addTiles() %>%
setView(lng = 13.38049, lat = 52.51873, zoom = 13) %>%
addPolylines(
lng = ~lng,
lat = ~lat,
layerId = ~id,
color = ~pal(dat()$value),
opacity = 1
)
})
# Zoom in and readjust view if shape matching id is clicked - this is the
# lng/lat/zoom value I want to keep when the sliderInput is changed
observeEvent(input$map_shape_click, {
x <- input$map_shape_click
if(x$id == "10351A") {
leafletProxy(
mapId = "map",
) %>%
flyTo(
lng = 13.282625,
lat = 52.497455,
zoom = 12
)
}
# Render dataset in the UI
output$clicked_info <- renderUI({
div(
tags$span("Line ID:", dat()$id[1]),
br(),
tags$span("Period:", dat()$period[1]),
br(),
tags$span("Value:", dat()$value[1])
)
})
})
}
shinyApp(ui = ui, server = server)
You need to put the addPolylines not in the map rendering, but in another observeEvent with leafletProxy. Replace your output$map block of code by the following lines :
# Render map
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(lng = 13.38049, lat = 52.51873, zoom = 13)
})
observeEvent(dat(), {
req(dat())
pal <- colorNumeric(palette = "Purples", domain = c(0, max(line1$value)))
leafletProxy("map") %>%
addPolylines(
data = dat(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
color = ~pal(dat()$value),
opacity = 1
)
})
I have created a Timeseries visualization map application that updates data points on Leaflet with the progression of the time series animation.
Now I am trying to add another functionality where when the user selects a particular week from the time series, the map will just show the points for that date only. One way I am thinking to do this would be add the ability to define a range with two toggles, so when the user drags the start and end toggle to the same week, the maps will just show the data points for that week. Or maybe there is a better way of doing it.
How can a leaftet be created such that not only does it show the whole data points for the entire time series like an animation (the current code does this), but also have the ability to show only data points for selected date on the slider?
Code:
# This is a Shiny time series map web application
library(shiny)
library(tidyverse)
library(tidyr)
library(leaflet)
library(xts)
xts_to_tibble <- function(xts_obj) {
data.frame(index(xts_obj), coredata(xts_obj)) %>%
set_names(c("date", names(xts_obj))) %>%
as_tibble()
}
# Create sample data
Date <- c(
"2014-04-08", "2014-06-04", "2014-04-30",
"2014-05-30", "2014-05-01"
)
lat <- as.numeric(c(
"45.53814", "45.51076", "45.43560", "45.54332",
"45.52234"
))
lon <- as.numeric(c(
"-73.63672", "-73.61029", "-73.60100",
"-73.56000 ", "-73.59022"
))
id <- as.numeric(c("1", "2", "3", "4", "5"))
# Create a df from the above columns
df <- data.frame(id, lat, lon, Date)
df$Year <- lubridate::year(df$Date)
df$Month <- lubridate::month(df$Date, label = TRUE, abbr = FALSE)
df$Week <- lubridate::week(df$Date)
df$Date <- as.Date(df$Date)
ui <- fluidPage(
# Title
titlePanel("Time Series Visiualization Map"),
sidebarLayout(
# Define the sidebar
sidebarPanel(
radioButtons(
inputId = "Frequency",
label = " Select Timer Series Frequency",
choices = c(
"weeks",
"months",
"years"
),
selected = "weeks",
inline = T
),
uiOutput("Time_Series_UI")
),
mainPanel(
leafletOutput("Time_Series_Map")
),
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# Render slider input depending on data frequency
observe({
# Create an xts object
df_xts <- xts(df, order.by = as.Date(df$Date))
# All_Dates = unique(df$Start_Date)
Filtered_Dates <- df_xts[xts::endpoints(
df_xts,
on = input$Frequency
)] %>% xts_to_tibble()
output$Time_Series_UI <- renderUI({
sliderInput("Date", "Date:",
min = pull(slice_min(Filtered_Dates, date), date),
max = pull(slice_max(Filtered_Dates, date), date),
value = pull(slice_min(Filtered_Dates, date), date),
step = 1,
timeFormat = "%YYYY-%MM-%DD",
animate = T
)
})
})
# Filter data for the date selected
Filtered_Data <- reactive({
req(input$Date)
filter(df, Date == input$Date)
})
# Create the leaflet map
output$Time_Series_Map <- renderLeaflet({
leaflet(df) %>%
addTiles() %>%
setView(lat = 0, lng = 0, zoom = 2)
})
# Create data markers for selected date
observe({
# print(input$Date)
leafletProxy("Time_Series_Map", data = Filtered_Data()) %>%
addCircleMarkers(
lng = ~lon, lat = ~lat,
popup = ~id
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I think the answer is not too difficult in this case currently your last observer looks like this:
observe({
# print(input$Date)
leafletProxy("Time_Series_Map", data = Filtered_Data()) %>%
addCircleMarkers(
lng = ~lon, lat = ~lat,
popup = ~id
)
})
This observer every time adds markers in Filtered_Data() however markers are never removed. By using a group and clearing that group you old markers are removed each time:
observe({
leafletProxy("Time_Series_Map", data = Filtered_Data()) %>%
clearGroup("points") %>%
addCircleMarkers(group='points',
lng = ~lon, lat = ~lat,
popup = ~id
)
})
I'm trying to highlight points in my map based on the user input slider. If the point falls within a certain date range, change the color, and if it doesn't, default it to black.
#server
shinyServer(function(input, output,session) {
output$myMap <- renderLeaflet({
leaflet() %>%
addTiles()%>%
addCircles(data=df,
# ~Longitude,
# ~Latitude,
group = "myMarkers",
label = ~htmlEscape(date))
})
observeEvent(input$selectVariable, {
mydat$col_format<- ifelse(mydat$Date >= input$falltime[1] & mydat$Date <= input$falltime [2],'blue',
ifelse(mydat$Date >= input$springtime[1] & mydat$Date <= input$springtime [2], 'black',
ifelse (mydat$Date, 'yellow')) )
leafletProxy("myMap") %>%
clearGroup("myMarkers") %>%
addCircles(data = df[df$AnimlID == input$selectVariable, ],
#~ mydat$Longitd ,
#~ mydat$Latitud,
group = "myMarkers",
col = mydat$col_format,
label = ~htmlEscape(date)
)
})
})
#ui shinyUI(dashboardPage(#skin = "black",
dashboardHeader(title = "Mapping Test", titleWidth = 350
),
dashboardSidebar(width = 350,
selectInput("selectVariable", label = h4("Select an D:"),
choices = unique(df$id)),
sliderInput("falltime","NSD Fall Slider:",
min = min, max = max, value = c(min, max)),
verbatimTextOutput("dateText"),
sliderInput("springtime","NSD Spring Slider:",
min = min, max = max, value = c(min, max)),
actionButton("submit", ("Submit"))),
dashboardBody(fluidPage(
box( plotOutput("plotlraj")),
box( leafletOutput("myMap")),
box(DT::dataTableOutput("Table"),
)
),
)
))
With the above code I don't get any errors but the map is really slow to load and the points are always blue no matter what the date range the slider input is set to.
I've also tried adding this reactive block but again, all the points are blue even when I change the slider date range
colorpal<- reactive({
if(mydat$Date >= input$falltime[1] & mydat$Date <= input$falltime [2]){
mydat[,'seasonColor']<-'#626262'
}
if(mydat$Date >= input$springtime[1] & mydat$Date <= input$springtime [2]){
mydat[,'seasonColor']<-'#BAF218
'
}
Using quakes so others can replicate.
In the filtered_df reactive function, manipulate your data.frame as you prefer. I prefer using dplyr, but am showing base R.
req() are used to ensure those inputs have values.
There is no need to have addCircles() in the leaflet instantiation. The observe reactive will take care of displaying the circles once filtered_df() is ready and every time it is changed after that.
For brevity, showing just the server code.
output$myMap <- renderLeaflet({
leaflet() %>%
addTiles()
})
filtered_df <- reactive({
req(input$depth_slider,
input$mag_slider)
filtered_df <- quakes[quakes$depth <= input$depth_slider,]
filtered_df[filtered_df$mag <= input$mag_slider, 'Strength'] <- 'Weak'
filtered_df[filtered_df$mag > input$mag_slider, 'Strength'] <- 'Strong'
return(filtered_df)
})
observe({
filtered_df <- filtered_df()
pal <- colorFactor(c('Green', 'Red'), domain = filtered_df$Strength)
leafletProxy('myMap') %>%
clearGroup('myMarkers') %>%
clearControls() %>%
addCircles(
data = filtered_df,
lng = ~long,
lat = ~lat,
group = 'myMarkers',
color = ~pal(Strength)
) %>%
addLegend(
pal = pal,
values = filtered_df$Strength
)
})
I cannot get the map to react with the sliders. THe data was from https://www.kaggle.com/nasa/meteorite-landings/data#
when i move the sliders the map "refreshes" like it resets itself as if something were going to change but all of the data points show up on the graph. any help would be appreciated.
library(shiny)
library(dplyr)
library(leaflet)
library(ggplot2)
Meteor <- read.csv()
#to take all NA values out
ReMeteor <- na.omit(Meteor) #from now on using ReMeteor instead of Meteor
ui <- shinyUI(fluidPage(
titlePanel("Meteorite Landings"),
# Sidebar with a sliders and checkbox
sidebarLayout( position = "right",
sidebarPanel(
#1st slider year range
sliderInput("years","The year the meteorite fell, or the year it was found ",
min = min(ReMeteor$year),
max = max(ReMeteor$year),
step = 1,value = c(1399,2013),
animate = TRUE),
#2nd slider mass range
sliderInput("masss","The mass of the meteorite, in grams",
min = min(ReMeteor$mass),
max = max(ReMeteor$mass),
step = 100,value = c(.010,60000000),
animate = TRUE),
#checkbox
selectInput("fall",
"Was meteorite seen falling or found?",
choices = sort(unique(ReMeteor$fall))),
),
mainPanel( leafletOutput("my_leaf",height = 650, width = 605),textOutput("text1"),textOutput("text2")
))))
server <- shinyServer(function(input, output, session) {
#i think this block of four was letting it refresh, although no changes
filtered <- reactive({
ReMeteor[ReMeteor$year >= input$years[1] & ReMeteor$year <= input$years[2],]
ReMeteor[ReMeteor$mass >= input$masss[1] & ReMeteor$mass <= input$masss[2],]
})
#need last checkbox
# filter(ReMeteor >= input$year[1] &
# ReMeteor <= input$year[2]) %>%
# filter(ReMeteor >= input$mass[1] &
# ReMeteor <= input$mass[2])%>%
# filter(ReMeteor = sort(unique(ReMeteor$fall)))
# fitBounds()#here it is !!! https://rstudio.github.io/leaflet/shiny.html search : fitbounds --- this too https://rstudio.github.io/leaflet/markers.html
output$my_leaf <- renderLeaflet({
leaflet(data = filtered()) %>%
addMiniMap(zoomLevelOffset = -4) %>%
addProviderTiles("Esri.NatGeoWorldMap")
})
#fitBounds(ReMeteor, ReMeteor$reclong,ReMeteor$reclat,ReMeteor$reclong,ReMeteor$reclat)
observe({
# year_ <-input$year
# mass_ <-input$mass
# fall_ <-input$fall
#
leafletProxy("my_leaf", data = filtered()) %>%
clearShapes() %>%
clearMarkers() %>%
clearPopups() %>%
addMarkers(lat = ReMeteor$reclat,
lng = ReMeteor$reclong,
clusterOptions = markerClusterOptions(),
popup = as.character(ReMeteor$name,ReMeteor$recclass))
})
output$text1 <- renderText({
paste("You have chosen a range from the year", input$years[1], "to", input$years[2])
})
output$text2 <- renderText({
paste("You have chosen a range of mass from", input$masss[1], "to", input$masss[2], "grams")
})
})
shinyApp(ui, server)
The issue here is that although you correctly used the reactive value filtered() in your leafletProxy call, you use the non-reactive version of ReMeteor in your addMarkers call.
observe({
leafletProxy("my_leaf", data = filtered()) %>%
clearShapes() %>%
clearMarkers() %>%
clearPopups() %>%
addMarkers(lat = filtered()$reclat,
lng = filtered()$reclong,
clusterOptions = markerClusterOptions(),
popup = as.character(filtered()$name,filtered()$recclass))
})
I'm trying to build a shiny app that will only plot points on rows that have a value within the range of a slider bar. If I increase the range of the slider bar, points will be added, but points are never removed when I decrease the range of the slider bar. Below is a reproducible example of my problem.If you increase the slider bar to full range, 3 points will show up on the map. If you then decrease the range enough it will zoom in on one point, but if you zoom out you will see that there are still 3 points being plotted on a map. I thought the clearShapes or clearMarkers function in leaflet would remove these points, but it's not working. Any suggestions?
library(shiny)
library(leaflet)
library(tidyverse)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
radioButtons("choice","Group:",choices = c(1,2), selected = 1),
uiOutput("value"),
verbatimTextOutput("Click_text")
),
mainPanel(
leafletOutput("Map")
)
)
)
server <- function(input, output) {
df <- data.frame(lat = c(42.34,43.65,45.26,48.63,47.65,47.52),
lng = c(-96.43,-97.45,-98.56,-92.35,-94.56,-95.62),
id = c(32,45,65,76,34,12),
grp = c(1,1,1,2,2,2),
val = c(1.75,2.12,3.2,3.32,4.76,4.85))
subsetData1 <- reactive({
df %>% filter(grp == input$choice)
})
output$value <- renderUI({
sliderInput("value",label = h3("value"),
min = min(subsetData1()$val,na.rm = TRUE),
max = max(subsetData1()$val,na.rm=TRUE),
value = c(quantile(subsetData1()$val,.25,na.rm = TRUE),quantile(subsetData1()$val,.75,na.rm=TRUE)))
})
subsetData <- reactive({
df2 <- subsetData1() %>% data.frame()
df2 %>% filter(val >= min(as.numeric(input$value)) & val <= max(as.numeric(input$value)))
})
output$Map <- renderLeaflet({
leaflet(height = 1000) %>%
addTiles() %>%
fitBounds(min(df$lng),min(df$lat),max(df$lng),max(df$lat))
})
observe({
leafletProxy("Map") %>%
clearMarkers() %>%
clearShapes() %>%
addCircleMarkers(data = subsetData(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
radius = 8,
weight = 10) %>%
fitBounds(.,min(subsetData()$lng),min(subsetData()$lat),
max(subsetData()$lng),max(subsetData()$lat))
})
observe({
click<-input$Map_marker_click
if(is.null(click))
return()
text<-paste("Latitude ", click$lat, "Longtitude ", click$lng)
text2<-paste("You've selected point ", click$id)
output$Click_text<-renderText({
text2
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can change your observe function where you clear markers to an observeEvent function.
observeEvent(input$value,{
leafletProxy("Map") %>%
clearMarkers() %>%
clearShapes() %>%
addCircleMarkers(data = subsetData(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
radius = 8,
weight = 10) %>%
fitBounds(.,min(subsetData()$lng),min(subsetData()$lat),
max(subsetData()$lng),max(subsetData()$lat))
})
You also have both the uiOutput and sliderInput id's as the same (value). You should make sure every element has a unique id. Rename one of them to something unique.