I am in the process of making a shiny app. I am trying to make my map interactive where the map shows only the selected Sites. Although, right now my map is showing the location of every single site in the data. This is what I have tried doing so far.( this is a simplified code)
Site_Name <-sample(c('a','b','c'),replace=T,5)
Latitude <-runif(5,min=-26, max=-22)
Longitude<-runif(5,min=-54, max=-48)
Sites <-data.frame(Site_Name,Latitude,Longitude)
fluidPage(
theme = shinytheme("cerulean"),
sidebarLayout(
sidebarPanel(
selectizeInput("sites",
"Site Name",choices= Sites$Site_Name,
options= list(maxItems = 2)),
mainPanel(
tabsetPanel(
tabPanel("Plots",leafletOutput("Station")
)
)
shinyServer(function(input, output, session) {
df1 <- eventReactive(input$sites, {
Sites %>% dplyr::filter(Site_Name %in% input$sites)
})
output$Station = renderLeaflet({
leaflet(data = df1()) %>%
addProviderTiles(providers$Esri.WorldStreetMap) %>%
addMarkers(Sites$Longitude, Sites$Latitude, popup= input$sites,
icon = list(
iconUrl = 'https://raw.githubusercontent.com/pointhi/leaflet-color-markers/master/img/marker-icon-2x-red.png',
iconSize = c(13, 20)))
})
}
It's showing all because you told to show all. You should replace Sites$Longitude, Sites$Latitude, popup= input$sites in addMarkers with lng = ~Longitude, lat = ~Latitude, popup= ~Site_Name.
Related
The code below generates two maps, one being generated by the googleway package and the other by the leaflet package. See in the image that a region is selected in selectInput and automatically two maps are generated. If I change my selectInput with another option, the map automatically updates the new locations. This is working fine. The problem is when I go to the other tabPanel, that is "Distance between locations", and I try to choose another region to showe the map again, only the map generated in the leafletupdates, the map generated by googleway does not, this is strange. Any help on this problem?
library(shiny)
library(shinythemes)
library(googleway)
library(shinyjs)
library(dplyr)
library(leaflet)
set_key("API KEY")
df1<-structure(list(ETEs = c("Location1", "Location2",
"Location3", "Location4", "Location5", "Location6",
"Location7", "Location8"), Latitude = c(-22.8851078223344,
-22.8315940282463, -22.9269302273894, -22.7168354545552, -22.4049856273179,
-23.6335639883851, -23.8650940097111, -22.2258061474773),
Longitude = c(-48.4939312250395,-48.4298167144681, -48.4594335076124, -48.5783308965308,
-48.1690878117765,-49.3218749756598, -48.0149391697704, -48.7246763738941),
Region = c("Centro-Oeste Paulista", "Centro-Oeste Paulista", "Centro-Oeste Paulista", "Centro-Oeste Paulista", "Nordeste Paulista",
"Nordeste Paulista", "Nordeste Paulista", "Nordeste Paulista")), row.names = c(NA, -8L), class = "data.frame")
function.test<-function(df1,selected_regions){
df_filtered <- df1 %>%
filter(Region %in% selected_regions)
plot1<-google_map() %>%
add_markers(data = df_filtered, lat = "Latitude", lon = "Longitude", info_window = df_filtered$ETEs)%>%
clear_traffic() %>%
clear_polylines() %>%
clear_markers() %>%
add_traffic()
plot2<- leaflet() %>%
addMarkers(data = df_filtered, lat = ~Latitude, lng = ~Longitude)
return(list(
"Plot1" = plot1,
"Plot2" = plot2
))
}
ui <- fluidPage(
useShinyjs(),
shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
br(),
tabPanel("",
sidebarLayout(
sidebarPanel(
selectizeInput("hours",
label = h5("Choose the region:"), choices = NULL,
multiple = TRUE,
options = list(maxItems = 1))),
mainPanel(
tabsetPanel(
tabPanel("Map",google_mapOutput(outputId = "mapWarsaw1",width = "80%", height = "400"),leafletOutput(outputId = "mapWarsaw2", width = "80%", height = "400")),
tabPanel("Distance between locations"))
)
)
)
))
server <- function(input, output,session) {
df1_reactive <- reactive(function.test(df1, input$hours))
observe({
updateSelectizeInput(session, "hours",
choices = unique(df1$Region)
)
})
output$mapWarsaw1 <- renderGoogle_map({
req(input$hours)
df1_reactive()[[1]]
})
output$mapWarsaw2 <- renderLeaflet({
req(input$hours)
df1_reactive()[[2]]
})
}
shinyApp(ui = ui, server = server)
Map OK
Map after press tabPanel Distance between locations and try to generate the maps again
df1_reactive <- reactive(function.test(df1, input$hours))
I'd start by swapping this to an eventReactive.
df1_reactive <- eventReactive(input$hours, {
function.test(df1, input$hours)
})
But I think your problem is that by switching tabs you are suspending the execution. See here: https://shiny.rstudio.com/reference/shiny/latest/outputoptions
Unfortunately, I can't reproduce without an API key but try this:
# Disable suspend for output$myplot
outputOptions(output, "mapWarsaw1", suspendWhenHidden = FALSE)
In Shiny, I have produced a leaflet map with clustered markers, and the cluster icon is a custom one, defined by me through JavaScript (JS() function). Such map should be reactive based on user inputs in a radioButton(). Hence, I used an observer() with an if statement, updating the map through leafletProxy().
When the icon of the cluster is a custom one, and not Leaflet's default, the marker cluters don't even appear. It seems that leafletProxy() can't handle the "reactivity" of the observer(). Below a minimal reproducible example.
library(shiny)
library(leaflet)
ui <- fluidPage(
br(),
radioButtons(inputId = "markers",
label = NULL,
choices = c("Type A",
"Type B"),
selected = "Type A"),
br(),
leafletOutput(outputId = "map")
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(lng = 178.441895,
lat = -18.141600,
zoom = 3.5)
})
observe({
if (input$markers == "Type A") {
leafletProxy(mapId = "map") %>%
clearMarkerClusters() %>%
addMarkers(data = quakes,
lng = ~long,
lat = ~lat,
clusterOptions = markerClusterOptions())
} else {
leafletProxy(mapId = "map") %>%
clearMarkerClusters() %>%
addMarkers(data = quakes,
lng = ~long,
lat = ~lat,
clusterOptions = markerClusterOptions(iconCreateFunction = JS("function (cluster) {
return new L.Icon({iconUrl: 'https://nicocriscuolo.github.io/resistancebank_plots/markers/marker_3D.png',
iconSize: [18, 27],
iconAnchor: [10, 26],
shadowUrl: 'https://nicocriscuolo.github.io/resistancebank_plots/markers/shadow-marker_3D.png',
shadowSize: [26, 39],
shadowAnchor: [5, 28]});}")))
}
})
}
shinyApp(ui, server)
What could be a possible solution?
This has finally been solved by Joe Cheng. Solution here:
https://github.com/rstudio/leaflet/pull/696
Make sure to install the updated leaflet version through:
remotes::install_github("rstudio/leaflet")
I can't find any documentation on how to add a tooltip with addPulseMarkers above the Layer Control (using leaflet.extras). See below for an example of what I'd aiming to do.
library(shiny)
library(leaflet)
library(leaflet.extras)
ui <- fluidPage(
leafletOutput("map")
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet(quakes) %>%
addPulseMarkers(lng = ~long, lat = ~lat,
icon = makePulseIcon(color = "blue", heartbeat = 2),
group = "I want a tooltip on hover above this that says, 'Nice'") %>%
addLayersControl(
overlayGroups = c("I want a tooltip on hover above this that says, 'Nice'"),
options = layersControlOptions(collapsed = FALSE)
)
})
}
shinyApp(ui, server)
Do you mean like this?
library(shiny)
library(leaflet)
library(leaflet.extras)
ui <- fluidPage(
leafletOutput("map")
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet(quakes) %>%
addPulseMarkers(lng = ~long, lat = ~lat,
icon = makePulseIcon(color = "blue", heartbeat = 2),
group = "I want a tooltip on hover above this that says, 'Nice'") %>%
addLayersControl(
overlayGroups = c("I want a tooltip on hover above this that says, 'Nice'"),
options = layersControlOptions(collapsed = FALSE)
) %>%
htmlwidgets::onRender("
function() {
$('.leaflet-control-layers-overlays').prepend('<label style=\"text-align:center\">Nice</label>');
}
")
})
}
shinyApp(ui, server)
It borrows from: Add title to layers control box in Leaflet using R
I create a map app using shiny and leaflet.
It projects a map and some shape files.
The shape file has area values.
I want to set whether to display the shape file or not based on the area value.
Specifically, the sliderInput function is used.
Although the display of the shape file is restricted using the sliderInput function,
The setview is reset every time the number is changed by sliderInput.
Instead of running setview every time, I want you to run setview where you are.
What should I do? I want you to tell me.
Below is the sample code
library(shiny)
library(leaflet)
ui <- shinyUI(fluidPage(
titlePanel("sample sample sample sample "),
#sidebarLayout settings
sidebarLayout(
sidebarPanel(
sliderInput("area_slider",label = h3("settings"),min = 0,max = 6000,value = c(0,6000)),
),
#mainpanel settings
mainPanel(
leafletOutput("mymap",height=600)
)
)
))
server <- shinyServer(function(input, output) {
#map settings
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles(group="OSM")%>%
#setView
#setView(lng=139.8,lat=35.7,zoom=12)%>%
#maker settings1
addAwesomeMarkers(lng = df$lng,
lat = df$lat,
clusterOptions = markerClusterOptions(),
group="Oct")%>%
addPolygons(data = shp %>% subset(shp#data$area < input$area_slider),
color = "#2feeb5",
group="carea")%>%
#Layers Control
addLayersControl(
baseGroups = c("OSM"),
overlayGroups = c("Oct","carea"),
options = layersControlOptions(collapsed = FALSE))
})
})
shinyApp(ui, server)
Using the example below, I am trying to figure out a way to add functionality to my shiny app such that the following works:
Click on a point on the map
This changes the plot according to station AND
Inputs the corresponding station into the "Click on Station" sidebar
Basically I'd like to be able either click on the map for a station OR input the station manually with a keyboard.
Is this possible with leaflet? I've seen references to using plotly which may be ultimate solution but I'd love to leaflet if possible in no small part because I have already done a lot of work with leaflet. This is similar to thisquestion though there is working example here:
library(shiny)
library(leaflet)
library(shinydashboard)
library(ggplot2)
library(dplyr)
data("quakes")
shinyApp(
ui = dashboardPage(title = "Station Lookup",
dashboardHeader(title = "Test"),
dashboardSidebar(
sidebarMenu(
menuItem("Data Dashboard", tabName = "datavis", icon = icon("dashboard")),
menuItem("Select by station number", icon = icon("bar-chart-o"),
selectizeInput("stations", "Click on Station", choices = levels(factor(quakes$stations)), selected = 10, multiple = TRUE)
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "datavis",
h4("Map and Plot"),
fluidRow(box(width= 4, leafletOutput("map")),
box(width = 8, plotOutput("plot")))
)
)
)
),
server = function(input, output) {
## Sub data
quakes_sub <- reactive({
quakes[quakes$stations %in% input$stations,]
})
output$plot <- renderPlot({
ggplot(quakes_sub(), aes(x = depth, y = mag))+
geom_point()
})
output$map <- renderLeaflet({
leaflet(quakes) %>%
addTiles() %>%
addCircleMarkers(lng = ~long, lat = ~lat, layerId = ~stations, color = "blue", radius = 3) %>%
addCircles(lng = ~long, lat = ~lat, weight = 1,
radius = 1, label = ~stations,
popup = ~paste(stations, "<br>",
depth, "<br>",
mag)
)
})
}
)
You can use input$map_marker_click and updateSelectInput():
Edit: Added functionality that stations can be deleted from selectInput() as suggested by OP in the comments.
(Dont forget to add session to your sever function).
observeEvent(input$stations,{
updateSelectInput(session, "stations", "Click on Station",
choices = levels(factor(quakes$stations)),
selected = c(input$stations))
})
observeEvent(input$map_marker_click, {
click <- input$map_marker_click
station <- quakes[which(quakes$lat == click$lat & quakes$long == click$lng), ]$stations
updateSelectInput(session, "stations", "Click on Station",
choices = levels(factor(quakes$stations)),
selected = c(input$stations, station))
})
However, this functionality is partly overwritten by the popup event(?). As i see it there is an inner blue circle (darker blue) that if clicked produces the popup. However, the input$map_marker_click only works if you click the outer (light blue) circle. I would report it as a bug,...