Click on points on Leaflet map to generate ggplot in Shiny - r

Using Shiny in R, I am attempting to create a Leaflet map which allows the user to click on any markers to generate a corresponding plot that represents the information (temperature) at that specific site.
I incorporated codes from this question (Click on points in a leaflet map as input for a plot in shiny) and the second trick on this blog (https://www.r-bloggers.com/4-tricks-for-working-with-r-leaflet-and-shiny/) but still cannot seem to successfully register the clicked marker point in Shiny.
i.e. Nothing plots when I click on any site.
I could not find any solutions based on further research, any help is appreciated.
library(leaflet)
library(shiny)
library(ggplot2)
# example data frame
wxstn_df <- data.frame(Site = c("a", "a", "b"), Latitude = c(44.1, 44.1, 37), Longitude = c(-110.2, -110.2, -112.7), Month = c(1,2,1), Temp_avg = c(10, 18, 12))
ui <- fluidPage(column(7, leafletOutput("wsmap", height = "600px")),
column(5, plotOutput("plot", height = "600px"))
)
server <- function(input, output) {
# create a reactive value to store the clicked site
stn <- reactiveValues(clickedMarker = NULL)
## leaflet map
output$wsmap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addCircleMarkers(data = wxstn_df, ~unique(Longitude), ~unique(Latitude), layerId = ~unique(Site), popup = ~unique(Site))
})
# store the click
observeEvent(input$map_marker_click, {
stn$clickedMarker <- input$map_marker_click
})
output$plot <- renderPlot({
ggplot(wxstn_df[wxstn_df$Site %in% stn$clickedmarker$Site,], aes(Month, Temp_avg)) +
geom_line()
})
}
shinyApp(ui, server)

Here's a solution:
library(leaflet)
library(shiny)
library(ggplot2)
# example data frame
wxstn_df <- data.frame(Site = c("a", "a", "b"), Latitude = c(44.1, 44.1, 37), Longitude = c(-110.2, -110.2, -112.7), Month = c(1,2,1), Temp_avg = c(10, 18, 12))
ui <- fluidPage(column(7, leafletOutput("wsmap", height = "600px")),
column(5, plotOutput("plot", height = "600px"))
)
server <- function(input, output) {
## leaflet map
output$wsmap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addCircleMarkers(data = wxstn_df, ~unique(Longitude), ~unique(Latitude), layerId = ~unique(Site), popup = ~unique(Site))
})
# generate data in reactive
ggplot_data <- reactive({
site <- input$wsmap_marker_click$id
wxstn_df[wxstn_df$Site %in% site,]
})
output$plot <- renderPlot({
ggplot(data = ggplot_data(), aes(Month, Temp_avg)) +
geom_line()
})
}
shinyApp(ui, server)
The main problem is that you were not changing the object names from the example that you were using, e.g. input$wsmap_marker_click because wsmap is the name of you leaflet ID. Similarly, to access Site info, use input$wsmap_marker_click$id not input$wsmap_marker_click$Site. It is often useful to print the objects within the reactive function to explore what the input object looks like and how to access parts of it.
e.g.
# generate data in reactive
ggplot_data <- reactive({
print(input$wsmap_marker_click)
site <- input$wsmap_marker_click$id
print(site)
data <- wxstn_df[wxstn_df$Site %in% site,]
print(data)
data})
Personally in this situation I would prefer to use a reactive expression generate ggplot data (ggplot_data()) from marker click rather than creating a reactiveValues object. Every time the marker is clicked the plot will update with new ggplot_data().
And proof it works:

Related

Shiny + Leaflet reactive function not working

My data consists of columns like lon , lat, region, flat-type and year. I have used leaflet and shiny to create a map with cluster markers.
I included 2 selectInput boxes - one for year and one for the flat-type. Using the reactive function, it keeps giving me this error whenever I run the shiny app.
Error: Don't know how to get location data from object of class
reactiveExpr,reactive
Here's my code
library(shiny)
library(leaflet)
library(dplyr)
ui <- fluidPage(
titlePanel("Transactions for Resale Flats"),
h3("Model A Flats: 3-Room, 4-Room, 5-Room"),
sidebarLayout(position = 'right',
sidebarPanel(
selectInput("year","Year", choices = c("2007","2008",
"2009","2010","2011",
"2012","2013","2014",
"2015","2016","2017"), selected="2007"),
selectInput("type","Flat-Type",choices = c("3 ROOM",'4 ROOM',"5 ROOM"),selected = "3-Room"),
width = 2),
mainPanel(leafletOutput("mymap",height = 650,width=605)))
)
server <- function(input,output, session){
headlinedata<-reactive({
headlinedata%>%
filter(year %in% input$year & flat_type %in% input$type)
})
output$mymap <- renderLeaflet({
leaflet(data=headlinedata) %>%
addTiles() %>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(headlinedata$address,',',headlinedata$town))
})
observe(leafletProxy('mymap', data=headlinedata()))%>%
clearMarkers()%>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(headlinedata$address,',',headlinedata$town))
}
shinyApp(ui = ui, server = server)
Also this code
observe(leafletProxy('mymap', data=headlinedata()))%>%
clearMarkers()%>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(headlinedata$address,',',headlinedata$town))
Whenever I include this, the app will run for a second and then close immediately. This code is supposed to update the map markers whenever the input changes.
Thanks.
First, you need to refer to reactive variables as the variable name followed by (). In output$mymap, you refer to headlinedata, which is the data frame to be filtered, when it should be headlinedata(), which is the reactive variable that's already been filtered. To disambiguate the two, I changed the name of the reactive variable to df. Then, when that reactive variable is needed in code downstream, I refer to it as df().
Second, since df() is a reactive variable and we've set up the leaflet to depend upon it, whenever the reactive variable changes, the map will also change. This means we don't need the observe(leafletProxy ... code.
Here's a reproducible example you can copy and paste.
library(shiny)
library(leaflet)
library(dplyr)
set.seed(1)
headlinedata <- data.frame(year = rep(2007:2017, 10),
flat_type = sample(c("3 ROOM",'4 ROOM',"5 ROOM"),
110, replace=T),
lat = sample(1:50, 110, replace=T),
lng = sample(1:50, 110, replace=T),
address = "address",
town = "town")
ui <- fluidPage(
titlePanel("Transactions for Resale Flats"),
h3("Model A Flats: 3-Room, 4-Room, 5-Room"),
sidebarLayout(position = 'right',
sidebarPanel(
selectInput("year","Year", choices = c("2007","2008",
"2009","2010","2011",
"2012","2013","2014",
"2015","2016","2017"), selected="2007"),
selectInput("type","Flat-Type",choices = c("3 ROOM",'4 ROOM',"5 ROOM"),selected = "3-Room"),
width = 2),
mainPanel(leafletOutput("mymap",height = 650,width=605)))
)
server <- function(input,output, session){
df<-reactive({
headlinedata%>%
dplyr::filter(year %in% input$year & flat_type %in% input$type)
})
output$mymap <- renderLeaflet({
leaflet(data=df()) %>%
addTiles() %>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(df()$address,',',df()$town))
})
}
shinyApp(ui = ui, server = server)

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))
})
})

Click on marker on map to show 2 ggplot chart on R shiny

I am new to R shiny.
I am able to show 1 line chart upon clicking on the marker on the map. However, I would like to show 2 line charts together, one on top of another at the side of the map, upon clicking onto the marker on the map.
I have attached the code below for 2 line charts.
Any help would be very appreciated. Thank you.
library(shiny) # for shiny apps
library(leaflet) # renderLeaflet function
library(readxl)
library(ggplot2)
server = function(input, output) {
Cookedfood_R <- readRDS("~/hawkermaster.rds")
line <- readRDS("~/line.rds")
line2 <- readRDS("~/line2.rds")
#Reshape the data for ggplot
traff2 <- melt(line,id=c("TYPE","newname"),variable.name = "Year")
traff3 <- melt(line2,id=c("TYPE","newname"),variable.name = "Year")
#Remove the X in the Year column and convert it to number
traff2$Year <- as.numeric(gsub(pattern="X",replacement = "",x = as.character(traff2$Year)))
traff3$Year <- as.numeric(gsub(pattern="X",replacement = "",x = as.character(traff3$Year)))
#getColor <- function(Cookedfood_R) {
# sapply(Cookedfood_R$TYPE, function(TYPE) {
# if(TYPE == 1) {"blue"}
# else {"orange"} })
#}
icons <- awesomeIcons(
icon = 'ion-close',
iconColor = 'black',
library = 'ion',
markerColor = getColor(Cookedfood_R)
)
output$map = renderLeaflet({
leaflet() %>% addTiles() %>%
addMarkers(data = Cookedfood_R,
lat = ~ LATITUDE,
lng = ~ LONGITUDE,
icon = icons,
layerId =~HAWKER,
popup = paste(Cookedfood_R$HAWKER, "<br>",
"No. of cooked food stalls:", Cookedfood_R$Cook, "<br>",
"No. of Market stalls:", Cookedfood_R$market,"<br>"))})
# generate data in reactive
ggplot_data <- reactive({
site <- input$map_marker_click$id
traff2[traff2$newname %in% site,]
})
ggplot_data2 <- reactive({
site2 <- input$map_marker_click$id2
traff3[traff3$newname %in% site2,]
})
output$plot1 <- renderPlot({
ggplot(data = ggplot_data(), aes(x = Year, y = value, color = TYPE))+
geom_line()+theme_bw()
#geom_point(aes(shape=TYPE, size=1))
})
output$plot2 <- renderPlot({
ggplot(data = ggplot_data2(), aes(x = Year, y = value, color = TYPE))+
geom_line()+theme_bw()
#geom_point(aes(shape=TYPE, size=1))
})
}
ui <- fluidPage(
br(),
column(8,leafletOutput("map", height="700px")),
column(4,br(),br(),br(),br(),plotOutput("plot1", height="300px")),
column(4,br(),br(),br(),br(),plotOutput("plot2", height="300px")),
br()
)
shinyApp(ui = ui, server = server)
It is difficult to test your code without test data but this line is incorrect:
site2 <- input$map_marker_click$id2
Each marker click updates input$map_marker_click$id - there is no id2.
If I understand your code correctly in that one marker click should show 2 line charts then changing to:
site2 <- input$map_marker_click$id
might work. If not, let me know more details and/or please give us some dummy data to work with.

R Shiny animated slider for map

I'm new to Shiny and coding. I found an example that uses a choropleth map (ichorophlet function) to show crime rates across years and US states. I'd like to replicate this map in Shiny using annual poverty rates in the US. My questions are: 1) How do get the map to load on Shiny? 2) How do I get the animation button to work? Below are the R codes I used. Any ideas how to fix this issue?
ui.R
shinyUI(fluidPage(
titlePanel("U.S. Poverty Rates"),
# Sidebar with slider that demonstrates various years
sidebarLayout(
sidebarPanel(
helpText("Create a poverty map."),
# Animation with custom interval (in ms) to control speed, plus looping
sliderInput("animation", "Press Play:", 1980, 2015, 1, step=1,
animate=animationOptions(interval=800, loop=TRUE))),
# Show map summarizing the values entered
mainPanel(
plotOutput("map")
)
)
))
server.R
# Load libraries
library(lattice)
library(plyr)
library(dplyr)
library(readxl)
library(RColorBrewer)
library(rMaps)
library(rjson)
library(rCharts)
library(shiny)
# Load data and helper files
data <- read_excel("data/hstpov21.xls", sheet = "Sheet1")
source("toJASON.R")
source("ichoropleth.R")
# Remove DC
datm <- subset(na.omit(data),
!(State %in% c("D.C.", "District of Columbia")))
# Discreticize poverty rates
datm2 <- transform(datm,
State = state.abb[match(as.character(State), state.name)],
fillKey = cut(Poverty,
quantile(Poverty, seq(0, 1, 1/5)),
labels = LETTERS[1:5]),
Year = as.numeric(substr(Year, 1, 4))
)
# Fill colors
fills = setNames(
c(RColorBrewer::brewer.pal(5, 'YlOrRd'), 'white'),
c(LETTERS[1:5], 'defaultFill')
)
# Create Payload for DataMaps
dat2 <- dlply(na.omit(datm2), "Year", function(x){
y = toJSONArray2(x, json = F)
names(y) = lapply(y, '[[', 'State')
return(y)
})
# Define server logic for slider
shinyServer(
function(input, output) {
# Reactive expression to compose a data frame containing all of the values
sliderValues <- reactive({
# Compose data frame
data.frame(
Name = c("Animation"),
Value = as.character(c(input$animation)),
stringsAsFactors=FALSE)
})
# Show the values using a chorophlet map
output$map <- renderPlot({
sliderValues()
ichoropleth(Poverty ~ State,
data = datm2[,1:3],
pal = 'PuRd',
ncuts = 5,
animate = 'Year',
play = TRUE)
})
})

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!

Resources