Update Leaflet Marker based on timer in Shinydashboard - r

I have data frame df which has two variables lat and lon, Now I need to create a Shinydashboard which updates the map by taking next row value in from the data frame after every 10 seconds.
df
df <- data.frame("Lat" = c(12.8882, 12.890, 12.891), "Lon" = c(77.58195,77.58190,77.581958))
Ui.R
library(shiny)
library(leaflet)
shinyUI( fluidPage(
leafletOutput("map1")
)
)
server.R
library(shiny)
shinyServer(function(input, output, session) {
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles() %>% # Add default OpenStreetMap map tiles
addMarkers(lng=df$lon, lat=df$lat)})
})
Only thing I know is I can use invalidateLater() to call the timer but I do not know how to implement that for the incremental reading of the rows in the data frame.
Expected Result
I need a map where the marker moves to the next position after every 10 Seconds, The coordinates for moving the marker is given through the data frame df.

You can use a reactiveVal() to keep track of the currently displayed marker, and use observe() in combination with invalidateLater() and leafletProxy() to remove the previous marker and add the new one. To do so we can give the layer a layerId everytime we add our marker, which we can then use to remove the marker again when plotting the next marker.
A working example is given below, I added some comments to illustrate what is happening. Hope this helps!
library(shiny)
library(leaflet)
set.seed(1)
df <- cbind(rnorm(40) * 2 + 13, rnorm(40) + 48)
ui <- fluidPage(
leafletOutput("mymap")
)
server <- function(input, output, session) {
# Create the base map
output$mymap <- renderLeaflet({
leaflet() %>%
addProviderTiles(providers$Stamen.TonerLite,
options = providerTileOptions(noWrap = TRUE)
) %>%
setView(lng = mean(rnorm(1000) * 2 + 13), lat = mean(rnorm(1000) + 48), zoom = 7)
})
# Initialize a reactiveVal to keep track of which point is currently selected
point_to_plot <- reactiveVal(1)
observe({
# invalidate every 2 seconds
invalidateLater(2000)
isolate({
# update point_to_plot() to next value. If next value is higher than the amount of rows
# in df, set it to 1.
point_to_plot(ifelse(point_to_plot()+1<=nrow(df),point_to_plot()+1,1))
# Use leafletProxy to remove our previous marker, and add the new one.
leafletProxy('mymap') %>%
removeMarker('my_marker') %>%
addMarkers(layerId = 'my_marker',data = df[point_to_plot(),,drop=F])
})
})
}
shinyApp(ui, server)
EDIT: Working example with your data:
library(shiny)
library(leaflet)
set.seed(1)
df <- data.frame("Lat" = c(12.8882, 12.890, 12.891), "Lon" = c(77.58195,77.58190,77.581958))
ui <- fluidPage(
leafletOutput("mymap")
)
server <- function(input, output, session) {
# Create the base map
output$mymap <- renderLeaflet({
leaflet() %>%
addProviderTiles(providers$Stamen.TonerLite,
options = providerTileOptions(noWrap = TRUE)
) %>%
setView(lat = 12.89, lng = 77.58195, zoom = 14)
})
# Initialize a reactieVal to keep trakc of which point is currently selected
point_to_plot <- reactiveVal(1)
observe({
# invalidate every 2 seconds
invalidateLater(2000)
isolate({
# update point_to_plot() to next value. If next value is higher than the amount of rows
# in df, set it to 1.
point_to_plot(ifelse(point_to_plot()+1<=nrow(df),point_to_plot()+1,1))
# Use leafletProxy to remove our previous marker, and add the new one.
leafletProxy('mymap') %>%
removeMarker('my_marker') %>%
addMarkers(layerId = 'my_marker',data = df[point_to_plot(),,drop=F])
})
})
}
shinyApp(ui, server)

Related

Update datatable when zooming with leaflet (shiny)

I am building a shiny application which contains a leaflet map with markers on it, and a table with information about each marker next to it. As I zoom in the leaflet map, how would I update the table to only show markers still visible on the leaflet map?
# Minimum Viable Example
library(shiny)
library(leaflet)
library(DT)
data(quakes)
# Define UI
ui <- fluidPage(
# leaflet box
column(
leafletOutput("mymap"),
width = 8
),
#data table box
column(
DT::dataTableOutput("table"),
width = 4
)
)
# Define server logic
server <- function(input, output) {
# leaflet map
output$mymap <- renderLeaflet({
# Show first 20 rows from the `quakes` dataset
leaflet(data = quakes[1:20,]) %>% addTiles() %>%
addMarkers(~long, ~lat, popup = ~as.character(mag), label = ~as.character(mag))
})
# data table
output$table = DT::renderDataTable({
quakes
})
}
# Run the application
shinyApp(ui = ui, server = server)
Use the input$mymap_bounds event to filter the data. In your example, add library(dplyr) and change output$table to
output$table = DT::renderDataTable({
if (isTruthy(input$mymap_bounds)) {
bounds = input$mymap_bounds
quakes %>% filter(
between(long, bounds$west, bounds$east),
between(lat, bounds$south, bounds$north)
)
} else
quakes
})
Note that this filters the entire quakes table, not the 20 items you show. Modify to suit. See the Events section of this page for details:
https://rstudio.github.io/leaflet/shiny.html

Zoom into Leaflet Map Based on User Inputs

I am trying to figure out how to zoom into a map based on user inputs. I have started with the map of the US and then trying zooming into a specific location based on zip code and number of miles:
shinyUI(fluidPage(
# Application title
titlePanel("Starbucks Locator"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("zip","Zip Code:", value = "18101"),
sliderInput("radius",
"Radius",
min = 1,
max = 25,
value = 15),
actionButton("go", "Submit")
),
# Show a plot of the generated distribution
mainPanel(
leafletOutput("myMap")
)
)
))
This is the Server Code:
library(shiny)
library(ZipRadius)
library(leaflet)
shinyServer(function(input, output) {
data <- reactive({x <- readRDS("Starbucks.rds")})
output$myMap <- renderLeaflet({
df <- data()
m <- leaflet(data = df) %>%
addTiles() %>%
addMarkers(lng = ~Lon, lat = ~Lat)
})
eventReactive(input$go, {
zip_include <- zipRadius(input$zip, input$radius)
})
leafletProxy("myMap") %>% fitBounds(~min(zip_include$longitude), ~min(zip_include$latitude),
~max(zip_include$longitude), ~max(zip_include$latitude))
})
I am using the ZipRadius package to find the which zip codes are input$distance away from input$zip. Then I want to zoom into the input zip code as the center and the bounds defined by the radius (input$distance). The original leaflet map works, but the leafletProxy is where I am having my issue. Any thoughts on how to do this? I am trying to use fitbounds since it can take into account minimum and maximum latitudes and longitudes. I think the issue may be with the eventReactive, but not sure how to test it. The dataset is available here at github.
There are a few issues with your server code.
You don't need to create your data in a reactive expression. As you only upload it once (I guess you won't change the coords or add another row).
Your renderLeaflet function can be simplified
Instead of using eventReactive use observeEvent. This function is triggered when you press the go button. In the observer you have to add all the actions that should be triggered by the button click. So you also have to insert the leafletProxy function here.
Remove the ~ symbol in the fitBounds function. You are already pointing to the zip_include dataset in fitBounds.
Working server (with provided csv)
shinyServer(function(input, output) {
data <- read.csv("c:/starbucks_us_locations.csv")
names(data) <- c('Lon', 'Lat')
output$myMap <- renderLeaflet({leaflet(data) %>%
addTiles() %>%
addMarkers(lng = ~Lon, lat = ~Lat)
})
observeEvent(input$go, {
zip_include <- zipRadius(input$zip, input$radius)
print(zip_include)
leafletProxy("myMap") %>% fitBounds(min(zip_include$longitude), min(zip_include$latitude),
max(zip_include$longitude), max(zip_include$latitude))
})
})

Shiny - how to highlight an object on a leaflet map when selecting a record in a datatable?

Is there a way to highlight a marker or polyline on a leaflet map when selecting (clicking on) the corresponding record in a datatable?
I looked at these questions/threads:
selecting a marker on leaflet, from a DT row click and vice versa - no answer
https://github.com/r-spatial/mapedit/issues/56 - check timelyportfolio's comment on Jul 23, 2017. As it shows in the gif, I would like to be able to select a row in the datatable so that the corresponding map object (marker/polyline) is highlighted as well (without editing the map).
Here is a working example where the highlighted map object is selected in the datatable below but not vice versa - which is what I am trying to achieve.
##############################################################################
# Libraries
##############################################################################
library(shiny)
library(shinythemes)
library(ggplot2)
library(plotly)
library(leaflet)
library(DT)
##############################################################################
# Data
##############################################################################
qDat <- quakes
qDat$id <- seq.int(nrow(qDat))
str(qDat)
##############################################################################
# UI Side
##############################################################################
ui <- fluidPage(
titlePanel("Visualization of Fiji Earthquake"),
# side panel
sidebarPanel(
h3('Fiji Earthquake Data'),
sliderInput(
inputId = "sld01_Mag",
label="Show earthquakes of magnitude:",
min=min(qDat$mag), max=max(qDat$mag),
value=c(min(qDat$mag),max(qDat$mag)), step=0.1
),
plotlyOutput('hist01')
),
# main panel
mainPanel(
leafletOutput('map01'),
dataTableOutput('table01')
)
)
##############################################################################
# Server Side
##############################################################################
server <- function(input,output){
qSub <- reactive({
subset <- subset(qDat, qDat$mag>=input$sld01_Mag[1] &
qDat$mag<=input$sld01_Mag[2])
})
# histogram
output$hist01 <- renderPlotly({
ggplot(data=qSub(), aes(x=stations)) +
geom_histogram(binwidth=5) +
xlab('Number of Reporting Stations') +
ylab('Count') +
xlim(min(qDat$stations), max(qDat$stations))+
ggtitle('Fiji Earthquake')
})
# table
output$table01 <- renderDataTable({
DT::datatable(qSub(), selection = "single",options=list(stateSave = TRUE))
})
# map
output$map01 <- renderLeaflet({
pal <- colorNumeric("YlOrRd", domain=c(min(quakes$mag), max(quakes$mag)))
qMap <- leaflet(data = qSub()) %>%
addTiles() %>%
addMarkers(popup=~as.character(mag), layerId = qSub()$id) %>%
addLegend("bottomright", pal = pal, values = ~mag,
title = "Earthquake Magnitude",
opacity = 1)
qMap
})
observeEvent(input$map01_marker_click, {
clickId <- input$map01_marker_click$id
dataTableProxy("table01") %>%
selectRows(which(qSub()$id == clickId)) %>%
selectPage(which(input$table01_rows_all == clickId) %/% input$table01_state$length + 1)
})
}
##############################################################################
shinyApp(ui = ui, server = server)
##############################################################################
Any suggestions?
Yes, that is possible. You can get the selected row form the datatable with input$x_rows_selected where x is the datatable name. We can then use the leafletProxy to remove the old marker and add a new one. I also created a reactiveVal that keeps track of the previously marked row, and reset the marker for that element when a new one is clicked. If you want to keep previously selected markers red as well, simply remove the reactiveVal prev_row() and remove the second part of the observeEvent. Below is a working example.
Note that I added a head(25) in the qSub() reactive to limit the number of rows for illustration purposes.
Hope this helps!
##############################################################################
# Libraries
##############################################################################
library(shiny)
library(shinythemes)
library(ggplot2)
library(plotly)
library(leaflet)
library(DT)
##############################################################################
# Data
##############################################################################
qDat <- quakes
qDat$id <- seq.int(nrow(qDat))
str(qDat)
##############################################################################
# UI Side
##############################################################################
ui <- fluidPage(
titlePanel("Visualization of Fiji Earthquake"),
# side panel
sidebarPanel(
h3('Fiji Earthquake Data'),
sliderInput(
inputId = "sld01_Mag",
label="Show earthquakes of magnitude:",
min=min(qDat$mag), max=max(qDat$mag),
value=c(min(qDat$mag),max(qDat$mag)), step=0.1
),
plotlyOutput('hist01')
),
# main panel
mainPanel(
leafletOutput('map01'),
dataTableOutput('table01')
)
)
##############################################################################
# Server Side
##############################################################################
server <- function(input,output){
qSub <- reactive({
subset <- subset(qDat, qDat$mag>=input$sld01_Mag[1] &
qDat$mag<=input$sld01_Mag[2]) %>% head(25)
})
# histogram
output$hist01 <- renderPlotly({
ggplot(data=qSub(), aes(x=stations)) +
geom_histogram(binwidth=5) +
xlab('Number of Reporting Stations') +
ylab('Count') +
xlim(min(qDat$stations), max(qDat$stations))+
ggtitle('Fiji Earthquake')
})
# table
output$table01 <- renderDataTable({
DT::datatable(qSub(), selection = "single",options=list(stateSave = TRUE))
})
# to keep track of previously selected row
prev_row <- reactiveVal()
# new icon style
my_icon = makeAwesomeIcon(icon = 'flag', markerColor = 'red', iconColor = 'white')
observeEvent(input$table01_rows_selected, {
row_selected = qSub()[input$table01_rows_selected,]
proxy <- leafletProxy('map01')
print(row_selected)
proxy %>%
addAwesomeMarkers(popup=as.character(row_selected$mag),
layerId = as.character(row_selected$id),
lng=row_selected$long,
lat=row_selected$lat,
icon = my_icon)
# Reset previously selected marker
if(!is.null(prev_row()))
{
proxy %>%
addMarkers(popup=as.character(prev_row()$mag),
layerId = as.character(prev_row()$id),
lng=prev_row()$long,
lat=prev_row()$lat)
}
# set new value to reactiveVal
prev_row(row_selected)
})
# map
output$map01 <- renderLeaflet({
pal <- colorNumeric("YlOrRd", domain=c(min(quakes$mag), max(quakes$mag)))
qMap <- leaflet(data = qSub()) %>%
addTiles() %>%
addMarkers(popup=~as.character(mag), layerId = as.character(qSub()$id)) %>%
addLegend("bottomright", pal = pal, values = ~mag,
title = "Earthquake Magnitude",
opacity = 1)
qMap
})
observeEvent(input$map01_marker_click, {
clickId <- input$map01_marker_click$id
dataTableProxy("table01") %>%
selectRows(which(qSub()$id == clickId)) %>%
selectPage(which(input$table01_rows_all == clickId) %/% input$table01_state$length + 1)
})
}
##############################################################################
shinyApp(ui = ui, server = server)
##############################################################################

selecting a marker on leaflet, from a DT row click and vice versa

The minimal example below renders a leaflet map with 3 markets, and a DT table with 3 records. When a market on the map is selected, so to is the matching record on the table. However, what I cannot do, is to also have the reverse of that, where a clicked row on the table also shows the related popup on the map.
I have been unable to find an example R shiny leaflet app that does something similar.
CODE tweaked to reflect initial comments
library(shiny)
library(leaflet)
library(DT)
library(tidyverse)
# Define UI for application that draws a histogram
ui <- fluidPage(
leafletOutput("opsMap"),
DT::dataTableOutput('ranksDT')
)
# Define server logic required to draw a histogram
server <- function(input, output) {
lats <- c(21.608889,21.693056, 24.04)
longs <- c(-74.650833, -73.095,-74.341944)
popups <- c('a','b','c')
layerids <- c('a','b','c')
iconNames <- c('cog','cog','cog')
iconColors <- c('red','red','red')
sampleData <- tibble(lats,longs, popups,layerids,iconNames,iconColors)
score <- c(7,3,9)
locationRanks <- tibble(popups, score)
output$opsMap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addAwesomeMarkers(lat = sampleData$lats,
lng = sampleData$longs,
popup = sampleData$popups,
layerId = sampleData$layerids,
icon = makeAwesomeIcon(icon=sampleData$iconNames,
markerColor=sampleData$iconColors))
})
output$ranksDT <- DT::renderDataTable({
d1 <- datatable(locationRanks,
selection = 'single',
rownames=FALSE,
options = list(dom = 'tpi',
pageLength =5,
paging=FALSE,
searching=FALSE
)
)
d1
})
# create a reactive value that will store the click position
mapClick <- reactiveValues(clickedMarker=NULL)
mapClick <- reactiveValues(clickedGroup=NULL)
# create a reactive for the DT table
locationClick <-reactiveValues(clickedRow = NULL)
# observe click events
observe({
mapClick$clickedMarker <- paste(input$opsMap_marker_click$id)
mapClick$clickedGroup <- paste(input$opsMap_marker_click$group)
locationClick$clickedRow <- input$ranksDT_rows_selected
})
# define a proxy variable for the plant rank table
proxy1 = dataTableProxy('ranksDT')
# when map is clicked, make the same table row selection - need row number
observeEvent(input$opsMap_marker_click$id, {
a <- which(locationRanks[1] == input$opsMap_marker_click$id)
proxy1 %>% selectRows(a)
})
proxy2 = leafletProxy('opsMap', session = shiny::getDefaultReactiveDomain())
# if table is clicked, select the same market from the map
observeEvent(locationClick$clickedRow, {
a <- as.character(locationRanks[locationClick$clickedRow,1])
cat(file=stderr(),"clicked row", locationClick$clickedRow, a,'\n')
#proxy2 %>% opsMap_marker_click$id <- a
})
}
# Run the application
shinyApp(ui = ui, server = server)
A solution could be to use input$map01_marker_click$id together with dataTableProxy(), selectRows() and selectPage() if you want to highlight rows in the datatable.
In order to highlight markers, i think you could either use some javascript to simulate a click on the marker. But i would also go for the easier way to adding a highlighted marker and removing it afterwards.
Basically your question was partly answered in this question: Shiny - how to highlight an object on a leaflet map when selecting a record in a datatable? and the remaining part was in one of the answers. -> credits to them.
As the code was quity lengthy, i made the effort to reduce it towards a minimal reproducible example.
Minimal reproducible example:
library(shiny)
library(leaflet)
library(DT)
qDat <- quakes[1:10, ]
qDat$id <- seq.int(nrow(qDat))
ui <- fluidPage(
mainPanel(
leafletOutput('map01'),
dataTableOutput('table01')
)
)
server <- function(input,output){
output$table01 <- renderDataTable({
DT::datatable(qDat, selection = "single", options = list(stateSave = TRUE))
})
# to keep track of previously selected row
prev_row <- reactiveVal()
# new icon style
highlight_icon = makeAwesomeIcon(icon = 'flag', markerColor = 'green', iconColor = 'white')
observeEvent(input$table01_rows_selected, {
row_selected = qDat[input$table01_rows_selected, ]
proxy <- leafletProxy('map01')
proxy %>%
addAwesomeMarkers(popup = as.character(row_selected$mag),
layerId = as.character(row_selected$id),
lng = row_selected$long,
lat = row_selected$lat,
icon = highlight_icon)
# Reset previously selected marker
if(!is.null(prev_row())){
proxy %>%
addMarkers(popup = as.character(prev_row()$mag),
layerId = as.character(prev_row()$id),
lng = prev_row()$long,
lat = prev_row()$lat)
}
# set new value to reactiveVal
prev_row(row_selected)
})
output$map01 <- renderLeaflet({
leaflet(data = qDat) %>%
addTiles() %>%
addMarkers(popup = ~as.character(mag), layerId = as.character(qDat$id))
})
observeEvent(input$map01_marker_click, {
clickId <- input$map01_marker_click$id
dataTableProxy("table01") %>%
selectRows(which(qDat$id == clickId)) %>%
selectPage(which(input$table01_rows_all == clickId) %/% input$table01_state$length + 1)
})
}
shinyApp(ui = ui, server = server)
This is not a solution, just some things that I found out about the code when looking at it.
The ID plantRanks only appears once in your code.
That is in input$plantRanksDT_rows_selected. Such things are easy to find and easy to fix. The correct id should be the output id of the datatable, so ranksDT. Once you replace that, you will see a second issue
proxy2 %>% opsMap_marker_click$id <- a makes no sense.
input$opsMap_marker_click$id exists but can obviously not be written. I don't exactly know how leaflet proxys work, but
leaflet::addMarkers()
looks promising. Good luck!

Use the dynamic value from selectinput in R leaflet setview

I'm creating a shiny leaflet map to record where I have been. I have a dataset contains coordinates and time. In my shiny app I've got 2 widgets-- a sliderbard for time line, a dropdown box to show the current countries that I have been. The country choices in the dropdown box is based on the time line sliderbar. Say for example: before 2016 all coordinates on the map are in country A then in the dropdown box there will be only one option in the dropdown box (country A). After 2016-01-01, the number of countries that I have been increased to 2 then in the dropdown box there will be 2 options (country A and country B) and currently this function works well.
Now I want to further develop my shiny app, the function I want is when I have multiple countries in the dropdown box, the app should allow me to choose one of the countries and when the country is chosen, the leaflet map will focus on the country I choose. I think using if else in setview() should solve the problem.
Then I created a (partially) workable shiny script below:
global.R
df <-read.csv("https://dl.dropbox.com/s/5w09dayyeav7hzy/Coordinatestest.csv",
header = T,
stringsAsFactors = F)
df$Time <- as.Date(df$Time, "%m/%d/%Y")
countriesSP <- getMap(resolution='low')
and
ui.R
library(devtools)
library(leaflet)
library(htmlwidgets)
library(shiny)
library(shinydashboard)
library(sp)
library(rworldmap)
library(RCurl)
header <- dashboardHeader(
title = 'Shiny Memery'
)
body <- dashboardBody(
fluidRow(
tabBox(
tabPanel("My Map", leafletOutput("mymap",height = 550)),
width = 700
))
)
dashboardPage(
header,
dashboardSidebar(
sliderInput('Timeline Value','Time line',min = min(df$Time),max = max(df$Time), value = min(df$Time)),
selectInput("select_country", label = "Select Country",
choices = NULL,
selected = NULL)
),
body
)
and
server.R
shinyServer(function(input, output, session) {
output$mymap <- renderLeaflet({
df <- subset(df, df$Time <= input$`Timeline Value`)
observe({
pointsSP <- SpatialPoints(df[,c("lon", "lat")], proj4string=CRS(proj4string(countriesSP)))
indices <- over(pointsSP, countriesSP)
part_choices <- as.list(c("All", na.omit(unique(as.character(indices$ADMIN)))))
updateSelectInput(session, "select_country", choices=part_choices)
})
lng <- ifelse(input$select_country == "All", mean(df$lon), 0)
lat <- ifelse(input$select_country == "All", mean(df$lat), 0)
m <- leaflet(df) %>%
addTiles(
#urlTemplate = "http://otile4.mqcdn.com/tiles/1.0.0/sat/{z}/{x}/{y}.png"
) %>% # Add default OpenStreetMap map tiles
#setView(mean(df$lon), mean(df$lat), zoom = 5) %>%
setView(lng, lat, zoom = 5) %>%
addMarkers(~lon, ~lat,
clusterOptions = markerClusterOptions())
})
})
Please copy and paste the script into Rstudio and run it. You will see as you drag the time line till the end, the country option will increase but default is always All. Ideally when I select one country and as you see based on some simple logic as long as the selection is not All, the coordinates in setview() function should be (0,0) (this can be dynamic later, currently I just want setview() to change the focus of the map). This function is not really working currently, i.e. when I select other country, the focus of the map will change to (0,0) but again change back to the default focus (mean(df$lon), mean(df$lat)) immediately and the selection will change back to All as well.
So any idea on how to alter my code to make this work?
Hope you are clear about my situation in this example.
Much appreciate for the help
I have changed the server.R part how I think this should be done. Let me know if this helps.
server.R
shinyServer(function(input, output, session) {
dfs <- reactive({
tmp <- subset(df, df$Time <= input$`Timeline Value`)
tmp
})
part_choices <- reactive({
tmp <- dfs()
pointsSP <- SpatialPoints(tmp[,c("lon", "lat")], proj4string=CRS(proj4string(countriesSP)))
indices <- over(pointsSP, countriesSP)
as.list(c("All", na.omit(unique(as.character(indices$ADMIN)))))
})
observe({
updateSelectInput(session, "select_country", choices=part_choices())
})
output$mymap <- renderLeaflet({
lng <- ifelse(input$select_country == "All", mean(df$lon), 0)
lat <- ifelse(input$select_country == "All", mean(df$lat), 0)
m <- leaflet(dfs()) %>%
addTiles(
#urlTemplate = "http://otile4.mqcdn.com/tiles/1.0.0/sat/{z}/{x}/{y}.png"
) %>% # Add default OpenStreetMap map tiles
#setView(mean(dfs()$lon), mean(dfs()$lat), zoom = 5) %>%
setView(lng, lat, zoom = 5) %>%
addMarkers(~lon, ~lat,
clusterOptions = markerClusterOptions())
})
})

Resources