Related
I am putting together an Shiny app to allow users to upload an area of interest (AOI), and calculate the amount of overlap with an administrative boundary (WMU). Everything is working as desired, except that my picker input options do not update. The picker input works, but I would like the choices to only include the WMU that overlap the AOI instead of all possible WMU. I can calculate the WMU ID that should populate the list, shown in the "TEST_TEXT"output below the map frame, but cannot successfully update the pickerInput. This kmz will overlap the several WMU that are loaded at the beginning of the script included below:
library(shiny)
library(sf)
library(tidyverse)
library(bcdata)
library(shinyjs)
library(leaflet)
library(mapview)
library(DT)
library(pals)
library(shinyWidgets)
library(shinymanager)
WMU_DATA <-
bcdc_get_data("wildlife-management-units") %>% st_transform(4326) %>% mutate(Total.WMU.HA =
as.numeric(st_area(.)) / 10000)
##### UI #####
ui <- fluidPage(
tags$head(tags$style(
HTML(
".shiny-notification {
height: 100px;
width: 400px;
position:fixed;
top: calc(25% - 50px);;
left: calc(50% - 200px);;
}
"
)
)),
# Application title
titlePanel("Calculate Overlap With WMU"),
# Inputs
sidebarLayout(
sidebarPanel(
width = 3,
textInput(
inputId = "AOI_NAME",
label = "AOI Name",
value = NULL
),
HTML("<br><br>"),
fileInput(
inputId = "KMZ",
label = "Choose KMZ",
multiple = FALSE,
accept = c('.kmz')
),
h3("or"),
HTML("<br><br>"),
fileInput(
inputId = "SHAPEFILE",
label = "Choose shapefile",
multiple = TRUE,
accept = c('.shp', '.dbf', '.sbn', '.sbx', '.shx', '.prj', '.xml')
),
pickerInput(
inputId = "WMU_FILTER",
label = "Filter Overlapping WMU",
choices = unique(WMU_DATA$WILDLIFE_MGMT_UNIT_ID),
selected = unique(WMU_DATA$WILDLIFE_MGMT_UNIT_ID),
multiple = TRUE,
options = list(`actions-box` = TRUE)
),
HTML("<br><br>")
),
# Display OUtputs
mainPanel(
width = 9,
leafletOutput("OVERLAP_MAP", height = 750),
h3(textOutput("TEST_TEXT")),
DTOutput("AOI_OVERLAP_TABLE")
)
)
)
######server#####
server <- function(input, output, session) {
####reactive data
AOI <-
reactive({
if (is.null(input$SHAPEFILE) & !is.null(input$KMZ)) {
st_read(unzip(input$KMZ$datapath)) %>%
st_zm(drop = T) %>%
mutate(AOI_NAME = input$AOI_NAME) %>%
st_transform(4326) %>%
select(-Name)
}
else if (!is.null(input$SHAPEFILE) & is.null(input$KMZ)) {
SHAPEFILE()
}
else{
return(NULL)
}
})
WMU_OVERLAP <- reactive({
st_filter(WMU_DATA, AOI())
})
AOI_WMU_INTERSECT <-
reactive({
st_intersection(AOI(), WMU_OVERLAP()) %>%
mutate(`HA of Overlap` = round(as.numeric(st_area(.)) / 10000, 0)) %>%
mutate(`Percent of WMU` = round(`HA of Overlap` / `Total.WMU.HA` *
100, 2))
})
observeEvent(AOI_WMU_INTERSECT
,
{
updatePickerInput(
session,
"WMU_FILTER",
choices = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID),
selected = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID)
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE)
###outputs
output$OVERLAP_MAP <-
renderLeaflet({
withProgress(message = "Calcualting Overlap", detail = "Should be done soon", {
AOI_SPATIAL <- AOI() %>% mutate(AOI_NAME = input$AOI_NAME)
WMU <-
WMU_OVERLAP() %>% filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
Overlap <-
AOI_WMU_INTERSECT() %>% filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
MAP <-
mapview(
Overlap,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
map.types = c("Esri.WorldTopoMap", "Esri.WorldImagery"),
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
))
) +
mapview(
WMU,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
lwd = 3,
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
)),
hide = TRUE
) +
mapview(AOI_SPATIAL,
label = "AOI_NAME",
col.regions = "red")
MAP#map %>%
setView(st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 1],
st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 2],
zoom = 9)
})
})
output$AOI_OVERLAP_TABLE <-
renderDT({
AOI_OVERLAP_TABLE <- AOI_WMU_INTERSECT() %>%
st_drop_geometry()
AOI_OVERLAP_TABLE
}, filter = "top", extensions = c("FixedHeader", "Buttons"),
options = list(
pageLength = 100,
fixedHeader = TRUE,
dom = "Bfrtip",
buttons = c('colvis', 'copy', 'excel', 'csv')
))
output$TEST_TEXT <-
renderText(unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID))
}
# Run the application
shinyApp(ui = ui, server = server)
Putting some req() and changing observeEvent() to observe() makes it work. Try this
######server#####
server <- function(input, output, session) {
####reactive data
AOI <-
reactive({
if (is.null(input$SHAPEFILE) & !is.null(input$KMZ)) {
st_read(unzip(input$KMZ$datapath)) %>%
st_zm(drop = T) %>%
mutate(AOI_NAME = input$AOI_NAME) %>%
st_transform(4326) %>%
select(-Name)
}
else if (!is.null(input$SHAPEFILE) & is.null(input$KMZ)) {
SHAPEFILE()
}
else{
return(NULL)
}
})
WMU_OVERLAP <- reactive({
req(AOI())
st_filter(WMU_DATA, AOI())
})
AOI_WMU_INTERSECT <-
reactive({
req(AOI(), WMU_OVERLAP())
st_intersection(AOI(), WMU_OVERLAP()) %>%
dplyr::mutate(`HA of Overlap` = round(as.numeric(st_area(.)) / 10000, 0)) %>%
dplyr::mutate(`Percent of WMU` = round(`HA of Overlap` / `Total.WMU.HA` *100, 2))
})
observe({updatePickerInput(
session,
"WMU_FILTER",
choices = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID),
selected = unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID)
)
} )#, ignoreInit = TRUE, ignoreNULL = TRUE)
###outputs
output$OVERLAP_MAP <-
renderLeaflet({
req(AOI_WMU_INTERSECT())
withProgress(message = "Calcualting Overlap", detail = "Should be done soon", {
AOI_SPATIAL <- AOI() %>% dplyr::mutate(AOI_NAME = input$AOI_NAME)
WMU <-
WMU_OVERLAP() %>% dplyr::filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
Overlap <-
AOI_WMU_INTERSECT() %>% dplyr::filter(WILDLIFE_MGMT_UNIT_ID %in% input$WMU_FILTER)
MAP <-
mapview(
Overlap,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
map.types = c("Esri.WorldTopoMap", "Esri.WorldImagery"),
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
))
) +
mapview(
WMU,
zcol = "WILDLIFE_MGMT_UNIT_ID",
alpha.regions = 0.2,
lwd = 3,
col.regions = alphabet(nlevels(
as.factor(WMU$WILDLIFE_MGMT_UNIT_ID)
)),
hide = TRUE
) +
mapview(AOI_SPATIAL,
label = "AOI_NAME",
col.regions = "red")
MAP#map %>%
setView(st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 1],
st_coordinates(st_centroid(st_as_sfc(
st_bbox(AOI_SPATIAL)
)))[, 2],
zoom = 9)
})
})
output$AOI_OVERLAP_TABLE <-
renderDT({
AOI_OVERLAP_TABLE <- AOI_WMU_INTERSECT() %>% st_drop_geometry()
AOI_OVERLAP_TABLE
}, filter = "top", extensions = c("FixedHeader", "Buttons"),
options = list(
pageLength = 100,
fixedHeader = TRUE,
dom = "Bfrtip",
buttons = c('colvis', 'copy', 'excel', 'csv')
))
output$TEST_TEXT <- renderText(unique(AOI_WMU_INTERSECT()$WILDLIFE_MGMT_UNIT_ID))
}
I am building a shiny budgeting shiny application that prompts the user to enter data such as what type of expense was spent, the amount, and a description. I would like to display a line plot in the second pannel of the application labeled "Monthly Budget" ONLY when the user has entered at least one data entry where the category is "Savings". I have tried experimenting with things such as hiding/displaying the plot whenever the condition is met, but it seems that I always get a NaN error message with this approach. Thus, I am experimenting with conditionalPanel() in hopes of accomplishing this task. I've noticed similar posts to this one, however this is the first case that I have found where conditionalPanel() deals with data that the user inputs as opposed to a given dataset. In the code below I get the following error message: "Error in: Invalid input: date_trans works with objects of class Date only".
Here is the code:
# Libraries
library(shiny)
library(ggplot2)
library(shinycssloaders)
library(colortools)
library(shinythemes)
library(DT)
library(tidyverse)
library(kableExtra)
library(formattable)
library(xts)
# Creating Contrasting Colors For Buckets
bucket_colors <- wheel("skyblue", num = 6)
# Define UI for application that draws a histogram
ui <- fluidPage(
# theme = shinytheme("spacelab"),
shinythemes::themeSelector(),
## Application Title
titlePanel("2021 Budgeting & Finances"),
tags$em("By:"),
tags$hr(),
navbarPage("", id = "Budget",
tabPanel("Data Entry",
div(class = "outer",
# Sidebar Layout
sidebarLayout(
sidebarPanel(
selectInput("Name",
label = "Name:",
choices = c("","Jack", "Jill")),
selectInput("Bucket",
label = "Item Bucket:",
choices = c("","Essential", "Non-Essential", "Savings", "Rent/Bills", "Trip", "Other")),
textInput("Item",
label = "Item Name:",
placeholder = "Ex: McDonald's"),
shinyWidgets::numericInputIcon("Amount",
"Amount:",
value = 0,
step = 0.01,
min = 0,
max = 1000000,
icon = list(icon("dollar"), NULL)),
dateInput("Date",
label = "Date",
value = Sys.Date(),
min = "2021-05-01",
max = "2022-12-31",
format = "M-d-yyyy"),
actionButton("Submit", "Submit", class = "btn btn-primary"),
downloadButton("Download", "Download")),
# Show a plot of the generated distribution
mainPanel(
tableOutput("PreviewTable")
)
)
)
),
############ THIS IS WHERE THE ERROR HAPPENS #############
tabPanel("Monthly Budget",
conditionalPanel("output.any(ReactiveDf() == 'Savings') == TRUE ",
plotOutput("SavingsPlot")
)
########### THIS IS WHERE THE ERROR HAPPENS ##############
),
tabPanel("Budget to Date",
tableOutput("YearTable")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
## SAVE DATA
# Set Up Empty DF
df <- tibble("Name" = character(),
"Date" = character(),
"Category" = character(),
"Amount" = numeric(),
"Description" = character())
# DF is made reactive so we can add new lines
ReactiveDf <- reactiveVal(value = df)
# Add inputs as new data (lines)
observeEvent(input$Submit, {
if (input$Bucket == "" | input$Amount == 0 |
is.na(input$Amount)) {
return(NULL)
}
else {
# New lines are packaged together in a DF
new_lines <- data.frame(Name = as.character(input$Name),
Date = as.character(input$Date),
Category = input$Bucket,
Amount = as.character(input$Amount),
Description = as.character(input$Item))
# change df globally
df <<- rbind(df, new_lines)
# ensure amount is numeric
df <<- df %>%
mutate("Amount" = as.numeric(Amount))
# Update reactive values
ReactiveDf(df)
#clear out original inputs now that they are written to df
updateSelectInput(session, inputId = "Name", selected = "")
updateSelectInput(session, inputId = "Bucket", selected = "")
updateNumericInput(session, inputId = "Amount", value = 0)
updateTextInput(session, inputId = "Item", value = "")
}
})
## Preview Table
observeEvent(input$Submit, {
output$PreviewTable <-
function(){
ReactiveDf()[order(ReactiveDf()$Date, decreasing = TRUE),] %>%
kable("html") %>%
kable_material(c("striped", "hover")) %>%
kable_styling("striped", full_width = TRUE) %>%
column_spec(3, color = "black", background = ifelse(ReactiveDf()[3]=="Essential", "#87CEEB", ifelse(ReactiveDf()[3] == "Non-Essential", "#EBA487", ifelse(ReactiveDf()[3] == "Savings", "#87EBA4", ifelse(ReactiveDf()[3] == "Rent/Bills", "#A487EB", ifelse(ReactiveDf()[3] == "Trip", "#CEEB87", "#EB87CE")))))) %>%
column_spec(1, color = ifelse(ReactiveDf()[1] == "Ashley", "lightpink", "lightcyan"))
}
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
output$SavingsPlot <- renderPlot({
savings <- ReactiveDf()[ReactiveDf()$Category == "Savings",]
savings <- savings[, -c(1,3,5)]
savings$Date <- as.Date(savings$Date)
savings$Amount <- as.numeric(savings$Amount)
savings <- as.xts(savings$Amount, order.by = as.Date(savings$Date))
weekly <- apply.weekly(savings,sum)
weekly_savings <- as.data.frame(weekly)
weekly_savings$names <- rownames(weekly_savings)
rownames(weekly_savings) <- NULL
colnames(weekly_savings) <- c("Amount", "Date")
Expected <- NULL
for(i in 1:dim(weekly_savings)[1]){
Expected[i] <- i * 625
}
weekly_savings$Expected <- Expected
ggplot(weekly_savings, aes(x = Date)) +
geom_line(aes(y = Expected), color = "red") +
geom_line(aes(y = Amount), color = "blue") +
ggtitle("House Downpayment Savings Over Time") +
ylab("Dollars") +
scale_x_date(date_minor_breaks = "2 day") +
scale_y_continuous(labels=scales::dollar_format())
})
})
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
# Downloadable csv of selected dataset ----
output$Download <- downloadHandler(
filename = function() {
paste("A&J Budgeting ", Sys.Date(),".csv", sep = "")
},
content = function(file) {
write.csv(ReactiveDf(), file, row.names = FALSE)
}
)
# use if df new lines have errors
observeEvent(input$start_over, {
# change df globally
df <- tibble("Name" = character(),
"Date" = character(),
"Expense Category" = character(),
"Amount" = numeric(),
"Description" = character())
# Update reactive values to empty out df
ReactiveDf(df)
})
## MONTHLY TABLE
output$MonthlyTable <- renderTable({
ReactiveDf()
})
## YEAR TO DATE TABLE
output$YearTable <- renderTable({
ReactiveDf()
})
}
# Run the application
shinyApp(ui = ui, server = server)
We can use a condition like nrow(filter(ReactiveDf(), Category == 'Savings')) > 0 as if ReactiveDf is a normal df. Also, when converting the xts object to a df the Date column was coerced to character.
app:
# Libraries
library(shiny)
library(tidyverse)
library(shinycssloaders)
library(colortools)
library(shinythemes)
library(DT)
library(tidyverse)
library(kableExtra)
library(formattable)
library(xts)
library(lubridate)
# Creating Contrasting Colors For Buckets
bucket_colors <- wheel("skyblue", num = 6)
# Define UI for application that draws a histogram
ui <- fluidPage(
# theme = shinytheme("spacelab"),
shinythemes::themeSelector(),
## Application Title
titlePanel("2021 Budgeting & Finances"),
tags$em("By:"),
tags$hr(),
navbarPage("", id = "Budget",
tabPanel("Data Entry",
div(class = "outer",
# Sidebar Layout
sidebarLayout(
sidebarPanel(
selectInput("Name",
label = "Name:",
choices = c("","Jack", "Jill")),
selectInput("Bucket",
label = "Item Bucket:",
choices = c("","Essential", "Non-Essential", "Savings", "Rent/Bills", "Trip", "Other")),
textInput("Item",
label = "Item Name:",
placeholder = "Ex: McDonald's"),
shinyWidgets::numericInputIcon("Amount",
"Amount:",
value = 0,
step = 0.01,
min = 0,
max = 1000000,
icon = list(icon("dollar"), NULL)),
dateInput("Date",
label = "Date",
value = Sys.Date(),
min = "2021-05-01",
max = "2022-12-31",
format = "M-d-yyyy"),
actionButton("Submit", "Submit", class = "btn btn-primary"),
downloadButton("Download", "Download")),
# Show a plot of the generated distribution
mainPanel(
tableOutput("PreviewTable")
)
)
)
),
tabPanel("Monthly Budget",
plotOutput("SavingsPlot")
),
tabPanel("Budget to Date",
tableOutput("YearTable")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
## SAVE DATA
# Set Up Empty DF
df <- tibble("Name" = character(),
"Date" = character(),
"Category" = character(),
"Amount" = numeric(),
"Description" = character())
# DF is made reactive so we can add new lines
ReactiveDf <- reactiveVal(value = df)
# Add inputs as new data (lines)
observeEvent(input$Submit, {
if (input$Bucket == "" | input$Amount == 0 |
is.na(input$Amount)) {
return(NULL)
}
else {
# New lines are packaged together in a DF
new_lines <- data.frame(Name = as.character(input$Name),
Date = as.character(input$Date),
Category = input$Bucket,
Amount = as.character(input$Amount),
Description = as.character(input$Item))
# change df globally
df <<- rbind(df, new_lines)
# ensure amount is numeric
df <<- df %>%
mutate("Amount" = as.numeric(Amount))
# Update reactive values
ReactiveDf(df)
#clear out original inputs now that they are written to df
updateSelectInput(session, inputId = "Name", selected = "")
updateSelectInput(session, inputId = "Bucket", selected = "")
updateNumericInput(session, inputId = "Amount", value = 0)
updateTextInput(session, inputId = "Item", value = "")
}
})
## Preview Table
observeEvent(input$Submit, {
output$PreviewTable <-
function(){
ReactiveDf()[order(ReactiveDf()$Date, decreasing = TRUE),] %>%
kable("html") %>%
kable_material(c("striped", "hover")) %>%
kable_styling("striped", full_width = TRUE) %>%
column_spec(3, color = "black", background = ifelse(ReactiveDf()[3]=="Essential", "#87CEEB", ifelse(ReactiveDf()[3] == "Non-Essential", "#EBA487", ifelse(ReactiveDf()[3] == "Savings", "#87EBA4", ifelse(ReactiveDf()[3] == "Rent/Bills", "#A487EB", ifelse(ReactiveDf()[3] == "Trip", "#CEEB87", "#EB87CE")))))) %>%
column_spec(1, color = ifelse(ReactiveDf()[1] == "Ashley", "lightpink", "lightcyan"))
}
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
if (nrow(filter(ReactiveDf(), Category == 'Savings')) > 0) {
output$SavingsPlot <- renderPlot({
savings <- filter(ReactiveDf(), Category == 'Savings')
savings$Date <- as.Date(savings$Date, format = "%Y-%m-%d")
savings$Amount <- as.numeric(savings$Amount)
savings <- as.xts(savings$Amount, order.by = savings$Date)
weekly <- apply.weekly(savings, sum)
weekly_savings <- as.data.frame(weekly)
weekly_savings$names <- rownames(weekly_savings)
rownames(weekly_savings) <- NULL
colnames(weekly_savings) <- c("Amount", "Date")
Expected <- NULL
for(i in 1:dim(weekly_savings)[1]){
Expected[i] <- i * 625
}
weekly_savings$Expected <- Expected
ggplot(weekly_savings, aes(x = ymd(Date))) +
geom_line(aes(y = Expected), color = "red") +
geom_line(aes(y = Amount), color = "blue") +
ggtitle("House Downpayment Savings Over Time") +
ylab("Dollars") +
scale_x_date(date_minor_breaks = "2 day") +
scale_y_continuous(labels=scales::dollar_format())
}) }
})
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
# Downloadable csv of selected dataset ----
output$Download <- downloadHandler(
filename = function() {
paste("A&J Budgeting ", Sys.Date(),".csv", sep = "")
},
content = function(file) {
write.csv(ReactiveDf(), file, row.names = FALSE)
}
)
# use if df new lines have errors
observeEvent(input$start_over, {
# change df globally
df <- tibble("Name" = character(),
"Date" = character(),
"Expense Category" = character(),
"Amount" = numeric(),
"Description" = character())
# Update reactive values to empty out df
ReactiveDf(df)
})
## MONTHLY TABLE
output$MonthlyTable <- renderTable({
ReactiveDf()
})
## YEAR TO DATE TABLE
output$YearTable <- renderTable({
ReactiveDf()
})
}
# Run the application
shinyApp(ui = ui, server = server)
I need to create an application where I filter multiple fields from a data frame. When the first field is filtered (using Date Range), the user then has to filter several pickerInputs before the data is displayed in a table. I'm not sure if this is the best way to create dependent filters. I cannot seem to find enough resources. I have tried the following. However, I'm not sure why I keep getting this warning::
Warning:Error in: Problem with filter() input '..1'
X Input '..1' must be of size 100 or 1, not size 0
get_data <- function(size){
longs <- seq(from=40, to =90, by = 0.01)
lats <- seq(from = 5, to= 50, by = 0.01)
LONGITUDE <- sample(longs, size, rep = TRUE)
LATITUDE <- sample(lats, size, rep = TRUE)
df <- data.frame(cbind(LONGITUDE, LATITUDE))
df$LOCATION <- sample(c("Location_A", "Location_B", "Location_C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
df$EQUIPMENT <- sample(c("Equipment_A", "Equipment_B", "Equipment_C", "Equipment_D"), size, replace = TRUE)
startTime <- as.POSIXct("2016-01-01")
endTime <- as.POSIXct("2019-01-31")
df$DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
df$WEEKDAY <- weekdays(as.Date(df$DATE))
return(df)
}
df <-get_data(100)
ui <- navbarPage(
id = "navBar",
title = "Data Exploration",
theme = shinytheme("cerulean"),
shinyjs::useShinyjs(),
selected = "Data",
tabPanel("Data",
fluidPage(
sidebarPanel(
div(id = "form",
uiOutput('timestamp'),
uiOutput('location'),
uiOutput('days_of_week'),
uiOutput('equipment_type'),
hr(),
HTML("<h3>Reset your filter settings here:</h3>"),
actionButton("resetAll", "Reset Entries"),
hr()),
mainPanel(
DT::DTOutput("datatable"))))
)
)#end the ui
server <- function(session, input, output){
filter_data <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
filter(LOCATION %in% input$location) %>%
filter(WEEKDAY %in% input$days_of_week) %>%
filter(EQUIPMENT %in% input$equipment_type)
})
output$timestamp <- renderUI({
dateRangeInput('timestamp',label = 'Date range input:',start = min(df$DATE), end = max(df$DATE))
})
output$location <- renderUI({
location <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
pull(LOCATION) %>%
as.character() %>% unique()
})
pickerInput('location', "Select Location:", choices = location(),selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
})
output$days_of_week <- renderUI({
days_of_week <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
filter(LOCATION %in% input$location) %>%
pull(WEEKDAY) %>%
as.character() %>% unique()
})
pickerInput('days_of_week', 'Choose Weekdays:', choices=days_of_week(), selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
})
output$equipment_type <- renderUI({
equipment <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
filter(LOCATION%in% input$location) %>%
filter(WEEKDAY %in% input$days_of_week) %>%
pull(EQUIPMENT) %>%
as.character() %>% unique()
})
pickerInput('equipment_type', "Choose Equipment:", choices = equipment(),selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
})
output$datatable <- DT::renderDT({
filter_data()
})
#Allow the user to reset all their inputs
observeEvent(input$resetAll, {
reset("form")
})
}
shinyApp(ui, server)
I think your warnings are due to input$timestamp being NULL the first time in your reactive expressions, before you create the dateRangeInput.
You could move your input to ui, and then use updatePickerInput when the dates change to alter your other inputs accordingly.
You might want to include two separate reaction expressions. One for filtering the data based on the date range, which will be used to update the other pickers. The second will include the other filters for location, equipment, and weekday, based on the picker selections.
See if this provides something closer to what you are looking for. I included what seemed to be the relevant packages at the top. I also adjusted your parentheses in the ui a bit.
library(shinythemes)
library(shinyWidgets)
library(shinyjs)
library(shiny)
library(dplyr)
get_data <- function(size){
longs <- seq(from=40, to =90, by = 0.01)
lats <- seq(from = 5, to= 50, by = 0.01)
LONGITUDE <- sample(longs, size, rep = TRUE)
LATITUDE <- sample(lats, size, rep = TRUE)
df <- data.frame(cbind(LONGITUDE, LATITUDE))
df$LOCATION <- sample(c("Location_A", "Location_B", "Location_C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
df$EQUIPMENT <- sample(c("Equipment_A", "Equipment_B", "Equipment_C", "Equipment_D"), size, replace = TRUE)
startTime <- as.POSIXct("2016-01-01")
endTime <- as.POSIXct("2019-01-31")
df$DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
df$WEEKDAY <- weekdays(as.Date(df$DATE))
return(df)
}
df <-get_data(100)
ui <- navbarPage(
id = "navBar",
title = "Data Exploration",
theme = shinytheme("cerulean"),
shinyjs::useShinyjs(),
selected = "Data",
tabPanel("Data",
fluidPage(
sidebarPanel(
div(id = "form",
dateRangeInput('timestamp', label = 'Date range input:', start = min(df$DATE), end = max(df$DATE)),
pickerInput('location', "Select Location:", choices = unique(df$LOCATION), options = list(`actions-box` = TRUE), multiple = T),
pickerInput('days_of_week', 'Choose Weekdays:', choices = unique(df$WEEKDAY), options = list(`actions-box` = TRUE), multiple = T),
pickerInput('equipment_type', "Choose Equipment:", choices = unique(df$EQUIPMENT), options = list(`actions-box` = TRUE), multiple = T),
hr(),
HTML("<h3>Reset your filter settings here:</h3>"),
actionButton("resetAll", "Reset Entries"),
hr())
),
mainPanel(
DT::DTOutput("datatable")))
)
)#end the ui
server <- function(session, input, output){
filter_by_dates <- reactive({
filter(df, DATE >= input$timestamp[1] & DATE <= input$timestamp[2])
})
filter_by_all <- reactive({
fd <- filter_by_dates()
if (!is.null(input$location)) {
fd <- filter(fd, LOCATION %in% input$location)
}
if (!is.null(input$days_of_week)) {
fd <- filter(fd, WEEKDAY %in% input$days_of_week)
}
if (!is.null(input$equipment_type)) {
fd <- filter(fd, EQUIPMENT %in% input$equipment_type)
}
return(fd)
})
observeEvent(input$timestamp, {
updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_dates()$LOCATION), selected = input$location)
updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = unique(filter_by_dates()$WEEKDAY), selected = input$days_of_week)
updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_dates()$EQUIPMENT), selected = input$equipment_type)
})
output$datatable <- DT::renderDT({
filter_by_all()
})
#Allow the user to reset all their inputs
observeEvent(input$resetAll, {
reset("form")
})
}
shinyApp(ui, server)
Edit (1/28/21): Based on the comment, it sounds like there is interest in updating all the input choices based on selections made.
If you substitute observeEvent with an observe, and use filter_by_all() instead of filter_by_date() in the three updatePickerInput, then all the non-date input choices will update whenever any changes are made to any input:
observe({
input$timestamp
updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_all()$LOCATION), selected = input$location)
updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = unique(filter_by_all()$WEEKDAY), selected = input$days_of_week)
updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_all()$EQUIPMENT), selected = input$equipment_type)
})
I have the shiny app below in which the user is able to select one or both dataframes and then based on the other filters to create a bar plot which will display the values of one or both dataframes. Now I have not connected it to the widgets in order to display what I want to achieve. It confuses me how to give the dataframes df1 and df2 to the plot_ly() and add_trace() functions together or one at a time.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(dplyr)
library(plotly)
shinyApp(
ui = dashboardPagePlus(
header = dashboardHeaderPlus(title = "Social Media Metrics", titleWidth = 320
),
sidebar = dashboardSidebar(width = 320,
checkboxGroupInput("checkGroup", label = "Select Dataset",
choices = list("df1", "df2"),
selected = "df1"),
checkboxGroupInput("checkGroup2", label = "Select Social Network",
choices = list("FACEBOOK", "INSTAGRAM"),
selected = "FACEBOOK"),
radioButtons("radio", label = "Choose type of values",
choices = list("Absolute", "Percentages" ),
selected = "Absolute"),
uiOutput("x30"),
uiOutput("x16"),
uiOutput("value")
),
body = dashboardBody(
plotlyOutput("plot")
)
),
server = function(input, output) {
page<-c("ONE","TWO","THREE")
network<-c("INSTAGRAM","FACEBOOK","FACEBOOK")
av<-c(3.5,7.2,8.7)
growth<-c(5,7,9)
av2<-c(3.5,7.2,8.7)
growth2<-c(5,7,9)
df1<-data.frame(page,network,av,growth,av2,growth2)
page<-c("ONE","TWO","THREE")
network<-c("INSTAGRAM","FACEBOOK","FACEBOOK")
av<-c(4.5,7.9,8.7)
growth<-c(5,6,9)
av2<-c(3.5,9.2,8.7)
growth2<-c(5,43,9)
df2<-data.frame(page,network,av,growth,av2,growth2)
output$x30<-renderUI({
if("df1" %in% input$checkGroup){
new<-subset(df1, network %in% input$checkGroup2)
pickerInput(
inputId = "x3"#The colname of selected column
,
label = "Select Profile-df1" #The colname of selected column
,
choices = as.character(new$page)#all rows of selected column
,
multiple = TRUE,options = list(`actions-box` = TRUE)
)
}
else{
return(NULL)
}
})
output$x16<-renderUI({
if("df2" %in% input$checkGroup){
new<-subset(df2, network %in% input$checkGroup2)
pickerInput(
inputId = "x6"#The colname of selected column
,
label = "Select Profile-df2" #The colname of selected column
,
choices = as.character(new$page)#all rows of selected column
,
multiple = TRUE,options = list(`actions-box` = TRUE)
)
}
else{
return(NULL)
}
})
output$value<-renderUI({
if(input$radio=="Absolute"){
pickerInput(
inputId = "val"
,
label = "Select Absolut Value"
,
choices = c("growth","growth2")#all rows of selected column
,
multiple = F,options = list(`actions-box` = TRUE)
)
}
else{
pickerInput(
inputId = "val"
,
label = "Select Percentage Value"
,
choices = c("av","av2")#all rows of selected column
,
multiple = F,options = list(`actions-box` = TRUE)
)
}
})
output$plot<-renderPlotly({
fig <- plot_ly(df1, x = ~page, y = ~growth, type = 'bar', name = 'growth')
fig <- fig %>% add_trace(df2,y = ~growth, name = 'growth')
fig <- fig %>% layout(yaxis = list(title = 'Count'), barmode = 'group')
fig
})
}
)
A reactive dataframe dfa() gives the selected data from either or both dataframes. Now, plotly requires some work. Please note that working with variables within dfa() gives some errors as both df1 and df2 are defined within the server and are available in output$plot, and hence, you may need to use dfa()$id, etc.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(dplyr)
library(plotly)
shinyApp(
ui = dashboardPagePlus(
header = dashboardHeaderPlus(title = "Social Media Metrics", titleWidth = 320
),
sidebar = dashboardSidebar(width = 320,
checkboxGroupInput("checkGroup", label = "Select Dataset",
choices = list("df1", "df2"),
selected = "df1"),
checkboxGroupInput("checkGroup2", label = "Select Social Network",
choices = list("FACEBOOK", "INSTAGRAM"),
selected = "FACEBOOK"),
radioButtons("radio", label = "Choose type of values",
choices = list("Absolute", "Percentages" ),
selected = "Absolute"),
uiOutput("x30"),
uiOutput("x16"),
uiOutput("value")
),
body = dashboardBody(
plotlyOutput("plot") , DTOutput("tb1")
)
),
server = function(input, output) {
page<-c("ONE","TWO","THREE")
network<-c("INSTAGRAM","FACEBOOK","FACEBOOK")
av<-c(3.5,4.2,8.7)
growth<-c(4,7,9)
av2<-c(3.5,7.2,4.7)
growth2<-c(4,7,9)
id <- rep("df1",3)
df1<-data.frame(page,network,av,growth,av2,growth2,id)
page<-c("ONE","TWO","THREE")
network<-c("INSTAGRAM","FACEBOOK","FACEBOOK")
av<-c(4.5,7.9,8.7)
growth<-c(5,4,8)
av2<-c(3.5,9.2,6.7)
growth2<-c(5,4,9)
id <- rep("df2",3)
df2<-data.frame(page,network,av,growth,av2,growth2,id)
output$x30<-renderUI({
if (is.null(input$checkGroup)) {
return(NULL)
}else if("df1" %in% input$checkGroup){
new<-subset(df1, network %in% input$checkGroup2)
pickerInput(
inputId = "x3" #The rownames of selected column
,
label = "Select Profile-df1" #The colname of selected column
,
choices = as.character(new$page) #all rows of selected column
,
multiple = TRUE,options = list(`actions-box` = TRUE)
)
}
else{
return(NULL)
}
})
output$x16<-renderUI({
if (is.null(input$checkGroup)) {
return(NULL)
}else if( "df2" %in% input$checkGroup){
new2<-subset(df2, network %in% input$checkGroup2)
pickerInput(
inputId = "x6" #The rownames of selected column
,
label = "Select Profile-df2" #The colname of selected column
,
choices = as.character(new2$page) #all rows of selected column
,
multiple = TRUE,options = list(`actions-box` = TRUE)
)
}
else{
return(NULL)
}
})
output$value<-renderUI({
if(req(input$radio)=="Absolute"){
pickerInput(
inputId = "val"
,
label = "Select Absolut Value"
,
choices = c("growth","growth2") #all rows of selected column
,
multiple = F, options = list(`actions-box` = TRUE)
)
}else if(req(input$radio)=="Percentages"){
pickerInput(
inputId = "val"
,
label = "Select Percentage Value"
,
choices = c("av","av2")#all rows of selected column
,
multiple = F,options = list(`actions-box` = TRUE)
)
} else {return(NUL)}
})
dfa <- reactive({
req(input$val)
if (is.null(input$checkGroup)) {return(NULL)}
if (input$checkGroup == "df1" | length(input$checkGroup) == 2){
df11 <- df1 %>% filter(page %in% req(input$x3) & network %in% req(input$checkGroup2))
}else df11 <- NULL
if (input$checkGroup == "df2" | length(input$checkGroup) == 2){
df22 <- df2 %>% filter(page %in% req(input$x6) & network %in% req(input$checkGroup2))
}else df22 <- NULL
if (is.null(df11) & is.null(df22)) {return(NULL)
}else {
if (is.null(df11)){df <- df22
}else if (is.null(df22)){df <- df11
}else { df <- rbind(df11,df22) }
df <- df %>% transform(y=df[[as.name(input$val)]], x=page)
}
df
})
output$tb1 <- renderDT(dfa())
output$plot<-renderPlotly({
if (is.null(dfa())) return(NULL)
xvar <- unique(dfa()$page)
xform <- list(categoryorder = "array",
categoryarray = xvar) ## to get the bars in the order you wish to display
fig <- plot_ly()
fig <- fig %>% add_trace( dfa() , x = ~x, y = ~y, type='bar', name='growth', fill=x, color=dfa()$id)
fig <- fig %>% layout(xaxis = list(xform, title="Page"),
yaxis = list(title = 'Count'), barmode = 'group')
fig
})
}
)
I am building a Shiny app which generate a dataframe from a database through the specific function my_function.
I want to use an eventReactive() to attribute the result of my_function depending on different inputs. My problem is that there are 2 ways to select these inputs which are structured in 2 different panels (I need this structure), so I have 2 actionButton that allow me to run my_function, and 1 variable for each eventReactive. Is there a way to put them in only 1 variable ?
df_all is a dataframe with several columns like "VAR1", "YEAR", "TYPE", "AGE" ... I need to filter depending on the inputs.
For the moment I have tried :
library(shiny)
library(shinydashboard)
library(DT)
library(dplyr)
df_all <- data.frame(
VAR1 = c(rep("A", 2), "B", "C")
YEAR = (rep(2001, 3), 2002)
TYPE = c("t1", "t2", "t2", "t1")
)
my_function <- function(arg1, arg2, arg3)
{
df = data.frame(
v1 = paste(arg1, arg2)
v2 = arg3
)
return(df)
}
shinyUI(dashboardPage(
dashboardHeader("title"),
dashboardSidebar(
sidebarMenu(id = "menu",
menuItem("Item1", tabName = "item1")
)),
dashboardBody(
tabItems(
tabItem(tabName = "item1",
selectInput(inputId = "var1", label = NULL, choices = c("A", "B", "C")),
tabsetPanel(
tabPanel("Item1-Panel1",
uiOutput("ui_year1"),
uiOutput("ui_type1"),
div(actionButton(inputId = "extra1", label = "Run", icon = icon("play")))),
tabPanel("Item1-Panel2",
uiOutput("ui_year2"),
uiOutput("ui_type2"),
div(actionButton(inputId = "extra2", label = "Run", icon = icon("play")))),
tabPanel("Item1-Panel3",
DT::dataTableOutput("tableau_ext1"),
DT::dataTableOutput("tableau_ext2"),
downloadButton("downloadCSV", "Save (CSV)"))
))))))
shinyServer(function(input, output) {
output$ui_year1 <- renderUI({
checkboxGroupInput(inputId = "year1", label = NULL, choices = df_all %>% filter(CULTURE == input$var1) %>% select(YEAR) %>% distinct() %>% pull()
})
output$ui_type1 <- renderUI({
checkboxGroupInput(inputId = "type1", label = NULL, choices = sort(df_all %>% filter(VAR1 == input$cult, YEAR %in% input$year1) %>% select(TYPE) %>% distinct() %>% pull())
})
output$ui_year2 <- renderUI({
checkboxGroupInput(inputId = "year2", label = NULL, choices = df_all %>% filter(VAR1 == input$var1) %>% select(YEAR) %>% distinct() %>% pull()
})
output$ui_type2 <- renderUI({
checkboxGroupInput(inputId = "type2", label = NULL, choices = sort(df_all %>% filter(VAR1 == input$cult, YEAR %in% input$year2) %>% select(TYPE) %>% distinct() %>% pull())
})
df1 <- eventReactive(input$extra1, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year1),
arg3 = as.character(input$type1))
})
df2 <- eventReactive(input$extra2, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year2),
arg3 = as.character(input$type2))
})
})
I tried to attribute the 2 eventReactive in 1 variable df, because I want to see and save the dataframe generated by my_function with :
shinyServer([...]
df <- eventReactive(input$extra1, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year1),
arg3 = as.character(input$type1))
})
df <- eventReactive(input$extra2, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year2),
arg3 = as.character(input$type2))
})
output$tableau_ext1 <- DT::renderDataTable({
df()
})
output$downloadCSV <- downloadHandler(
filename = function() {
paste0(input$year1, "_", input$type1, ".csv")
},
content = function(file) {
write.csv2(df(), file, row.names = FALSE)
}
)
)
But it didn't worked... If someone knows how to solve my problem, I will be grateful for his help :)
Building off of this thread the following seems to achieve the desired behavior (if I understand everything correctly):
library(shiny)
my_fun <- function() {
x <- sample(x=nrow(iris), size = 6)
x
}
ui <- fluidPage(
tabsetPanel(
tabPanel(title = "panel1",
actionButton("go1", "go 1")),
tabPanel(title = "panel2",
actionButton("go2", "go 2"))
),
mainPanel(dataTableOutput("tab"))
)
server <- function(input, output) {
df <- eventReactive(c(input$go1, input$go2), {
iris[my_fun(),]
}, ignoreNULL = FALSE, ignoreInit = TRUE)
output$tab <- renderDataTable({
df()
})
}
shinyApp(ui, server)
See also ?eventReactive for the ignoreNULL and ignoreInit options.
Edit: Two functions, one eventReactive, and keep track of tabs to know what to render.
library(shiny)
library(dplyr)
go1_fun <- function() {
x <- filter(iris, Species == "setosa") %>% head
x
}
go2_fun <- function() {
x <- filter(iris, Species == "virginica") %>% head
x
}
ui <- fluidPage(
tabsetPanel(id = "tabs",
tabPanel(title = "panel1",
actionButton("go1", "go 1")),
tabPanel(title = "panel2",
actionButton("go2", "go 2"))
),
mainPanel(dataTableOutput("tab"))
)
server <- function(input, output, session) {
df1 <- reactive({
if (req(input$go1)) {
x <- go1_fun()
}
return(x)
})
df2 <- reactive({
if (req(input$go2)) {
x <- go2_fun()
}
return(x)
})
tab_to_render <- eventReactive(c(input$go1, input$go2), {
if (input$tabs == "panel1") x <- df1()
if (input$tabs == "panel2") x <- df2()
return(x)
}, ignoreNULL = FALSE, ignoreInit = TRUE)
output$tab <- renderDataTable({
tab_to_render()
})
}
shinyApp(ui, server)