Keep map zoom (inside same city) while changing attributes in shiny|mapdeck - r

I'm trying to create a shinyapp using mapdeck that maps a variable based on some attributes. Basically, I select a city and then select an activity and a time threshold to produce the desirable map. Reproducible code below (make sure to use a mapbox API):
library(shiny)
library(dplyr)
library(mapdeck)
library(sf)
ui <- shinyUI(fluidPage(
selectInput(inputId = "city",
label = h1("Pick city:"),
choices = c("Belo Horizonte" = "bho",
"Fortaleza" = "for"),
selected = "bho"),
selectInput(inputId = "activity",
label = h1("Pick activity:"),
choices = c("TT", "ST"),
selected = "TT"),
sliderInput(inputId = "time",
label = h1("Pick time threshold:"),
min = 30, max = 120,
step = 30, value = 30,
animate = TRUE),
mapdeckOutput("map")
)
)
# SERVER --------------------------------------------------------------------------------------
# Define a server for the Shiny app
server <- shinyServer(function(input, output) {
data <- readRDS(url("https://github.com/kauebraga/misc/raw/master/data.rds"), "rb")
centroids <- data.frame(sigla_muni = c("for", "bho"),
lon = c(-38.52770, -43.95988),
lat = c( -3.785656, -19.902739))
# register mapbox api key
mapdeck::set_token("YOUR_API")
# reactive for the city
city_filtered <- reactive({
data %>% filter(sigla_muni == input$city)
})
# reactive for the activity
activity_filtered <- reactive({
city_filtered() %>% dplyr::filter(activity == input$activity)
})
# Reactive for time threshold
time_filtered <- reactive({
activity_filtered() %>% dplyr::filter(time_threshold == input$time)
})
# initialize baseMap
output$map <- renderMapdeck({
mapdeck(location = c(-43.95988, -19.902739), zoom = 0)
})
#
observe({
centroids_city <- filter(centroids, sigla_muni == input$city)
mapdeck_update(map_id = "map") %>%
mapdeck_view(location = c(centroids_city$lon, centroids_city$lat), zoom = 10,
duration = 3000,
transition = "fly")
a <- mapdeck_update(map_id = "map") %>%
add_polygon(
data = time_filtered(),
fill_colour = "value",
fill_opacity = 200,
layer_id = "acess",
palette = "inferno",
update_view = FALSE,
focus_layer = FALSE,
)
})
}
)
shinyApp(ui = ui, server = server)
I want to use the cool map transitions provided by mapdeck, so I create a basemap with zero zoom and then use the mapdeck_view function inside my shiny::observer so I can have the nice transition whenever I open the map or select a different city. I set the views based on cities centroids.
The problem is that the view (and the transition) also updates whenever I change the zoom inside the same city and then select different attributes (different activities or a different time threshold). I wish there was a way to keep the map in the same zoom while I change attributes within the same city, having transition only when I change cities.
I tried to play with shiny::isolate inside my observer but didn't succeed (nothing happened in this case):
observe({
isolate({
centroids_city <- filter(centroids, sigla_muni == input$city)
mapdeck_update(map_id = "map") %>%
mapdeck_view(location = c(centroids_city$lon, centroids_city$lat), zoom = 10,
duration = 3000,
transition = "fly")
})
a <- mapdeck_update(map_id = "map") %>%
add_polygon(
data = time_filtered(),
fill_colour = "value",
fill_opacity = 200,
layer_id = "acess_cum",
palette = "inferno",
update_view = FALSE,
focus_layer = FALSE,
)
})
Appreciate any help. Thanks!

I think you need the city input and the time & activity inputs in different observers. This appears to achieve your desired behaviour.
observe({
centroids_city <- filter(centroids, sigla_muni == input$city)
mapdeck_update(map_id = "map") %>%
mapdeck_view(location = c(centroids_city$lon, centroids_city$lat), zoom = 10,
duration = 3000,
transition = "fly")
})
observeEvent({c(input$time, input$activity, input$city)},{
print(" -- changing -- ")
sf <- time_filtered()
print( unique( sf$sigla_muni ) )
print( unique( sf$time_threshold ) )
print( unique( sf$activity ) )
mapdeck_update(map_id = "map") %>%
add_polygon(
data = sf,
fill_colour = "value",
fill_opacity = 200,
layer_id = "acess",
palette = "inferno",
update_view = FALSE,
focus_layer = FALSE,
)
})

Related

Double calls to plot/load functions in shiny app

I have an app with a map, dropdown, calendar and line plot (my real app is much bigger but I have simplified as much as I can). The problem with it is that when I modify any of the uicontrol features, the data loading and plotting routines run twice (as evidenced from the print statements). In the full app the plots display a reasonable amount of data so running them twice leads to poor performance.
The app is structured so that I can select 1 of 2 predefined points on the map and it will change the dropdown and graph. A new location can also be selected with the dropdown menu (which in turn updates the map). There is also a checkbox to lock the timeframe and when this is not selected the timeframe gets reset to the extents of the timeseries for the new location.
I have isolated the problem to the updateDateRangeInput that is called in the server.R file (line 35). I can comment this out and the problem goes away, but then I lose the functionality to reset the calendar to the new timeframe. Does anyone know how I can keep that functionality but stop the data loading and plotting code from running twice?
Example app below:
app.R
library(shiny)
library(rsconnect)
source('ui.R')
source('server.R')
ui <- ui_page()
server <- server_page(input, output, session)
shinyApp(ui=ui, server=server)
ui.R
library(shiny)
library(leaflet)
library(dygraphs)
inc_level <- 5
ui_page <- function(){
fluidPage(
titlePanel("TEST APP"),
sidebarLayout(
sidebarPanel(
leafletOutput('region_map'),
selectInput(inputId = "Site",label = "Pick a site",choices = c("A","B"), selected = "A"),
fluidRow(
column(6,
dateRangeInput(inputId = "timeframe",label="Select time range", start ="2015-07-01", end = "2016-07-01")),
column(4,checkboxInput(inputId = "lock_timeframe",label = "Lock Time Range"))
)
),
mainPanel(
tabsetPanel(
tabPanel("Plot 1", dygraphOutput(outputId = "plot1"))
)
)
)
)
}
server.R
library(shiny)
library(ggplot2)
library(dygraphs)
library(xts)
server_page <- function(input, output, session){
# Create Data -------------------------------------------------------------
Y1 <- c(21000, 23400, 26800)
Time1 <- startdate <- as.Date(c('2007-11-1','2008-3-25','2010-3-14'))
Y2 <- c(11000, 11400, 16800)
Time2 <- startdate <- as.Date(c('2001-11-1','2003-3-25','2005-3-14'))
Lat <-c(-39.095980, -39.605823)
Lon <- c(173.887903, 173.824561)
Site <- c("A","B")
# Extract Data -------------------------------------------------------
df1 <- reactive({
print("load data")
if (input$Site=="A"){
df1 <- data.frame(Time1, Y1)
}
else if (input$Site=="B"){
df1 <- data.frame(Time2, Y2)
}
names(df1) <- c("Time","Y")
if (1){ # IF YOU CHANGE THIS TO A 0 FUNCTIONLITY IS LOST BUT PROBLEM GOES AWAY
lockTest <- input$lock_timeframe
if (lockTest==FALSE){
updateDateRangeInput(session, "timeframe",
start = df1$Time[1],
end =df1$Time[length(df1$Time)])
}
}
df1 <- df1[df1$Time >= format(input$timeframe[1]) & df1$Time <= format(input$timeframe[2]),]
validate(need(nrow(df1)!=0, "No Data In Range"))
return(df1)
}) #%>% bindCache(input$Site) # I woudl like to cache based on location to stop reloading of data from file in the full app
# Line Plot --------------------------------------------------------
output$plot1 <- renderDygraph({
print("Plotting")
data <- df1()
data <- xts(x = data$Y, order.by = data$Time)
dyPlt <- dygraph(data,width = 800, height = 400)
})
# Plot Map -----------------------------------------------------
output$region_map <- renderLeaflet({
y <- Lat
x <- Lon
id <- Site
leaflet() %>%
addProviderTiles(providers$OpenStreetMap, options = providerTileOptions(noWrap = TRUE)) %>%
setView(lng = 174.051515, lat = -39.301619, zoom = 8) %>%
addCircleMarkers(lng = x, lat = y ,color="green", radius = 2, layerId = id, label = id,
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "green","border-color" = "rgba(0,0,0,0.5)"))
)
})
# Map Click Behaviour -----------------------------------------------------
#When map is clicked: update map and change dropdown value
observeEvent(input$region_map_marker_click, {
event <- input$region_map_marker_click
updateSelectInput(session,
inputId = "Site",
label = "Pick a site",
choices = Site,
selected = event$id)
})
# Update map when a new site is selected from the dropdown
observeEvent(input$Site, {
update_markers()
})
# Function to redraw markers and highlight the selected location
update_markers <- function(){
y <- Lat
x <- Lon
id <- Site
sitInd <- id == input$Site
leafletProxy("region_map") %>% clearMarkers() %>% addCircleMarkers(lng = x, lat = y ,color="green", radius = 2, layerId = id, label = id,
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "green","border-color" = "rgba(0,0,0,0.5)")),
options = list(zIndex = 200)) %>%
addCircleMarkers(lng = x[sitInd], lat = y[sitInd] ,color="blue", radius = 4, layerId = id[sitInd], label = id[sitInd],
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "blue","border-color" = "rgba(0,0,0,0.5)")),
options = list(zIndex = 300) )
}
}

How to change circle marker color in leaflet when I select a row in the table in Shiny?

So I want to change the CircleMarker colour in Leaflet map when I select a row in the table. I didn't get any errors but nothing happens. I don't know how to create and apply the reactive function properly in my Shiny app.
I tried to create a reactive function when a row is selected in the table and apply it to a separate leaflet proxy and leaflet map.
library(shiny)
library(DT)
library(dplyr)
library(leaflet)
library(leaflet.extras)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Quakes Test"),
# Sidebar with numericInput for quakes depth range
sidebarLayout(
sidebarPanel(
numericInput(inputId = "min_depth", label = "Mininum depth", value = min(quakes$depth), min = min(quakes$depth), max = max(quakes$depth)),
numericInput(inputId = "max_depth", label = "Maximum depth", value = max(quakes$depth), min = min(quakes$depth), max = max(quakes$depth))
),
# Show a map
mainPanel(
fluidRow(
leafletOutput("mymap_occ", width = "98%", height = 500))
)
),
fluidRow(DT::dataTableOutput(outputId = "prop_table"))
)
server <- function(input, output) {
#filter terrains
depth_final <- reactive({
obj <- quakes
if (input$min_depth != "All") {
obj <- quakes %>%
filter(depth >= as.numeric(input$min_depth)) %>%
filter(depth <= as.numeric(input$max_depth))
}
})
#row selected in table
table2_bat <- reactive({
data <- depth_final()
data <- data[input$prop_table, ]
})
output$prop_table <- renderDT({
datatable(depth_final(), extensions = 'Buttons', rownames = FALSE, escape = FALSE, selection = 'single')
})
#row selected map
observe({
leafletProxy("mymap_occ", data = table2_bat()) %>%
clearGroup(group = "FOO") %>%
addCircleMarkers(lng = ~long, lat = ~lat,
color = "white", fillColor = "yellow", opacity = 1, fillOpacity = 1,
radius = 5, weight = 20, group = "FOO")
})
#map
observe({
leafletProxy("mymap_occ", data = depth_final()) %>%
clearGroup(group = "FOO_2") %>%
addCircleMarkers(lng = ~long, lat = ~lat,
color = "white", fillColor = "red", opacity = 1, fillOpacity = 0.75,
radius = 5, weight = 2, group = "FOO_2")
})
output$mymap_occ <- renderLeaflet({
leaflet(table2_bat()) %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat)) %>%
addProviderTiles(providers$Esri.WorldImagery, group = "Vue satellite") %>%
addProviderTiles(providers$Stamen.TonerLabels, group = "Vue satellite")
})
output$mymap_occ <- renderLeaflet({
leaflet(depth_final()) %>%
fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat)) %>%
addProviderTiles(providers$Esri.WorldImagery, group = "Vue satellite") %>%
addProviderTiles(providers$Stamen.TonerLabels, group = "Vue satellite")
})
}
shinyApp(ui = ui, server = server)
First. You have to use eventReactive instead of reactive to trigger an action based on an event, i.e. when the user selects a row. Second. To get the index of the selected row you have to use input$prop_table_rows_selected (see here) instead of input$prop_table. input$prop_table does not exist, i.e. it returns NULL. Hence, to make your app work try this:
#row selected in table
table2_bat <- eventReactive(input$prop_table_rows_selected, {
data <- depth_final()
data <- data[input$prop_table_rows_selected, ]
})

R googleway - turn off legend in Shiny

How can the legend be 'turned off' dynamically with googleway? Here is the code adapted from the googleway vignette (this example is updated from a previous version based on a slider and is hopefully more relevant to this question)
library(googleway)
library(tidyverse)
library(shiny)
ui <- fluidPage(
checkboxInput("check", "Fill polygons"),
google_mapOutput(outputId = "map")
)
server <- function(input, output){
output$map <- renderGoogle_map({
google_map(key = "") %>%
add_polygons(data = melbourne, id = "polygonId", pathId = "pathId",
polyline = "polyline", fill_opacity = 0, fill_colour = "SA2_NAME",
legend = FALSE, update_map_view = FALSE)
})
# observe check box
observe({
show_legend <- input$check
my_fill_opacity <- as.integer(input$check)
if(show_legend){
google_map_update(map_id = "map") %>%
update_polygons(data = melbourne, id = "polygonId",
fill_opacity = 1, fill_colour = "SA2_NAME",
legend = TRUE)
} else {
google_map_update(map_id = "map") %>%
update_polygons(data = melbourne, id = "polygonId",
fill_opacity = 0, fill_colour = "SA2_NAME",
legend = FALSE)
}
})
}
shinyApp(ui, server)
The left picture is with the legend turned off at the start. The middle picture is after clicking "Fill polygons". The right picture is after unchecking "Fill polygons" - you can see the legend does not disappear.

Filtering leaflet map data in shiny

I'm having trouble setting up this shiny with a leaflet map. My original post had two questions and it was suggested I should start a new post to address my second issue: how do I get the map to show my updated data after I have filtered by speed; my table gets updated whether I change "speed" or the map bounds, but the leaflet map does not update points based on the speed filter input.
REPRODUCIBLE CODE
library(shiny)
library(magrittr)
library(leaflet)
library(DT)
ships <-
read.csv(
"https://raw.githubusercontent.com/Appsilon/crossfilter-demo/master/app/ships.csv"
)
ui <- shinyUI(fluidPage(
titlePanel("Filter"),
sidebarLayout(
sidebarPanel(width = 3,
numericInput(
"speed_f", label = h5("Ship's Speed"), value = 100
)),
mainPanel(tabsetPanel(
type = "tabs",
tabPanel(
"Leaflet",
leafletOutput("leafletmap", width = "350px"),
dataTableOutput("tbl")
)
))
)
))
server <- function(input, output) {
in_bounding_box <- function(data, lat, long, bounds, speed) {
data %>%
dplyr::filter(
lat > bounds$south &
lat < bounds$north &
long < bounds$east & long > bounds$west &
speed > input$speed_f
)
}
output$leafletmap <- renderLeaflet({
leaflet() %>%
addProviderTiles("Esri.WorldImagery", group = "ESRI World Imagery") %>%
addCircleMarkers(
data = ships,
~ long ,
~ lat,
popup = ~ speed,
radius = 5 ,
stroke = FALSE,
fillOpacity = 0.8,
popupOptions = popupOptions(closeButton = FALSE)
)
})
data_map <- reactive({
if (is.null(input$leafletmap_bounds)) {
ships
} else {
bounds <- input$leafletmap_bounds
in_bounding_box(ships, lat, long, bounds, speed)
}
})
output$tbl <- DT::renderDataTable({
DT::datatable(
data_map(),
extensions = "Scroller",
style = "bootstrap",
class = "compact",
width = "100%",
options = list(
deferRender = TRUE,
scrollY = 300,
scroller = TRUE,
dom = 'tp'
)
)
})
}
shinyApp(ui = ui, server = server)
UPDATE
Making the following change data = data_map() seems to work, with an exception:
output$leafletmap <- renderLeaflet({
leaflet() %>%
addProviderTiles("Esri.WorldImagery", group = "ESRI World Imagery") %>%
addCircleMarkers(
data = data_map(), #### THIS LINE HAS CHANGED
~ long ,
~ lat,
popup = ~ speed,
radius = 5 ,
stroke = FALSE,
fillOpacity = 0.8,
popupOptions = popupOptions(closeButton = FALSE)
)
})
However, the leaflet map does not let me zoom out of the area defined by the filtered points. Is there a way around this?
If you define a reactive just for the map data and use that within renderLeaflet it should allow you to then move out of the are defined. You don't need to change any of your other functions or reactives, just add the new reactive and make a couple of changes to renderLeaflet as below
map_data_react <- reactive({
ships %>% dplyr::filter(speed > input$speed_f)
})
output$leafletmap <- renderLeaflet({
ships_data <- map_data_react() # Add this
ships_data %>% leaflet() %>%
addProviderTiles("Esri.WorldImagery", group = "ESRI World Imagery") %>%
addCircleMarkers(
~ long , # Removed `data = data_map()`
~ lat,
popup = ~ speed,
radius = 5 ,
stroke = FALSE,
fillOpacity = 0.8,
popupOptions = popupOptions(closeButton = FALSE)
)
})

Leaflet choropleth maps in shiny - unable to use addPolygons function properly

I am new to writing shiny apps and new to using the leaflet package. I am trying to create a shiny app which will get user inputs and plot a choropleth map based on the aggregated values of the selected user variable.
My sample dataset has the following variables: statename latitude longitude countyname medianage asianpopulation otherpopulation
My app would ask the user to select from either username or countyname. Based on this selection, internally I group my dataset using statename or countyname.
Then the user selects either one or many from the variables: medianage asianpopulation otherpopulation.
Based on this, I want to plot the choropleth map on the sum of the values of these variables and show a table below with these values.
I am not able to use the addPolygons method to plot the map. Do I need to use a shape file for this? Where am I going wrong in this code?
library(dplyr)
library(shiny)
library(readr)
library(leaflet)
library(lazyeval)
library(rgdal)
setwd("E:/Data")
ui <- fluidPage(
titlePanel("Filters"),
sidebarLayout(
sidebarPanel(
radioButtons("level", "Select the Level", choices = c("State", "County"),selected = "State" ,inline = TRUE),
selectInput("variable", "Variable Name", choices = NULL, multiple = FALSE, selectize = TRUE, selected = "medianage")
),
mainPanel(
leafletOutput("map"),
dataTableOutput("heatmapdata")
)
)
)
server <- function(input, output, session) {
read_csv(file="Sample.csv") %>%
select(statename, latitude, longitude, countyname, medianage, asianpopulation, otherpopulation) -> heatmapData -> hd
variable = c()
group = c()
heatmapData <- data.frame(heatmapData)
hd <- heatmapData
heatmapdata_1 <- select(heatmapData, -c(latitude, longitude))
heatmapdata_2 <- select(heatmapdata_1, -c(statename, countyname))
updateSelectInput(session, "variable", choices = sort(unique(colnames(heatmapData))), selected = "medianage")
heatmapdata_2 <- heatmapdata_1
datasetLevel.group <- function(df, grp.var) {
df %>% group_by_(grp.var) %>%
summarise_each(funs(sum)) -> df
df
}
datasetLevel <- reactive({
heatmapdata_2 <- heatmapdata_1
inputvariable <- c("medianage")
if (input$level == "State") {
inputlevel = c("statename")
heatmapdata_2 <- select(heatmapdata_2, -c(countyname))
}
if (input$level == "County") {
inputlevel = c("countyname")
heatmapdata_2 <- select(heatmapdata_2, -c(statename))
}
sm <- datasetLevel.group(heatmapdata_2, inputlevel)
group <- inputlevel
variable <- inputvariable
l_hd <- list(sm, inputlevel, input$variable)
l_hd
})
output$map <- renderLeaflet(
{
leaflet() %>% addTiles(options=tileOptions(minZoom = 3, maxZoom = 10)) %>%
setView(lng = -98.35, lat = 39.5, zoom = 4) %>%
setMaxBounds( -180, 5, -52, 73)
}
)
output$heatmapdata <- renderDataTable(
select_(datasetLevel()[[1]], datasetLevel()[[2]], datasetLevel()[[3]]),
options = list(pageLength=5,
scrollX=TRUE,
lengthMenu = c(5, 10, 25, 100),
searching=FALSE)
)
observe({
pal <- colorQuantile("YlOrRd", NULL, n = 20)
leafletProxy("map", data = datasetLevel()[[1]]) %>%
clearMarkers() %>%
clearMarkerClusters() #%>%
# addPolygons(data = datasetLevel()[[1]],
# fillColor = ~pal(variable),
# fillOpacity = 0.8,
# color = "#BDBDC3",
# weight = 1)
})
}
shinyApp(ui = ui, server = server)
I have commented out the addPolygons code as I get an error with that. I have been breaking my head to get the maps color coded based on the aggregated values of the selected variable.
The data file can be found at: https://drive.google.com/file/d/0B4PQcgewfQ3-MF9lNjU4clpUcUk/view?usp=sharing
Any help on this will be really helpful. Thanks.

Resources