i would like to generate colored polygons, with dynamic values based on option choosen form combo box (specific supplier name).
I used leaflet package to print polygons based on 'SpatialPolygonsDataFrame' object class. And it works fine. I have problems with using 'reactive' shiny function - is change object class from 'SpatialPolygonsDataFrame' to 'data.frame' - creatling leflet map is impossible.
Here is part of my code:
ui <- pageWithSidebar(
sidebarPanel(
# supplier selection
selectInput(inputId = "inpSuppl", label = "supplier:",
choices = sort(x=names(table(db$SUPPLIER)), decreasing=FALSE),
selected = sort(x=names(table(db$SUPPLIER)), decreasing=FALSE)[[1]]
)
),
mainPanel(leafletOutput("myMap"))
)
server <- function(input, output, session) {
myData <- reactive({
data <- data[data$SUPPLIER==input$inpSuppl, c("A_COLUMN")]
})
output$myMap <- renderLeaflet({
m <- leaflet()
m <- addTiles(m)
m <- addPolygons(map = m, data = myData(), stroke = FALSE, fillColor = ~pal(mapval))
})
}
shinyApp(ui=ui, server=server)
Any idea?
Thanks so much. I have another problem - with color palette. i would like to change number of clusters and then color polygons. When i start app everything is all right, but after i change down number of clusters in input field, number of cluster don't work proper (number of cluster don't shrink).
ui <- bootstrapPage(
leafletOutput("myMap", width = "100%", height = "100%"),
absolutePanel(top = 100, left = 10, width = "160px",
# input - supplier
selectInput(inputId = "inpSuppl", label = "supplier:",
choices = sort(x=names(table(db$SUPPLIER)), decreasing=FALSE),
selected = sort(x=names(table(db$SUPPLIER)), decreasing=FALSE)[[1]]
),
# input - variable type
selectInput(inputId = "inpVar", label = "variable:", choices = c("turnover" = "VAL_1", "basket" = "VAL_2")),
# numeric input - number of clusters
numericInput(inputId="inpClust", label="number of clusters:", value=3, step=1)
)
)
# --------------------------------------------------------------------------
server <- function(input, output, session) {
# dynamic number of clusters
clusters <- reactive({input$inpClust})
# dynamic data set - adding specific variable from db object to sh2 object
ld <- reactive({
# add aditional data to sh2 object (SpatialPolygonsDataFrame class)
# from db obejct (data.frame class)
sh2$mapval <- db[db$SUPPLIER==input$inpSuppl, c(input$inpVar)]
# create clusters
k <- kmeans(sh2$mapval, clusters())
# add clusters to sh2 object (SpatialPolygonsDataFrame class)
sh2$cluster <- k$cluster
return(sh2)
})
# create color pal
colorpal <- reactive({colorNumeric(palette="YlOrRd", ld()$cluster)})
# static map elements
output$myMap <- renderLeaflet({
m <- leaflet("myMap") # preapare leaflet object
m <- addTiles(m)
m <- addPolygons(m, data = sh0, color = "black", weight = 1, fillColor = "black") # country polygon
})
# dynamic map elements
observe({
pal <- colorpal()
leafletProxy("myMap", data = ld()) %>%
addPolygons(stroke = FALSE, fillColor = ~pal(cluster), fillOpacity=0.6, popup = ~paste(mapval)) # powiats polygons
})
}
ui <- pageWithSidebar(
sidebarPanel(
# supplier selection
selectInput(inputId = "inpSuppl", label = "supplier:",
choices = sort(x=names(table(db$SUPPLIER)), decreasing=FALSE),
selected = sort(x=names(table(db$SUPPLIER)), decreasing=FALSE)[[1]]
)
),
mainPanel(leafletOutput("myMap"))
)
server <- function(input, output, session) {
myData <- reactive({
data <- data[data$SUPPLIER==input$inpSuppl, c("A_COLUMN")]
data
})
output$myMap <- renderLeaflet({
m <- leaflet()
m <- addTiles(m)
m <- addPolygons(map = m, data = myData(), stroke = FALSE, fillColor = ~pal(mapval))
})
}
shinyApp(ui=ui, server=server)
Per the comments above.
Related
I am struggling with getting the code to work for this log widget I want to add to my interactive plot in shiny. I am able to modify the graphs x and y axis to a log scale by adding log(dat()[[input$yvrbl]]) to the server coder
server <- function(input, output) {
x <- reactive({
log(dat()[[input$yvrbl]])
})
y <- reactive({
log(dat()[[input$yvrbl]])
})
I was able to create the widgets on the ui code as well. I am still unable to transform the data to the log version based on whether or not the widget is checked. I tried making a separate reactive expression to host the changed log version of the x and y axis depending on an if statement. Please let me know what else I can do.
library(shiny)
library(plotly)
library(tibble)
library(tidyverse)
library(tidyr)
library(readr)
library(dplyr)
library(ggplot2)
# set working directory
setwd("~/BDSWD")
#read data
gm <- read_csv("gapminder_clean.csv")
# Define UI ----
ui <- fluidPage(
column(3,offset = 4, titlePanel("Explore Gapminder Data with Shiny")),
headerPanel('Graphs'),
mainPanel(
plotlyOutput('plot')
),
sidebarPanel(
#variable selection for x-axis
selectInput(inputId ='xvrbl', #The input slot that will be used to access the value.
label = 'X-Axis Variable', #Display label for the control, or NULL for no label.
choices = colnames(gm), #List of values to select from
selected = 'CO2 emissions (metric tons per capita)'
),
checkboxInput(inputId = "LogX",
label = "Log Transform",
value = FALSE),
#variable selection for y-axis
selectInput(inputId ='yvrbl', #The input slot that will be used to access the value.
label = 'Y-Axis Variable', #Display label for the control, or NULL for no label.
choices = colnames(gm), #List of values to select from
selected = 'gdpPercap'
),
checkboxInput(inputId = "LogY",
label = "Log Transform",
value = FALSE),
#date range - slider
sliderInput(inputId = "time",
label = "Years",
min = min(gm$Year),
max = max(gm$Year),
step = 5,
value = c(min(gm$Year),max(gm$Year)))
)
)
server <- function(input, output) {
x <- reactive({
dat()[[input$xvrbl]]
})
y <- reactive({
dat()[[input$yvrbl]]
})
dat <- reactive({
subset(gm, Year %in% input$time)
})
lgrthmc <- reactive({
if(isTRUE(input$LogY)) {
y <- reactive({
log(dat()[[input$yvrbl]])
})
} else {}
if(isTRUE(input$LogX)) {
x <- reactive({
log(dat()[[input$xvrbl]])
})
} else {}
})
output$plot <- renderPlotly({
plot_ly(
x = x(),
y = y(),
type = "scatter",
mode = "markers",
color = dat()$continent
) %>%
layout(
title = 'Gapminder Dataset',
plot_bgcolor = "#e5ecf6",
xaxis = list(title = input$xvrbl),
yaxis = list(title = input$yvrbl),
legend = list(title=list(text='<b> Continent </b>'))
)
})
}
# Run the app
shinyApp(ui = ui, server = server)
Instead of wrapping reactives inside a reactive you could achieve your desired result by adding an if inside your reactives, e.g.
Note: I slightly adjusted the subsetting of your data to take the sliderInput into account.
x <- reactive({
x <- dat()[[input$xvrbl]]
if (input$LogX) x <- log(x)
return(x)
})
library(gapminder)
library(shiny)
library(plotly)
library(tidyverse)
gm <- gapminder |> rename(Year = year)
# Define UI ----
ui <- fluidPage(
column(3, offset = 4, titlePanel("Explore Gapminder Data with Shiny")),
headerPanel("Graphs"),
mainPanel(
plotlyOutput("plot")
),
sidebarPanel(
# variable selection for x-axis
selectInput(
inputId = "xvrbl", # The input slot that will be used to access the value.
label = "X-Axis Variable", # Display label for the control, or NULL for no label.
choices = colnames(gm), # List of values to select from
selected = "lifeExp"
),
checkboxInput(inputId = "LogX",
label = "Log Transform",
value = FALSE),
# variable selection for y-axis
selectInput(
inputId = "yvrbl", # The input slot that will be used to access the value.
label = "Y-Axis Variable", # Display label for the control, or NULL for no label.
choices = colnames(gm), # List of values to select from
selected = "gdpPercap"
),
checkboxInput(
inputId = "LogY",
label = "Log Transform",
value = FALSE
),
# date range - slider
sliderInput(
inputId = "time",
label = "Years",
min = min(gm$Year),
max = max(gm$Year),
step = 5,
value = range(gm$Year)
)
)
)
server <- function(input, output) {
x <- reactive({
x <- dat()[[input$xvrbl]]
if (input$LogX) x <- log(x)
return(x)
})
y <- reactive({
y <- dat()[[input$yvrbl]]
if (input$LogY) y <- log(y)
return(y)
})
dat <- reactive({
subset(gm, Year >= input$time[[1]], Year <= input$time[[2]])
})
output$plot <- renderPlotly({
plot_ly(
x = x(),
y = y(),
type = "scatter",
mode = "markers",
color = dat()$continent
)
})
}
# Run the app
shinyApp(ui = ui, server = server)
#>
#> Listening on http://127.0.0.1:6593
I have a dataframe:
df1<-data.frame(a=rnorm(100),b=rnorm(100),c=rnorm(100),ID1=c("A","B"),ID2=(c("A","B","C","D")))
I am drawing a 3d plot with plotly by adding add_trace in a loop, like:
library(shiny)
library(plotly)
library(tidyverse)
df1<-data.frame(a=rnorm(100),b=rnorm(100),c=rnorm(100),ID1=c("A","B"),ID2=(c("A","B","C","D")))
test<-unique(df1$ID2)
tempt.col<-c("red","blue","green","yellow")
p<-plot_ly()
for(i in 1:length(test)){
df2<-df1[df1$ID2==test[i],] %>%
select(a,b,c)
p<-add_trace(p=p,
data = df2,
x=~a,y=~b,z=~c,
type="scatter3d",
marker = list(size=5,color=tempt.col[i]),
mode="markers"
)
}
p
It works very well like:
Now I want to achieve this in shiny, I would like to generate colourInput based on the length of the selected ID, the ui:
ui<-fluidPage(
fluidRow(
sidebarPanel(
selectInput("select1","Select the ID",choices = colnames(df1[,4:5]),multiple = FALSE),
actionButton("act1","Go"),
uiOutput("ui1"),
),
mainPanel(
tableOutput("table1"),
plotlyOutput("plot.3d",height = "1000px")
)
)
)
server:
server<-function(input,output){
tempt.group<-reactive({
unique(df1[,input$select1])
})
observeEvent(input$act1,{
tempt.vector<-list()
tempt.col.name<-isolate(
vector(mode = "list",length = 2)
)
for(i in 1:length(tempt.group())){
tempt.vector[[i]]<-colourpicker::colourInput(
inputId = paste0("ColorID",i),
label = tempt.group()[i])
tempt.col.name[[1]][i]<-paste0("ColorID",i)
tempt.col.name[[2]][i]<-tempt.group()[i]
}
output$ui1<-renderUI({
tempt.vector
})
names(tempt.col.name)<-c("inputId","label")
col.name<-reactive({
data.frame(sapply(tempt.col.name,cbind))
})
col.df<-reactive({
tempt.col.df<-reactiveValuesToList(input)
data.frame(
names = names(tempt.col.df[grepl("ColorID", names(tempt.col.df))]),
values = unlist(tempt.col.df[grepl("ColorID", names(tempt.col.df))], use.names = FALSE)
)
})
group.col.df<-reactive({
merge(col.df(),col.name(),by.x="names",by.y="inputId")
})
output$table1<-renderTable(
group.col.df()
)
pp<-reactive({
p<-plot_ly()
for(i in 1:length(tempt.group())){
# col<-group.col.df()[group.col.df()[,"label"]==tempt.group()[i],"values"] ####it should be something wrong with here
df2<-df1[df1$ID==tempt.group()[i],] %>%
select(a,b,c)
p<-add_trace(p=p,
data = df2,
x=~a,y=~b,z=~c,
type="scatter3d",
# marker = list(size=5,color=col[i]), ####it should be something wrong with here
mode="markers"
)
}
p
})
output$plot.3d<-renderPlotly({
pp()
})
})
}
shinyApp(ui=ui,server=server)
The app is like:
I want to fetch the colourInput and pass to the color of the 3d scatter plot, but nothing works. The page either keeps refreshing or frozen,
That must be something wrong with col<-group.col.df()[group.col.df()[,"label"]==tempt.group()[i],"values"] and marker = list(size=5,color=col[i]),
please help.
The below works as intended.
library(shiny)
library(plotly)
df1<-data.frame(a=rnorm(100),b=rnorm(100),c=rnorm(100),ID1=c("A","B"),ID2=(c("A","B","C","D")))
# Define UI
ui<-fluidPage(
fluidRow(
sidebarPanel(
selectInput("select1","Select the ID",choices = colnames(df1[,4:5]),multiple = FALSE),
# actionButton("act1","Go"),
uiOutput("myui"),
# keep track of the last selection on all selectInput created dynamically
),
mainPanel(
#tableOutput("table1"),
plotlyOutput("plot.3d",height = "1000px")
)
)
)
# Define server logic required to draw a histogram
server<-function(input,output){
rv <- reactiveValues(mygroup=0, uitaglist = list(), uilabels = list(), input_subset = list(), plotly=NULL)
observeEvent(input$select1, {
newgroup <- unique(df1[,input$select1])
rv$mygroup <- newgroup
# ui tags
rv$uitaglist <- list()
for(i in 1:length(rv$mygroup)){
rv$uitaglist[[i]]<-colourpicker::colourInput(
inputId = paste0("ColorID",i),
label = rv$mygroup[i])
rv$uilabels[[i]] <- paste0("ColorID",i)
}
})
output$myui <- renderUI({
rv$input_subset <- rv$uitaglist
})
observe({
rv$input_subset <- lapply(rv$uilabels, function(x) input[[x]])
p<-plot_ly()
for(i in 1:length(rv$mygroup)) {
df2<-df1[df1$ID2 == rv$mygroup[i],] %>% select(a,b,c)
p<-add_trace(p=p,
data = df2,
x=~a,y=~b,z=~c,
type="scatter3d",
marker = list(size=5,color=rv$input_subset[[i]]),
mode="markers"
)
}
rv$plotly <- p
})
output$plot.3d<-renderPlotly({
rv$plotly
})
} # end server
# Run the application
shinyApp(ui = ui, server = server)
The main difficulty was to observe all your dynamically-generated UI inputs at once. Turns out it could be done using observe and lapply.
Observing several inputs is problematic because the error Must use single string to index into reactivevalues is returned by trying to index input by a vector or list.
Now, Why this can't be done out-of-the-box is a good question.
I'm attempting to make a filtered scatter plot in shiny and am nearly ready to integrate it into my main project, however, whenever the selection changes the filter-dependent selections reset to their default settings.
For context my example uses the Iris data set, displaying each petal width as selectable to plot and allowing you to look at the petal length associated with those widths independently. The problem is whenever I change what pedal width is selected petal length resets to its default.
I think that this could result in an error where I'm looking for a length that isn't a valid option with my example data however for my project use case this would be extremely helpful.
Attached is my code in its current state.
library(shinydashboard)
library(shinyWidgets)
library(plotly)
library(shiny)
#______________________________________________________________________________#
server <- function(input, output, session) {
df <- reactive({
subset(iris, Petal.Width %in% input$Petalw)
})
# Extract list of Petal Lengths from selected data - to be used as a filter
p.lengths <- reactive({
unique(df()$Petal.Length)
})
# Filter based on Petal Length
output$PetalL <- renderUI({
pickerInput("PetalLengthSelector", "PetalLength", as.list(p.lengths()), as.list(p.lengths()), options = list(`actions-box` = TRUE),multiple = T)
})
# Subset this data based on the values selected by user
df_1 <- reactive({
foo <- subset(df(), Petal.Length %in% input$PetalLengthSelector)
return(foo)
})
#output table
output$table <- DT::renderDataTable(
DT::datatable(df_1(), options = list(searching = FALSE,pageLength = 25))
)
#output scatter plot
output$correlation_plot <- renderPlotly({
fig <- plot_ly(
data = df_1(),
x = ~Sepal.Length,
y = ~Sepal.Width,
type = 'scatter',
mode = 'markers',
#mode ="lines+markers",
color =~Petal.Length,
text = ~paste("Sepal.Length:",Sepal.Length,"<br>",
"Sepal.Width:",Sepal.Width,"<br>",
"Petal.Length:",Petal.Length,"<br>",
"Petal.Width:",Petal.Width,"<br>",
"Species:",Species),
hoverinfo = 'text'
)
})
}
#______________________________________________________________________________#
ui <- navbarPage(
title = 'Select values in two columns based on two inputs respectively',
fluidRow(
column(width = 12,
plotlyOutput('correlation_plot')
)
),
fluidRow(
column(width = 6,
pickerInput("Petalw","PetalWidth", choices = unique(iris$Petal.Width),selected = unique(iris$Petal.Width), options = list(`actions-box` = TRUE),multiple = T)
),
column(width = 6,
uiOutput("PetalL")
)
),
fluidRow(
column(12,
tabPanel('Table', DT::dataTableOutput('table'))
)
)
)
shinyApp(ui, server)
I would define df dataframe as a eventReactive object with a new actionButton. This way it only updates when you click on the actionButton. Then you can avoid updating the second pickerInput while still selecting items in the first pickerInput. Try this
library(shinydashboard)
library(shinyWidgets)
library(tidyverse)
library(plotly)
library(shiny)
library(DT)
#______________________________________________________________________________#
server <- function(input, output, session) {
df <- eventReactive(input$update, {
req(input$Petalw)
subset(iris, Petal.Width %in% input$Petalw)
})
# Extract list of Petal Lengths from selected data - to be used as a filter
p.lengths <- reactive({
req(df())
unique(df()$Petal.Length)
})
# Filter based on Petal Length
output$PetalL <- renderUI({
req(p.lengths())
pickerInput("PetalLengthSelector", "PetalLength",
choices = as.list(p.lengths()),
selected = as.list(p.lengths()),
options = list(`actions-box` = TRUE),multiple = T)
})
# Subset this data based on the values selected by user
df_1 <- reactive({
req(df(),input$PetalLengthSelector)
foo <- subset(df(), Petal.Length %in% input$PetalLengthSelector)
return(foo)
})
output$table <- DT::renderDataTable(
DT::datatable(df_1(), options = list(searching = FALSE,pageLength = 25))
)
### this works
# output$correlation_plot <- renderPlotly({
# req(df_1())
# text = paste("Sepal.Length:",df_1()$Sepal.Length,"<br>",
# "Sepal.Width:", df_1()$Sepal.Width,"<br>",
# "Petal.Length:",df_1()$Petal.Length,"<br>",
# "Petal.Width:", df_1()$Petal.Width,"<br>",
# "Species:",df_1()$Species)
# plot1 <- plot_ly(data=df_1(),
# x = ~Petal.Length,
# y = ~Petal.Width,
# type = 'scatter',
# mode = "markers",
# color =~Petal.Length,
# text = text,
# hoverinfo = 'text'
#
# )
# })
output$correlation_plot <- renderPlotly({
fig <- plot_ly(
data = df_1(),
x = ~Sepal.Length,
y = ~Sepal.Width,
type = 'scatter',
mode = 'markers',
color =~Petal.Length,
text = ~paste("Sepal.Length:",Sepal.Length,"<br>",
"Sepal.Width:",Sepal.Width,"<br>",
"Petal.Length:",Petal.Length,"<br>",
"Petal.Width:",Petal.Width,"<br>",
"Species:",Species),
hoverinfo = 'text'
)
})
}
#______________________________________________________________________________#
ui <- navbarPage(
title = 'Select values in two columns based on two inputs respectively',
fluidRow(
column(width = 12,
plotlyOutput('correlation_plot')
)
),
fluidRow(
column(width = 3,
pickerInput("Petalw","PetalWidth", choices = unique(iris$Petal.Width),selected = c("PetalWidth"), options = list(`actions-box` = TRUE),multiple = T)
),
column(2, actionBttn("update","Update")), column(2,""),
column(width = 5,
uiOutput("PetalL")
)
),
tags$style(type='text/css', "#update { width:100%; margin-top: 25px;}"), ### aligning action button with pickerInput
fluidRow(
column(12,
tabPanel('Table', DT::dataTableOutput('table'))
)
)
)
shinyApp(ui, server)
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)
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)