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)
Related
I have an app with a map, dropdown, calendar and line plot (my real app is much bigger but I have simplified as much as I can). The problem with it is that when I modify any of the uicontrol features, the data loading and plotting routines run twice (as evidenced from the print statements). In the full app the plots display a reasonable amount of data so running them twice leads to poor performance.
The app is structured so that I can select 1 of 2 predefined points on the map and it will change the dropdown and graph. A new location can also be selected with the dropdown menu (which in turn updates the map). There is also a checkbox to lock the timeframe and when this is not selected the timeframe gets reset to the extents of the timeseries for the new location.
I have isolated the problem to the updateDateRangeInput that is called in the server.R file (line 35). I can comment this out and the problem goes away, but then I lose the functionality to reset the calendar to the new timeframe. Does anyone know how I can keep that functionality but stop the data loading and plotting code from running twice?
Example app below:
app.R
library(shiny)
library(rsconnect)
source('ui.R')
source('server.R')
ui <- ui_page()
server <- server_page(input, output, session)
shinyApp(ui=ui, server=server)
ui.R
library(shiny)
library(leaflet)
library(dygraphs)
inc_level <- 5
ui_page <- function(){
fluidPage(
titlePanel("TEST APP"),
sidebarLayout(
sidebarPanel(
leafletOutput('region_map'),
selectInput(inputId = "Site",label = "Pick a site",choices = c("A","B"), selected = "A"),
fluidRow(
column(6,
dateRangeInput(inputId = "timeframe",label="Select time range", start ="2015-07-01", end = "2016-07-01")),
column(4,checkboxInput(inputId = "lock_timeframe",label = "Lock Time Range"))
)
),
mainPanel(
tabsetPanel(
tabPanel("Plot 1", dygraphOutput(outputId = "plot1"))
)
)
)
)
}
server.R
library(shiny)
library(ggplot2)
library(dygraphs)
library(xts)
server_page <- function(input, output, session){
# Create Data -------------------------------------------------------------
Y1 <- c(21000, 23400, 26800)
Time1 <- startdate <- as.Date(c('2007-11-1','2008-3-25','2010-3-14'))
Y2 <- c(11000, 11400, 16800)
Time2 <- startdate <- as.Date(c('2001-11-1','2003-3-25','2005-3-14'))
Lat <-c(-39.095980, -39.605823)
Lon <- c(173.887903, 173.824561)
Site <- c("A","B")
# Extract Data -------------------------------------------------------
df1 <- reactive({
print("load data")
if (input$Site=="A"){
df1 <- data.frame(Time1, Y1)
}
else if (input$Site=="B"){
df1 <- data.frame(Time2, Y2)
}
names(df1) <- c("Time","Y")
if (1){ # IF YOU CHANGE THIS TO A 0 FUNCTIONLITY IS LOST BUT PROBLEM GOES AWAY
lockTest <- input$lock_timeframe
if (lockTest==FALSE){
updateDateRangeInput(session, "timeframe",
start = df1$Time[1],
end =df1$Time[length(df1$Time)])
}
}
df1 <- df1[df1$Time >= format(input$timeframe[1]) & df1$Time <= format(input$timeframe[2]),]
validate(need(nrow(df1)!=0, "No Data In Range"))
return(df1)
}) #%>% bindCache(input$Site) # I woudl like to cache based on location to stop reloading of data from file in the full app
# Line Plot --------------------------------------------------------
output$plot1 <- renderDygraph({
print("Plotting")
data <- df1()
data <- xts(x = data$Y, order.by = data$Time)
dyPlt <- dygraph(data,width = 800, height = 400)
})
# Plot Map -----------------------------------------------------
output$region_map <- renderLeaflet({
y <- Lat
x <- Lon
id <- Site
leaflet() %>%
addProviderTiles(providers$OpenStreetMap, options = providerTileOptions(noWrap = TRUE)) %>%
setView(lng = 174.051515, lat = -39.301619, zoom = 8) %>%
addCircleMarkers(lng = x, lat = y ,color="green", radius = 2, layerId = id, label = id,
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "green","border-color" = "rgba(0,0,0,0.5)"))
)
})
# Map Click Behaviour -----------------------------------------------------
#When map is clicked: update map and change dropdown value
observeEvent(input$region_map_marker_click, {
event <- input$region_map_marker_click
updateSelectInput(session,
inputId = "Site",
label = "Pick a site",
choices = Site,
selected = event$id)
})
# Update map when a new site is selected from the dropdown
observeEvent(input$Site, {
update_markers()
})
# Function to redraw markers and highlight the selected location
update_markers <- function(){
y <- Lat
x <- Lon
id <- Site
sitInd <- id == input$Site
leafletProxy("region_map") %>% clearMarkers() %>% addCircleMarkers(lng = x, lat = y ,color="green", radius = 2, layerId = id, label = id,
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "green","border-color" = "rgba(0,0,0,0.5)")),
options = list(zIndex = 200)) %>%
addCircleMarkers(lng = x[sitInd], lat = y[sitInd] ,color="blue", radius = 4, layerId = id[sitInd], label = id[sitInd],
labelOptions = labelOptions(noHide = F, direction = "bottom",
style = list("color" = "blue","border-color" = "rgba(0,0,0,0.5)")),
options = list(zIndex = 300) )
}
}
I would like to bind input$plotBrush to textInput and vice versa so that when I draw my x brush on my plot it set the same boundaries ([brush]$xmin and [brush]$xmax) to the related text input and when I enter my values in my textInput, it draws me a brush on my plot whith the same boundaries entered.
I wasn't able to find any solution on accessing the [brush]$xmin and [brush]$xmax variable
(problem is : updateBrushInput does'nt exist)
Here is a reproductible example :
(the text inputs are set and returns [brush]$xmin and [brush]$xmax from the brushPlot, but the filter only works in one way)
library(shiny)
library(leaflet)
library(leaflet.extras)
library(tidyverse)
library(sf)
#Create T0New data
lat <- c(49.823, 49.823, 58.478, 57.478, 45.823)
lng <- c(-10.854,-10.854,-10.854,2.021,2.02)
date_start_min <- c(123,125,135,168,149)
T0New <- data.frame(lat,lng)
ui <- fluidPage(
leafletOutput("map", height = "50vh"),
textInput("input1","Date start (from 123 to 149)",value = ""),
textInput("input2","Date end (from 123 to 149)",value = ""),
plotOutput("distribPlot", height = "47vh",
brush = brushOpts(id = "distribPlot_brush", direction = "x", resetOnNew = FALSE))
)
server <- function(input, output, session) {
observeEvent(input$distribPlot_brush, {
brush <- input$distribPlot_brush
if (!is.null(brush)) {
updateTextInput(session, "input1", value=brush$xmin)
updateTextInput(session, "input2", value=brush$xmax)
}
})
#filter data from plot sel
filteredGraphData <- reactive({
currentlyFiltered <- T0New
if(!is.null(input$distribPlot_brush)){
thisSel <- input$distribPlot_brush
currentlyFiltered <- currentlyFiltered %>%
filter(date_start_min >= thisSel$xmin, date_start_min <= thisSel$xmax)
}
return(currentlyFiltered)
})
#Output map
output$map <- renderLeaflet({
leaflet()%>%
addProviderTiles(providers$OpenTopoMap)
})
observe({
mapData <- filteredGraphData()
mapProxy <- leafletProxy("map", session = session, data = mapData)
mapProxy %>%
clearGroup('A') %>%
addCircleMarkers(
data = mapData,
lat = mapData$lat,
lng = mapData$lng,
radius = 5,
color = 'red',
stroke = F,
fillOpacity = 1,
group = 'A'
)
})
#outputPlot
output$distribPlot <- renderPlot({
distribPlot <- ggplot(T0New,aes(date_start_min)) +
geom_density(col = "#053144", fill = "#43a2ca", alpha = 0.3, adjust = 0.75)
return(distribPlot)
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
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)
})
}
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 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.