Calculate distance from clicked point on leaflet map in R Shiny - r

I am just starting with R/Shiny. In this exercise, I am trying to calculate distance from the clicked point on a leaflet map to other points in a data frame. The final output I need to get is distance from the clicked point to each of the lat-long pairs in the sample_points data frame. I am able to get reactive lat-long values of the clicked point, but not the distance measurement. Please see the below app.R code. Any suggestions are appreciated.
library(shiny)
library(shinydashboard)
library(dplyr)
library(leaflet)
library(geodist)
# Sample points
sample_lat <- c(40.1, 40.2, 40.3, 40.4, 40.5)
sample_long <- c(-89.1, -89.2, -89.3, -88.9, -88.8)
sample_points <-
data.frame(Latitude = sample_lat, Longitude = sample_long)
ui <- dashboardPage(dashboardHeader(),
dashboardSidebar(),
dashboardBody(fluidRow(
box(width = NULL,
leafletOutput("map", height = 500)),
box(width = NULL,
tableOutput("location")),
box(width = NULL,
renderDataTable("distance"))
)))
server <- function(input, output) {
# Map output
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-89.0, 40.5, zoom = 9)
})
click_values <- reactiveValues(clat = NULL,
clng = NULL)
# Click event
observeEvent(input$map_click, {
click <- input$map_click
click_values$clat <- click$lat
click_values$clng <- click$lng
leafletProxy('map') %>%
clearMarkers() %>%
addMarkers(lng = click_values$clng,
lat = click_values$clat)
})
clicked_point <-
reactive({
df = data.frame(Long = click_values$clng,
Lat = click_values$clat)
})
output$location <- renderTable({
clicked_point()
})
# Calculated distance from the clicked point
output$distance <- renderDataTable({
sample_points %>%
mutate(
dist = geodist::geodist_vec(
x1 = sample_points$Longitude,
y1 = sample_points$Latitude,
x2 = clicked_point$Long,
y2 = clicked_point$Lat,
paired = TRUE,
measure = "haversine"
)
) %>%
mutate(dist_mi = dist / 1609) %>%
select(-dist)
})
}
shinyApp(ui, server)

In ui, you should use dataTableOutput("distance"), not renderDataTable(). That is why output$distance <- renderDataTable({...}) is not being executed.
Then in output$distance you forgot to call clicked_point as a reactive. It should be clicked_point()$Long for example. And to avoid having an error display on first load, you need to check if clicked_point already has valid values.
output$distance <- renderDataTable({
if(nrow(clicked_point()) == 0)
return()
sample_points %>%
...
})
I earlier suggested using req() to check if clicked_point() contained a valid value, but req(), and isTruthy() returns TRUE for empty data.frames.

Related

Adding zip code data into shiny leaflet map in R

below is my code. I have a working map that zooms into each county when clicked on but I want the map to be shaded darker or lighter based on how many zip codes are in a certain place and the count of data in each state.
Any help would be much appreciated!
require(leaflet)
require(maps)
require(maptools)
require(sp)
require(rgeos)
zipdata=data2$LossZipCode
statedata=data2$LossStateAbbreviation
mapStates=map("state",fill=TRUE,plot=FALSE)
mapCounty=map("county",fill=TRUE,plot=FALSE)
shinyApp(
ui = fluidPage(leafletOutput('myMap'),
br(),
leafletOutput('myMap2')),
server <- function(input, output, session) {
#leafletOutput("myMap"),br(),leafletOutput("myMap2")
output$myMap=renderLeaflet({
leaflet()%>%
addProviderTiles("Stamen.TonerLite",options=providerTileOptions(noWrap=TRUE))%>%
addPolygons(lng=mapStates$x, lat=mapStates$y,fillColor=topo.colors(10,alpha=NULL),stroke=FALSE)
})
observeEvent(input$myMap_shape_click, {
click <- input$myMap_shape_click
if(is.null(click))
return()
lat <- click$lat
lon <- click$lng
coords <- as.data.frame(cbind(lon, lat))
point <- SpatialPoints(coords)
mapStates_sp <- map2SpatialPolygons(mapStates, IDs = mapStates$names)
i <- point [mapStates_sp, ]
selected <- mapStates_sp [i]
mapCounty_sp <- map2SpatialPolygons(mapCounty, IDs = mapCounty$names)
z <- over(mapCounty_sp, selected)
r <- mapCounty_sp[(!is.na(z))]
output$myMap2 <- renderLeaflet({
leaflet() %>%
addProviderTiles("Stamen.TonerLite",
options = providerTileOptions(noWrap = TRUE)) %>%
addPolygons(data=r,
fillColor = topo.colors(10, alpha = NULL),
stroke = FALSE)
})
})
})

Reactive Shiny Application

I am trying to create an interactive shiny application that displays a leaflet plot based on a user's date and plot type specification. Ideally, I would like the user to specify whether they would like to view a state-wide or a county-wide plot. Then, based on their answers, I would like them to decide whether to use the regular data or the standardized data. After this, they would hit a submit button and the plot would render. I don't want the plot to render until the user presses the "Submit" action button. This is my idea so far, but it fails whenever I try to implement.
library(ggplot2)
library(shapefiles)
library(sp)
library(CARBayes)
library(leaflet)
library(rgdal)
library(leaflet)
library(shiny)
## County Data
dta <- read.csv()
## County Data (percentage)
perc <-read.csv()
## Date Specification Function
selectdates <- function(data, start, end){
keep <- data[, 1:5]
data <- data[, -c(1:5)]
tmp1 <- as.Date(names(data))
tmp2 <- which(tmp1 >= as.Date(start) & tmp1 <= as.Date(end))
tmp <- data[, tmp2]
Sum <- rowSums(tmp)
tmp <- cbind(keep, Sum)
return(tmp)
}
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Mapping"),
tags$em(""),
tags$hr(),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
dateRangeInput("daterange", "Date Range:",
start = as.character(Sys.Date() - 6),
end = as.character(Sys.Date())),
selectInput("ptChoice", "Type of Plot:", choices = c("", "County-Wise", "State-Wise")),
selectInput("typeChoice", "Data Type:", choices = c("", "Raw", "Percentage")),
actionButton("submitButton", "Submit", class = "btn btn-primary")
),
# Display leaflet plot of cases
mainPanel(
leafletOutput("countyPlot"),
leafletOutput("statePlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
observeEvent(input$ptChoice, {
req(input$ptchoice)
if(input$ptChoice == "County-Wide"){
hide("statePlot")
show("countyPlot")
}
else{
hide("countyPlot")
show("statePlot")
}
})
fdta <- eventReactive(input$typeChoice, {
if (input$typeChoice == "Raw"){
df <- selectdates(data = tmp, start = input$daterange[1], end = input$daterange[2])
row.names(df) <- df$FIPS
}else if (input$typeChoice == "Percentage"){
df <- selectdates(data = perc, start = input$daterange[1], end = input$daterange[2])
}else {return(NULL)}
df
})
observeEvent(input$submitButton, {
output$statePlot <- renderLeaflet({
## INSERT STATE PLOT CODE HERE
})
output$countyPlot <- renderLeaflet({
## Loads SHP and DBF File
shp <- read.shp()
dbf <- read.dbf()
sp <- combine.data.shapefile(data = fdta, shp = shp, dbf = dbf)
proj4string(sp) <- CRS("+proj=longlat +datum=WGS84 +no_defs")
sp <- spTransform(sp, CRS("+proj=longlat +datum=WGS84 +no_defs"))
colours <- colorNumeric(palette = "YlOrRd", domain = sp#data$Sum)
leaflet(sp) %>%
addTiles() %>%
addPolygons(
fillColor = ~ colours(Sum),
weight = 1,
opacity = 0.7,
color = "white",
dashArray = '3',
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE
)
) %>%
addLegend(
pal = colours,
values = sp#data$Sum,
opacity = 1,
title = "Count"
) %>%
addScaleBar(position = "bottomleft")
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can put the two plots inside an observeEvent, if you want it only after someone clicks on submit button. To use the appropriate dataframe, create a reactive dataframe and then use it as dfa() to generate the appropriate plot. Try this
server = function(input, output) {
observeEvent(input$ptChoice,{
req(input$ptChoice)
if(input$ptChoice == "County-Wide"){
hide("statePlot")
show("countyPlot")
}else{
hide("countyPlot")
show("statePlot")
}
})
dfa <- eventReactive(input$typechoice, {
if (input$typechoice == "Regular") {
df <- dta
}else if (input$typechoice == "Standardized") {
df <- dta2
}else {return(NULL)}
df
})
observeEvent(input$submitButton,{
output$stateplot <- renderLeaflet({
state <- CODE FOR STATE PLOT
})
output$countyPlot <- renderLeaflet({
county <- CODE FOR COUNTY PLOT
})
})
}
You might want to have your leaflet plot be stored in reactiveValues (rv) - then, you can have one output for your plot, and show what is stored in rv.
To change the plot when the submit button is pressed, be sure to reference the input$submitButton with your observeEvent.
Here is a working example that can be adapted. You could use an additional function to generate the plots based on your input values.
library(ggplot2)
library(leaflet)
library(shiny)
ui = fluidPage(
titlePanel("Leaflet Plot"),
tags$em(""),
tags$hr(),
sidebarLayout(
sidebarPanel(
selectInput("plotChoice", "Type of Plot:", choices = c("", "Boston", "Chicago")),
actionButton("submitButton", "Submit", class = "btn btn-primary")
),
# Display leaflet plot of cases
mainPanel(
leafletOutput("leafletPlot")
)
)
)
server = function(input, output) {
rv <- reactiveValues(plot = NULL)
output$leafletPlot <- renderLeaflet({
rv$plot
})
observeEvent(input$submitButton, {
if (input$plotChoice == "Boston") {
rv$plot <- leaflet() %>% setView(lng = -71.0589, lat = 42.3601, zoom = 12) %>% addTiles()
} else {
rv$plot <- leaflet() %>% setView(lng = -87.6298, lat = 41.8781, zoom = 12) %>% addTiles()
}
})
}
shinyApp(ui = ui, server = server)

Add Moving Marker to a shiny leaflet

I am trying to visualise a random walk. Not its path, but actually see the marker moving as it wanders around. Something like this.
I have come with this workaround in which I clear all markers and add them again with the new positions at every step.
library(shiny)
library(leaflet)
df <- data.frame(latitude = 10, longitude = 0)
ui <- fluidPage(
sliderInput("time", "date", 0,
1e2,
value = 1,
step = 1,
animate = TRUE
),
leafletOutput("mymap")
)
server <- function(input, output, session) {
points <- eventReactive(input$time, {
df$latitude <- df$latitude + rnorm(1)
df$longitude <- df$longitude + rnorm(1)
df
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles()
})
observe({
leafletProxy("mymap") %>%
clearMarkers() %>%
addMarkers(data = points())
})
}
shinyApp(ui, server)
But I found a much more neat solution in this method movingMarker. I was wondering if there's a way to implement it using that javascript code.

R shiny checkboxGroup to plot data on map

I am very new to shiny, and I have a question.
I have a simple dataset with observations (Number_Total) of species (Species), in a certain location (X,Y).
I would like to generate a map, that enables you to select the species in a dropdown menu. Shiny then shows you were the species occurs on the map.
I got pretty far (for my experience), but selecting species in the menu does not do anything...
ui <- (fluidPage(titlePanel("Species Checker"),
sidebarLayout(
sidebarPanel(
selectizeInput('species', 'Choose species',
choices = df$Species, multiple = TRUE)
),
mainPanel(
leafletOutput("CountryMap",
width = 1000, height = 500))
)
))
The server side
server <- function(input, output, session){
output$CountryMap <- renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng = 10, lat = 40, zoom = 5) %>%
addCircles(lng = df$Y, lat = df$X, weight = 10,
radius =sqrt(df$Number_Total)*15000, popup = df$Species)
})
observeEvent(input$species, {
if(input$species != "")
{
leafletProxy("CountryMap") %>% clearShapes()
index = which(df$Species == input$species)
leafletProxy("CountryMap")%>% addCircles(lng = df$X[index],
lat = df$Y[index],
weight = 1,
radius =sqrt(df$Number_Total[index])*30, popup = df$Species[index])
}
})
}
And finally plot it
shinyApp(ui = ui, server = server)
I know my code is probably messy, but again, I blaim my experience =)
I did not manage to get an example dataset in here right away, so here it comes as picture
This is the result of the above code (with slightly different data)
enter image description here
Here's what you need. I think you are skilled enough to understand this but comment if you have any questions.
server <- function(input, output, session) {
# map_data <- reactive({
# req(input$species)
# df[df$Species %in% input$species, ]
# })
output$CountryMap <- renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng = 10, lat = 40, zoom = 5)
})
map_proxy <- leafletProxy("CountryMap")
observe({
md <- df[df$Species %in% input$species, ]
map_proxy %>%
addCircles(lng = md$Y, lat = md$X, weight = 10,
radius = sqrt(md$Number_Total)*15000, popup = md$Species)
})
}

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