Related
I am trying to add an easyButton with a flyTo function within a shiny app in R.
When the user presses the button, it will fly to the current location (lat/long). I am using a reactivePoll to poll a boat instrument simulator every 5 seconds (NMEA simulator), which is where the lat/long come from. A path is also drawn by using addCircleMarkers. I want to keep this path drawn, and the flyTo button to pan and zoom to the current location without refreshing the map, i.e. removing the path that was drawn.
In my current code with the flyTo button, with every poll the map refreshes. If I remove this code, the map does not refresh, so I think how I'm using the reactive within this button is the issue, but I'm not sure why. It may be because I have a reactive inside a reactive (All_NMEA() inside of renderleaflet()). The code of interest in the reprex is:
addEasyButton(easyButton(
icon = "fa-crosshairs", title = "Locate Vessel",
onClick = JS("
function(btn, map) {
map.flyTo([", paste(as.numeric(All_NMEA()["lat"]) / 100), ",", paste(as.numeric(All_NMEA()["long"]) / -100), "], zoom = 10);
}
")
))
The NMEA simulator is required to produce data that is polled, linked above.
Reproducible example:
# https://chrome.google.com/webstore/detail/nmea-simulator/dfhcgoinjchfcfnnkecjpjcnknlipcll?hl=en
# needs an NMEA simulator to generate the poll data
#
library(shiny)
library(leaflet)
connect <- function() {
s_con <<- socketConnection("127.0.0.1", port = 55555, open = "a+")
Sys.sleep(1)
NMEA_poll <<- readLines(s_con, n = 18)
close(s_con)
return(NMEA_poll)
}
pollGPRMC <- function(data) {
gps_ans <- list(rmc = NULL, rest = data)
rxp <-
"\\$GPRMC(,[^,]*){12}\\*[0-9,A-F]{2}"
beg <- regexpr(rxp, data)
if (beg == -1)
return(gps_ans)
end <-
beg + attr(beg, "match.length")
sub <-
substr(data, beg, end - 6)
gps_ans$rmc <-
strsplit(sub, ",")[[1]]
names(gps_ans$rmc) <- c(
"id_rmc",
"UTC",
"status",
"lat",
"N/S",
"long",
"E/W",
"boat speed (knots)",
"cog (deg)",
"date (ddmmyy)" # ddmmyy
)
gps_ans$rest <- substr(data, end, nchar(data))
return(gps_ans)
}
map_data <- data.frame(lat = c(36.05, 36.25), lon = c(-132.13, -132.33))
ui <- fluidPage(
# Application title
titlePanel("Map"),
mainPanel(tags$style(type = "text/css", "#map {height: calc(100vh - 80px) !important;}"),
leafletOutput("map"))
)
server <- function(input, output, session) {
All_NMEA <- shiny::reactivePoll(
5000,
session,
checkFunc = Sys.time,
valueFunc = function() {
connect()
NMEA_data <- toString(NMEA_poll)
GPS_dat <- pollGPRMC(NMEA_data)
lat_deg <- substr(GPS_dat$rmc["lat"], 1, 2)
lat_mins <- substr(GPS_dat$rmc["lat"], 3, 9)
lat_for_dist <- as.numeric(lat_deg) + (as.numeric(lat_mins) / 60)
print(lat_for_dist)
lon_deg <- substr(GPS_dat$rmc["long"], 1, 3)
lon_mins <- substr(GPS_dat$rmc["long"], 4, 9)
lon_for_dist <- (as.numeric(lon_deg) + (as.numeric(lon_mins) / 60))*-1
print(lon_for_dist)
leafletProxy("map", session = session) %>%
addCircleMarkers(
lng = lon_for_dist,
lat = lat_for_dist,
radius = 1,
fillOpacity = 1, color = "red"
)
NMEA_out <- c(GPS_dat$rmc)
return(NMEA_out)
}
)
ord <- function(data) {
print(data)
}
observe(ord(All_NMEA()))
output$map <- renderLeaflet({
map <- leaflet(map_data) %>%
addProviderTiles(providers$Esri.OceanBasemap, group = "ocean basemap (default)") %>%
addTiles(group = "Basic") %>%
fitBounds( ~ min(lon), ~ min(lat), ~ max(lon), ~ max(lat)) %>%
addLayersControl(
baseGroups = c("ocean basemap (default)", "Basic"),
options = layersControlOptions(collapsed = FALSE)) %>%
fitBounds( ~ min(lon), ~ min(lat), ~ max(lon), ~ max(lat)) %>%
addEasyButton(easyButton(
icon = "fa-crosshairs", title = "Locate Vessel",
onClick = JS("
function(btn, map) {
map.flyTo([", paste(as.numeric(All_NMEA()["lat"]) / 100), ",", paste(as.numeric(All_NMEA()["long"]) / -100), "], zoom = 10);
}
")
))
})
}
shinyApp(ui = ui, server = server)
You answered the question yourself in your last sentence. The map will always be redrawn whenever the reactive All_NMEA changes. To prevent that, you would normally use leafletProxy but apparently you cannot add an easyButton like that, so I offer you another solution.
A click on the easyButton will trigger another shiny input that is called my_easy_button. In an observeEvent you listen to this event and do the flyTo there within a leafletProxy.
library(shiny)
library(leaflet)
map_data <- data.frame(lat = c(36.05, 36.25), lon = c(-132.13, -132.33))
ui <- fluidPage(
titlePanel("Map"),
mainPanel(tags$style(type = "text/css", "#map {height: calc(100vh - 80px) !important;}"),
leafletOutput("map"))
)
server <- function(input, output, session) {
All_NMEA <- shiny::reactivePoll(
intervalMillis = 5000,
session = session,
checkFunc = Sys.time,
valueFunc = function() {
NMEA_out <- data.frame(lat = runif(1, 0, 20),
long = runif(1, 0, 20))
leafletProxy("map", session = session) %>%
addCircleMarkers(
lng = NMEA_out$long,
lat = NMEA_out$lat,
radius = 1,
fillOpacity = 1, color = "red"
)
return(NMEA_out)
}
)
observe({All_NMEA()})
output$map <- renderLeaflet({
map <- leaflet(map_data) %>%
addProviderTiles(providers$Esri.OceanBasemap, group = "ocean basemap (default)") %>%
addTiles(group = "Basic") %>%
addLayersControl(
baseGroups = c("ocean basemap (default)", "Basic"),
options = layersControlOptions(collapsed = FALSE)) %>%
addEasyButton(
easyButton(id = "buttonid",
icon = "fa-crosshairs", title = "Locate Vessel",
onClick = JS("function(btn, map) {
Shiny.onInputChange('my_easy_button', 'clicked', {priority: 'event'});
}")
))
})
observeEvent(input$my_easy_button, {
print("easyButton is clicked")
allnmea <- req(All_NMEA())
leafletProxy("map", session = session) %>%
flyTo(lng = allnmea$long, lat = allnmea$lat, zoom = 5)
})
}
shinyApp(ui = ui, server = server)
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,
)
})
I would like the icons on a leaflet map to be linked to the correspondent trace on a plotly line plot in a shiny app. Once I click on an icon, only the line with the same id should be displayed in plotly. Is this possible? I have been trying with crosstalk but I must be missing something.
library(shiny)
library(leaflet)
library(plotly)
library(crosstalk)
tmp1 <- data.frame(Date = seq(as.POSIXct("2016-06-18 10:00"),
length.out = 10, by = "mins"),
Temp = rnorm(n = 10, mean = 20, sd = 5),
lat=51.504162,
long=-0.130472,
id="first")
tmp2 <- data.frame(Date = seq(as.POSIXct("2016-06-18 10:00"),
length.out = 10, by = "mins"),
Temp = rnorm(n = 10, mean = 20, sd = 5),
lat=51.502858,
long= -0.116722,
id="second")
uktemp<-rbind(tmp1,tmp2)
#=========================================
ui <- fluidPage(
fluidRow(
column(6, leafletOutput("map")),
column(6, plotlyOutput("graph"))
)
)
server <- function(input, output, session) {
crossuktemp<- SharedData$new(uktemp)
output$map <- renderLeaflet({
leaflet(options = leafletOptions(minZoom = 15,maxZoom =18 ))%>%
addTiles()%>%
addCircles(data=crossuktemp,
lng= ~ long,
lat= ~ lat,
label=~id)
})
output$graph <- renderPlotly({
plot_ly(crossuktemp,x=~Date,y=~Temp, color =~id, mode="lines")%>%
layout(title = "",yaxis = list(title = "C°"),
xaxis = list(title = "Time")) %>%
highlight(off = "plotly_deselect")
})
}
shinyApp(ui, server)
I've hacked together a solution, making use of leaflets events it creates on the click.
ui <- fluidPage(
# add a reset button to undo click event
fluidRow(actionButton("reset", "Reset")),
fluidRow(
column(6, leafletOutput("map")),
column(6, plotlyOutput("graph"))
),
fluidRow()
)
server <- function(input, output, session) {
# create reactive data set based on map click
filteredData <- reactive({
event <- input$map_shape_click
if (!is.null(event)){
uktemp[uktemp$lat == event$lat & uktemp$long == event$lng,]
}
})
output$map <- renderLeaflet({
leaflet(options = leafletOptions(minZoom = 15,maxZoom =18 ))%>%
addTiles()%>%
addCircles(data=uktemp,
lng= ~ long,
lat= ~ lat,
label=~id)
})
# default graph
output$graph <- renderPlotly({
plot_ly(uktemp,x=~Date,y=~Temp, color =~id, mode="lines")%>%
layout(title = "",yaxis = list(title = "C°"),
xaxis = list(title = "Time")) %>%
highlight(off = "plotly_deselect")
})
# if clicked on map, use filtered data
observeEvent(input$map_click,
output$graph <- renderPlotly({
plot_ly(filteredData(),x=~Date,y=~Temp, color =~id, mode="lines")%>%
layout(title = "",yaxis = list(title = "C°"),
xaxis = list(title = "Time")) %>%
highlight(off = "plotly_deselect")
})
)
# if reset, then go back to main data
observeEvent(input$reset,
output$graph <- renderPlotly({
plot_ly(uktemp,x=~Date,y=~Temp, color =~id, mode="lines")%>%
layout(title = "",yaxis = list(title = "C°"),
xaxis = list(title = "Time")) %>%
highlight(off = "plotly_deselect")
})
)
}
To do so, have a read of these links
see the section: Inputs/Events
https://rstudio.github.io/leaflet/shiny.html
some SO questions
Click event on Leaflet tile map in Shiny
R shiny: reset plot to default state
To do undo the click event, I had to add a reset button in. Maybe there is a way of undoing a click in a more elegant way. I expect there are cleaner ways to build this if you read around it some more :)
Cheers,
Jonny
Is there any way to select or highlight data on a leaflet map in by clicking on the legend in Rshiny?
example code:
library(shiny)
library(leaflet)
library(RColorBrewer)
library(leafletGeocoderRshiny)
ui <- fluidPage(
leafletOutput("map"),
p(),
actionButton("recalc", "New points")
)
server <- function(input, output, session) {
df = data.frame(x = rnorm(100), y = rexp(100, 2), z = runif(100))
pal = colorBin('PuOr', df$z, bins = c(0, .1, .4, .9, 1))
output$map <- renderLeaflet({ leaflet(df) %>%
addCircleMarkers(~x, ~y, color = ~pal(z)) %>%
addLegend(pal = pal, values = ~z)
})
}
shinyApp(ui, server)
The recent updates (0.2) to the mapedit package may help: http://r-spatial.org/r/2017/06/09/mapedit_0-2-0.html
I got close, but ran out of time now. But i decided to share anyway, maybe someone else sees a solution to the last step.
So far it works for the first click on any of the rectangles in the legend. It doesnt work for any following clicks as the map is redrawn and with it the onclick listeners are deleted. I didnt find a way to add them again so far,...
Its a hacky aprroach: I add onclick listener to the boxes and decided to update the colors via R as i didnt see a good way in JS.
library(shiny)
library(leaflet)
library(RColorBrewer)
library(leafletGeocoderRshiny)
library(shinyjs)
colors <- c("#000000", "#222222", "#888888", "#FFFFFF")
ui <- fluidPage(
useShinyjs(),
leafletOutput("map"),
p(),
actionButton("recalc", "New points")
)
server <- function(input, output, session) {
global <- reactiveValues(colors = colors,
bins = c(0, .1, .4, .9, 1))
observe({
print(input$interval)
isolate({
if(!is.null(input$interval)){
lowerBound <- as.numeric(unlist(input$interval))
global$colors <- colors
global$colors[which(global$bins == lowerBound)] <- "#FF0000"
}
})
})
session$onFlushed(function() {
runjs("
var legendButton = document.getElementsByTagName('i')
var elem; var interval;
for (nr = 0; nr < legendButton.length; nr++) {
elem = legendButton[nr]
elem.onclick = function(e){
console.log(e.target)
interval = e.target.nextSibling.nodeValue.split(' ');
Shiny.onInputChange('interval', interval[1]);
}
}
")
})
df = data.frame(x = rnorm(100), y = rexp(100, 2), z = runif(100))
pal = reactive({
colorBin(global$colors, df$z, bins = global$bins)
})
output$map <- renderLeaflet({ leaflet(df) %>%
addCircleMarkers(~x, ~y, color = ~pal()(z)) %>%
addLegend(pal = pal(), values = ~z)
})
}
runApp(shinyApp(ui, server), launch.browser = T)
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.