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)
})
}
Related
I have a map which has a series of lines with associated values, which is rendered based on a reactive dataframe, filtered by a sliderInput.
When a line is clicked, the map view is updated with new lng, lat and zoom values, based on that line. What I would like is that the view does not reset when the slider is updated. I understand that it's resetting to the values in the initial setView() because the map is rerendering when the slider is changed, but I'm unsure how I can prevent this behaviour.
In short, when a user clicks on the line, I want it to stay at that lng/lat/zoom even as the slider changes. How can I accomplish this?
Below is a simplified reproducible example, with only one line:
library(shiny)
library(leaflet)
library(tidyverse)
library(RColorBrewer)
# Example data frame
line1 <- data.frame(
lng = rep(c(13.35011, 13.21514), 4),
lat = rep(c(52.51449, 52.48042), 4),
id = rep("10351A", 8),
period = rep(c(1, 2, 3, 4), each = 2),
value = rep(c(1200, 2300, 3140, 1111), each = 2)
)
ui <- fluidPage(
sidebarPanel(
sliderInput(
inputId = "period_picker",
label = "Period",
min = 1,
max = 4,
value = 1
),
uiOutput("clicked_info")
),
mainPanel(
leafletOutput("map")
)
)
server <- function(input, output) {
# Reactive dataframe based on period_picker
dat <- reactive({
filtered <- line1 %>%
filter(period == input$period_picker)
return(filtered)
})
# Render map
output$map <- renderLeaflet({
# Create color palette based on reactive frame
pal <- colorNumeric(palette = "Purples", domain = c(0, max(line1$value)))
# Render leaflet map
leaflet(data = dat()) %>%
addTiles() %>%
setView(lng = 13.38049, lat = 52.51873, zoom = 13) %>%
addPolylines(
lng = ~lng,
lat = ~lat,
layerId = ~id,
color = ~pal(dat()$value),
opacity = 1
)
})
# Zoom in and readjust view if shape matching id is clicked - this is the
# lng/lat/zoom value I want to keep when the sliderInput is changed
observeEvent(input$map_shape_click, {
x <- input$map_shape_click
if(x$id == "10351A") {
leafletProxy(
mapId = "map",
) %>%
flyTo(
lng = 13.282625,
lat = 52.497455,
zoom = 12
)
}
# Render dataset in the UI
output$clicked_info <- renderUI({
div(
tags$span("Line ID:", dat()$id[1]),
br(),
tags$span("Period:", dat()$period[1]),
br(),
tags$span("Value:", dat()$value[1])
)
})
})
}
shinyApp(ui = ui, server = server)
You need to put the addPolylines not in the map rendering, but in another observeEvent with leafletProxy. Replace your output$map block of code by the following lines :
# Render map
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(lng = 13.38049, lat = 52.51873, zoom = 13)
})
observeEvent(dat(), {
req(dat())
pal <- colorNumeric(palette = "Purples", domain = c(0, max(line1$value)))
leafletProxy("map") %>%
addPolylines(
data = dat(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
color = ~pal(dat()$value),
opacity = 1
)
})
I'm trying to create two leaflet maps in an R shiny app that are placed in different tabpanels using the tabsetPanel() function. I would like to have a widget (e.g., sliderInput()) that controls the size of markers on both maps. I can create an app that does this but the problem is that features are not initially rendered on the map that is on the second panel on startup. Features are rendered on the second panel only after selecting the panel, then changing the input with a slider. I would like both maps to show their features on startup without having to initialize the second with a slider.
library(shiny)
library(leaflet)
pts <- data.frame(
x = rnorm(10, mean = -93.625),
y = rnorm(10, mean = 42.0285)
)
# Define UI
ui <- fluidPage(
sliderInput("radius",
"Point radius:",
min = 1,
max = 50,
value = 30),
tabsetPanel(
tabPanel('Map1',
leafletOutput('map1')
),
tabPanel('Map2',
leafletOutput('map2')
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$map1 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
output$map2 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
observe({
tab1 <- leafletProxy('map1', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
tab2 <- leafletProxy('map2', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
})
}
# Run the application
shinyApp(ui = ui, server = server)
As a simple fix, you could give your tabsetPanel an id, and put the corresponding input in your observer, so that the observer also invalidates when you change tabs. Working example is given below, I hope this helps!
library(shiny)
library(leaflet)
pts <- data.frame(
x = rnorm(10, mean = -93.625),
y = rnorm(10, mean = 42.0285)
)
# Define UI
ui <- fluidPage(
sliderInput("radius",
"Point radius:",
min = 1,
max = 50,
value = 30),
tabsetPanel(id='my_tabsetPanel',
tabPanel('Map1',
leafletOutput('map1')
),
tabPanel('Map2',
leafletOutput('map2')
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$map1 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
output$map2 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 6)
})
observe({
input$my_tabsetPanel
tab1 <- leafletProxy('map1', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
tab2 <- leafletProxy('map2', data = pts) %>%
clearMarkers() %>%
addCircleMarkers(lng = ~x, lat = ~y, radius = input$radius)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I have a shiny app, where I want to plot CircleMarkers on a leaflet map. Additionally a marker should be plotted, controlled over an overlayGroup. When the zoom level is greater than 7 the marker should be plotted otherwise not. This is done by sending code to the server and getting the index of the marker. See also here: Show layer in leaflet map in Shiny only when zoom level > 8 with LayersControl?
It works fine, but when I add the addSearchOSM plugin from leaflet.extras the CircleMarkers will not be plotted anymore when the app starts. So the observe statement will not be rendered until I change an input.
This is the code:
library(leaflet)
library(leaflet.extras)
library(shiny)
data <- data.frame(longitude = c(11.43, 11.55), latitude = c(48, 48.5), label = c("a", "b"))
getInputwithJS <- '
Shiny.addCustomMessageHandler("findInput",
function(message) {
var inputs = document.getElementsByTagName("input");
console.log(inputs);
Shiny.onInputChange("marker1", inputs[1].checked);
}
);
'
ui <- fluidPage(
sidebarPanel(
selectInput("label", "label", selected = "a", choices = data$label)
),
mainPanel(
leafletOutput("map", width = "100%", height = "700"),
tags$head(tags$script(HTML(getInputwithJS)))
)
)
server <- function(input, output, session){
# subset data according to label input
data_subset <- reactive({
data[data$label %in% input$label, ]
})
output$map <- renderLeaflet({
leaflet() %>% addTiles() %>% setView(11, 48.5, 7) %>%
addLayersControl(overlayGroups = c("marker1"),
options = layersControlOptions(collapsed = FALSE)) %>%
addSearchOSM()
})
# does not show points when app starts
observe({
leafletProxy("map") %>% clearGroup("points") %>%
addCircleMarkers(data_subset()$longitude, data_subset()$latitude, group = "points")
})
global <- reactiveValues(DOMRdy = FALSE)
autoInvalidate <- reactiveTimer(1000)
observe({
autoInvalidate()
if(global$DOMRdy){
session$sendCustomMessage(type = "findInput", message = "")
}
})
session$onFlushed(function() {
global$DOMRdy <- TRUE
})
# add marker if marker is clicked in layerscontrol and zoom level of map > 7
observe({
if (!is.null(input$marker1)){
if (input$marker1 == TRUE){
if (input$map_zoom > 7) {
leafletProxy("map") %>% addMarkers(lng = 11.2, lat = 48, group = "marker1")
}else{
leafletProxy("map") %>% clearGroup(group = "marker1")
}
}
}
})
}
shinyApp(ui, server)
I'm trying to build a shiny app that will only plot points on rows that have a value within the range of a slider bar. If I increase the range of the slider bar, points will be added, but points are never removed when I decrease the range of the slider bar. Below is a reproducible example of my problem.If you increase the slider bar to full range, 3 points will show up on the map. If you then decrease the range enough it will zoom in on one point, but if you zoom out you will see that there are still 3 points being plotted on a map. I thought the clearShapes or clearMarkers function in leaflet would remove these points, but it's not working. Any suggestions?
library(shiny)
library(leaflet)
library(tidyverse)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
radioButtons("choice","Group:",choices = c(1,2), selected = 1),
uiOutput("value"),
verbatimTextOutput("Click_text")
),
mainPanel(
leafletOutput("Map")
)
)
)
server <- function(input, output) {
df <- data.frame(lat = c(42.34,43.65,45.26,48.63,47.65,47.52),
lng = c(-96.43,-97.45,-98.56,-92.35,-94.56,-95.62),
id = c(32,45,65,76,34,12),
grp = c(1,1,1,2,2,2),
val = c(1.75,2.12,3.2,3.32,4.76,4.85))
subsetData1 <- reactive({
df %>% filter(grp == input$choice)
})
output$value <- renderUI({
sliderInput("value",label = h3("value"),
min = min(subsetData1()$val,na.rm = TRUE),
max = max(subsetData1()$val,na.rm=TRUE),
value = c(quantile(subsetData1()$val,.25,na.rm = TRUE),quantile(subsetData1()$val,.75,na.rm=TRUE)))
})
subsetData <- reactive({
df2 <- subsetData1() %>% data.frame()
df2 %>% filter(val >= min(as.numeric(input$value)) & val <= max(as.numeric(input$value)))
})
output$Map <- renderLeaflet({
leaflet(height = 1000) %>%
addTiles() %>%
fitBounds(min(df$lng),min(df$lat),max(df$lng),max(df$lat))
})
observe({
leafletProxy("Map") %>%
clearMarkers() %>%
clearShapes() %>%
addCircleMarkers(data = subsetData(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
radius = 8,
weight = 10) %>%
fitBounds(.,min(subsetData()$lng),min(subsetData()$lat),
max(subsetData()$lng),max(subsetData()$lat))
})
observe({
click<-input$Map_marker_click
if(is.null(click))
return()
text<-paste("Latitude ", click$lat, "Longtitude ", click$lng)
text2<-paste("You've selected point ", click$id)
output$Click_text<-renderText({
text2
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can change your observe function where you clear markers to an observeEvent function.
observeEvent(input$value,{
leafletProxy("Map") %>%
clearMarkers() %>%
clearShapes() %>%
addCircleMarkers(data = subsetData(),
lng = ~lng,
lat = ~lat,
layerId = ~id,
radius = 8,
weight = 10) %>%
fitBounds(.,min(subsetData()$lng),min(subsetData()$lat),
max(subsetData()$lng),max(subsetData()$lat))
})
You also have both the uiOutput and sliderInput id's as the same (value). You should make sure every element has a unique id. Rename one of them to something unique.
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.