updatePickerInput does not respond to reactive data - r

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))
}

Related

Subsetting dataset when condition is true in Shiny

Using the code below, I could create my shiny app. When users select "yes" instead of "No", I would like the map to display only zip codes with at least 500 participants. As shown in the picture, "no" is selected by default.
I think I need some conditional statements to subset the data, but I dont know how to make this possible!
ui <- fluidPage(
fluidRow(
sidebarPanel(width=2,
radioButtons(
inputId = "ProjectID",
label = strong("Project ID"),
selected = "18",
choices = sort(unique(IDD_nhmap$ProjectID))
),
selectInput(
inputId = "Zip",
label = "Zip Codes With atleast 500 participants",
selected = "No",
selectize = TRUE,
multiple = FALSE,
choices = c("Yes", "No")),
),
######################
mainPanel(
fluidRow(
column(width = 6, shinyjs::useShinyjs(), leafletOutput("IDD_int_map1", height = "500px"))
)
), # this closes mainPanel
), # this closes fluidRow
br(),
br()
) # this closes ui
####################################
server <- function(input, output, session) {
#ACS_Blacks
IDD_mapdata_ <- reactive ({
out_map <- IDD_nhmap %>%
filter (ProjectID %in% input$ProjectID)
return(out_map)
list(Zip_Black)
})
IDD_mapdata_1 <- reactive ({
out_map_1 <- lat_long %>%
filter (ProjectID %in% input$ProjectID)
return(out_map_1)
list(lat)
})
output$IDD_int_map1 <- renderLeaflet ({
npal2 <- colorNumeric(palette = "Greens",
domain = IDD_nhmap$Zip_Black)
labels <- sprintf(
"<strong>Zip Code=%s </strong> <br/> Count = %s <br/> Percentage = %s ",
IDD_mapdata_()$Zip,
IDD_mapdata_()$Zip_Black,
IDD_mapdata_()$state_black
) %>%
lapply(htmltools::HTML)
leaflet (IDD_mapdata_(), options = leafletOptions(zoomSnap = 0.25, zoomDelta =
0.25)) %>%
addProviderTiles("CartoDB.Positron",
options = providerTileOptions(opacity = 2)) %>% # you need this and ()to remove the backgroun (Mexico/Canda)
clearControls() %>%
clearShapes() %>%
addPolygons(
fillColor = ~npal2(Zip_Black),
stroke = T,
weight = 1,
smoothFactor = 0.2,
fillOpacity = 1,
color = "black",
label = labels,
labelOptions = labelOptions(
interactive = TRUE,
style = list(
'direction' = 'auto',
'color' =
'black',
'font-family' = 'sans-serif',
# 'font-style'= 'italic',
'box-shadow' = '3px 3px rgba(0,0,0,0.25)',
'font-size' = '14px',
'border-color' = 'rgba(0,0,0,0.5)'
)
),
highlightOptions = highlightOptions(
weight = 2,
bringToFront = T,
# color = "#666",
fillOpacity = 0.7
)
) %>%
setView(lng = IDD_mapdata_1()$long,
lat = IDD_mapdata_1()$lat,
zoom = 8) %>%
addLegend(
position = "topright",
opacity = 1,
values = IDD_nhmap$Zip_Black,
# colors= c("#FFFFE5", "#D9F0A3", "#78C679", "#006837"),
pal = npal2,
#title = (paste("%",input$ProjectID)) ,
#title = (paste("%",input$ProjectID)) ,
title = (paste("African American (ACS)")) ,
labFormat = labelFormat()
) %>%
addTiles(options = tileOptions(opacity = 2)) # you need this to remove the backgroun (Mexico/Canda)
})
}
shinyApp(ui, server)
Approach 1: checkbox input as filter/subset logic
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxInput("fltr", "Filter mpg above 18", value = TRUE)
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
output$plot <- renderPlot({
subset(mtcars, input$fltr | mpg <= 18) |>
plot(mpg ~ disp, data = _)
})
}
shinyApp(ui, server)
Approach 2: reactive data
This approach might be preferred if multiple components (e.g., plots, tables) use the same optionally-filtered data.
server <- function(input, output, session) {
mydat <- reactive({
dat <- mtcars
if (isTRUE(input$fltr)) {
dat <- subset(dat, mpg <= 18)
}
dat
})
output$plot <- renderPlot({
plot(mpg ~ disp, data = req(mydat()))
})
}

R shiny: How to copy data derived from plotly_selection events into a data frame/table and update each time by pressing an actionButton?

I'm putting together a shiny app to play around with some athlete GPS data. Essentially, I'm looking to structure my script so that each time the user selects an area of interest on the plotly plot and the "Add" actionButton is clicked, the table below will add the calculated Start_time, Time_at_peak, Max_velocity, Time_to_peak, and Distance_to_peak values.
The issue can be seen in the GIF below: - Once the area of interest is selected and the "Add" button clicked, the first values seem correct. However, when the user selects a second area of interest to add to the table, it overwrites the initial entry and will keep overwriting each time a new selection is made. This is seemingly because because the code is inside the observeEvent(event_data("plotly_selected"), which, confusingly, it needs to be in order to calculate the variables of interest.
I'm currently a little stumped and can't seem to find any relevant information. As such, any guidance would be greatly appreciated!
Here is a we transfer link to some test data that can be uploaded to the app: https://wetransfer.com/downloads/5a7c5da5a7647bdbe133eb3fdac79c6b20211119052848/afe3e5
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
x_df <- data.frame(Start_time = character(1), Time_at_peak = character(1), Max_velocity = integer(1),
Time_to_peak = integer(1), Distance_to_peak = integer(1))
x_df$Start_time <- as.character("0:00:00.0")
x_df$Time_at_peak <- as.character("0:00:00.0")
x_df$Max_velocity <- as.integer(0)
x_df$Time_to_peak <- as.integer(0)
x_df$Distance_to_peak <- as.integer(0)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(event_data("plotly_selected"), {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
values <- reactiveValues()
values$df <- x_df
addData <- observe({
if(input$Add > 0) {
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
values$df <- isolate(rbind(values$df, newLine))}
})
output$testing <- renderDataTable({values$df})
})
})
))
I've managed to figure it out and thought I'd post an answer rather than delete the question - just in case someone out there is looking to do a similar thing and they are unsure how to do it.
Firstly, I removed the pre-populated table x_df from the beginning - it was no longer required.
Although I thought the code needed to sit inside the observeEvent(event_data("plotly_selected") to function correctly, it did not - thankfully, because that was at the root of the issue. Instead, I used observeEvent(input$Add, { (which is the correct code to use as opposed to if(input$Add > 0)) to anchor the event to the click of the Add button.
The values <- reactiveValues() was placed outside the observeEvent() and an IF statement was used to either add the data to the values$df data frame on it's own if it was the first selection, or bind it to the existing saved data.
Here's the new code and a GIF demonstrating.
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
values <- reactiveValues(df_data = NULL)
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(input$Add, {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
if (is.null(values$df)){
values$df <- newLine}
else {
values$df <- isolate(rbind(values$df, newLine))}
output$testing <- renderDataTable({values$df})
})
})
))

Read Reactive Elements from Shiny Module

I'm trying to use some reactive elements from predefined function and call that data from a module to generate plots, but data is not getting updated upon selection. I've also tried to call the function inside reactive() and call that from the module, but still same result. My approach is below:
library(shiny)
library(shinyWidgets)
library(highcharter)
library(data.table)
library(dplyr)
employement_type_count <- function(
data,
category,
...
){
data[employee_category %in% category, .(count = .N), by = employee_category]
}
pie_chart_ui <- function(id) {
ns <- NS(id)
highchartOutput(ns("pie"))
}
pie_chart_server <- function(
id,
data,
var_x = names(data)[1],
var_y = names(data)[2],
lab_x = names(data)[1],
lab_y = names(data)[2],
tooltip_name = names(data)[2],
export_title = NA
) {
moduleServer(
id,
function(input, output, session) {
output$pie <- renderHighchart({
data %>%
hchart(
'pie',
hcaes_(x = var_x, y = var_y),
name = tooltip_name
) %>%
hc_xAxis(title = list(text = lab_x)) %>%
hc_yAxis(title = list(text = lab_y)) %>%
hc_plotOptions(
pie = list(
allowPointSelect = TRUE,
cursor = 'pointer',
dataLabels = list(
enabled = TRUE,
format = '<b>{point.name}</b>: {point.percentage:.1f}%',
style = list(
color = "(Highcharts.theme && Highcharts.theme.contrastTextColor) || 'black'"
)
)
)
) %>%
hc_exporting(
enabled = TRUE,
buttons = list(
contextButton = list(
align = 'right'
)
),
chartOptions = list(
title = list(
text = export_title
)
)
)
})
}
)
}
ui <- fluidPage(
sidebarPanel(
pickerInput(
"employee_type",
"Employee Type",
choices = c("Regular", "Project", "Service", "Part-Time"),
selected = c("Regular", "Project", "Service", "Part-Time"),
multiple = TRUE
)
),
mainPanel(
pie_chart_ui("employee_category")
)
)
server <- function(input, output, session){
# data_common <- fread("data_common.csv")
data_common <- data.table(
id = 1:26,
employee_name = LETTERS,
gender_type = rep(c("Male", "Female"), each = 13),
employee_category = c("Regular", "Project", rep(c("Regular", "Project", "Service", "Part-Time"), times = 6))
)
pie_chart_server(
"employee_category",
employement_type_count(
data_common,
input$employee_type
)
)
}
shinyApp(ui, server)
Note that, data should be imported from server, instead of global, as it is constantly getting updated.
One way to do it is shown below.
library(shiny)
library(shinyWidgets)
library(highcharter)
library(data.table)
library(dplyr)
df1 <- data.table(
id = 1:26,
employee_name = LETTERS,
gender_type = rep(c("Male", "Female"), each = 13),
employee_category = c("Regular", "Project", rep(c("Regular", "Project", "Service", "Part-Time"), times = 6))
)
employement_type_count <- function(
data,
category,
...
){
data <- data()
if (is.null(category())) {df <- data
}else df <- data[employee_category %in% category(), .(count = .N), by = employee_category]
return(df)
}
pie_chart_ui <- function(id) {
ns <- NS(id)
highchartOutput(ns("pie"))
}
pie_chart_server <- function(
id,
data,
var_x = names(data)[1],
var_y = names(data)[2],
lab_x = names(data)[1],
lab_y = names(data)[2],
tooltip_name = names(data)[2],
export_title = NA
) {
moduleServer(
id,
function(input, output, session) {
output$pie <- renderHighchart({
data %>%
hchart(
'pie',
hcaes_(x = var_x, y = var_y),
name = tooltip_name
) %>%
hc_xAxis(title = list(text = lab_x)) %>%
hc_yAxis(title = list(text = lab_y)) %>%
hc_plotOptions(
pie = list(
allowPointSelect = TRUE,
cursor = 'pointer',
dataLabels = list(
enabled = TRUE,
format = '<b>{point.name}</b>: {point.percentage:.1f}%',
style = list(
color = "(Highcharts.theme && Highcharts.theme.contrastTextColor) || 'black'"
)
)
)
) %>%
hc_exporting(
enabled = TRUE,
buttons = list(
contextButton = list(
align = 'right'
)
),
chartOptions = list(
title = list(
text = export_title
)
)
)
})
}
)
}
ui <- fluidPage(
sidebarPanel(
pickerInput(
"employee_type",
"Employee Type",
choices = c("Regular", "Project", "Service", "Part-Time"),
selected = c("Regular", "Project", "Service", "Part-Time"),
multiple = TRUE
)
),
mainPanel(
pie_chart_ui("employee_category")
)
)
server <- function(input, output, session){
# data_common <- fread("data_common.csv")
data_common <- reactive(df1)
employee <- reactive(input$employee_type)
observe({
mydata <- employement_type_count(
data_common,
employee
)
pie_chart_server(
"employee_category",
mydata
)
})
}
shinyApp(ui, server)

SEPTA Map R Shiny Issue with ObserveEvent

I have the following Shiny Application:
rm(list=ls())
# requirements
requirement_vector <- c("shiny", "leaflet", "tidyverse", "gtfsr", "dataMeta")
lapply(requirement_vector, require, character.only = TRUE)
# data load
{
zip <- get_feed(url = "https://github.com/septadev/GTFS/releases/download/v201812161/gtfs_public.zip",
paste0(getwd(), "/SEPTA_Site"),
quiet = FALSE)
unzip(zip, exdir = paste0(getwd(), "/SEPTA_Site"))
RailData <- import_gtfs(paste0(getwd(), "/SEPTA_Site/google_rail.zip"), local = TRUE)
BusData <- import_gtfs(paste0(getwd(), "/SEPTA_Site/google_bus.zip"), local = TRUE)
delete_vector <- list.files(paste0(getwd(), "/SEPTA_Site"), pattern = "*.zip*")
lapply(as.list(delete_vector), function(x) file.remove(paste0(getwd(), "/SEPTA_Site/", x, "")))
Lines <- c('Broad Street Line', 'Bus', 'Market Frankford Line', 'Regional Rail', 'Trolley')
RRRouteNames <- unique(RailData[["routes_df"]][["route_short_name"]]) %>% sort()
BRouteNames <- unique(BusData[["routes_df"]][["route_id"]])
rmv <- c('BSL', 'BSO', 'MFL', 'MFO', 'NHSL', 'LUCYGO', 'LUCYGR')
BRouteNames <- BRouteNames[!BRouteNames %in% rmv]
TRouteNames <- c('10', '11', '13', '15', '34', '36', '101', '102')
BRouteNames <- BRouteNames[!BRouteNames %in% TRouteNames]
df <- RailData[["stops_df"]]
df <- df %>% inner_join(RailData[["stop_times_df"]],df , by = "stop_id")
df <- df %>% inner_join(RailData[["trips_df"]],df , by = "trip_id")
df <- df %>% inner_join(RailData[["routes_df"]],df , by = "route_id")
keep_vector <- c("stop_id", "stop_name", "stop_lat", "stop_lon", "zone_id",
"arrival_time", "departure_time", "route_id", "route_text_color",
"direction_id", "route_short_name")
df <- unique(df[keep_vector])
df$route_short_name <- paste("Route ", df$route_short_name)
rm(delete_vector, requirement_vector,keep_vector, rmv, zip)
}
# ui
{
ui <- fluidPage(
# App title
titlePanel("Septa Price Map"),
sidebarLayout(
sidebarPanel(
# Input: Input for type & line
selectInput(inputId = "line", label = "Choose Your Service:",
choices = Lines, selected = "Broad Street Line"),
conditionalPanel(
condition = "input.line == 'Regional Rail'",
selectInput(inputId = "line2", label = "Choose Your Route:",
choices = RRRouteNames)),
conditionalPanel(
condition = "input.line == 'Trolley'",
selectInput(inputId = "line3", label = "Choose Your Route:",
choices = TRouteNames)),
conditionalPanel(
condition = "input.line == 'Bus'",
selectInput(inputId = "line4", label = "Choose Your Route:",
choices = BRouteNames)),
conditionalPanel(
condition = "input.line == 'Bus' || input.line == 'Trolley'",
textOutput(outputId = "description")),
actionButton(inputId = "clear", label = "Clear Selection")
),
mainPanel({
leafletOutput(outputId = "MyMap")
})
)
)
}
# server
{
server <- function(input, output) {
output$MyMap <- renderLeaflet({
if (input$line == "Broad Street Line"){
map_gtfs(gtfs_obj = BusData, route_ids = 'BSL', stop_opacity = .75) %>% addProviderTiles(providers$Stamen.Terrain)
} else if (input$line == "Market Frankford Line"){
map_gtfs(gtfs_obj = BusData, route_ids = 'MFL', stop_opacity = .75) %>% addProviderTiles(providers$Stamen.Terrain)
} else if (input$line == "Trolley"){
map_gtfs(gtfs_obj = BusData, route_ids = input$line3, stop_opacity = .75) %>% addProviderTiles(providers$Stamen.Terrain)
} else if (input$line == "Bus"){
map_gtfs(gtfs_obj = BusData, route_ids = input$line4, stop_opacity = .75) %>% addProviderTiles(providers$Stamen.Terrain)
} else if (input$line == "Regional Rail"){
map_gtfs(gtfs_obj = RailData, route_ids =
plyr::mapvalues(input$line2,
RailData[["routes_df"]][["route_short_name"]],
RailData[["routes_df"]][["route_id"]],
warn_missing = FALSE),
stop_opacity = .75) %>% addProviderTiles(providers$Stamen.Terrain)
}
})
output$description <- renderText({
if (input$line == "Trolley") {
plyr::mapvalues(input$line3,
BusData[["routes_df"]][["route_id"]],
BusData[["routes_df"]][["route_long_name"]],
warn_missing = FALSE)}
else {
plyr::mapvalues(input$line4,
BusData[["routes_df"]][["route_id"]],
BusData[["routes_df"]][["route_long_name"]],
warn_missing = FALSE)
}
})
observeEvent(input$MyMap_marker_click, {
print(input$MyMap_marker_click)
})
}
}
shinyApp(ui = ui, server = server)
This functions fine so far, it reacts to the initial input and is able to map individual routes. My issue comes from the last few lines of code when I print the Marker Click. The group, latitude and longitude of each stop is printed but not the stopID which is what I'm looking for. In addition, something called $.nonce is printed and I haven't had any luck searching for what that number represents. The stopID appears in the popup so I know it's stored somewhere in the map, I'm just not sure where. I'm new to shiny and leaflet and would appreciate any help.

Table will not render in Shiny

I have been messing with making a shiny app and I feel as though i am doing everything in the correct manner to get the table to render but no luck. In my app you should you upload an csv and then go to the data frame tab. I have tried many small changes but nothing seems to work. Id imagine this has something to do with the server section but i cant see it.
R ui:
library(readxl)
library(plyr)
library(dplyr)
library(plotly)
library(readr)
library(RColorBrewer)
library(data.table)
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(DT)
library(xtable)
ui <- fluidPage(theme = shinytheme("slate"), mainPanel(
navbarPage(
"Permian Plots", collapsible = TRUE, fluid = TRUE,
navbarMenu(
"County Plot",
tabPanel(
sidebarPanel( fileInput(
'file1',
'Choose CSV File',
accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv')
),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
# App buttons comma and quote
radioButtons('sep', 'Separator',
c(
Comma = ',',
Semicolon = ';',
Tab = '\t'
), ','),
radioButtons(
'quote',
'Quote',
c(
None = '',
'Double Quote' = '"',
'Single Quote' = "'"
),
'"'
))
),
tabPanel("Data Frame",
fluidRow(box(DT::dataTableOutput("contents")))),
tabPanel("County Plot", plotlyOutput(
"plotMap", height = 1200, width = 1200
),
actionButton("btn", "Plot")
)
)
)
)
)
Server:
server <- function(input, output, session) {
options(shiny.maxRequestSize = 200*1024^2)
dsnames <- c()
data_set <- reactive({
inFile <- input$file1
if (is.null(inFile)){
return()
}
data_set <- read.csv(
inFile$datapath,
header = input$header,
sep = input$sep,
quote = input$quote
)
})
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
})
})
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
observeEvent(
input$btn,
{
output$plotMap <- renderPlotly({withProgress(message = 'Plotting...', value = 0.1,{
plot <- Plots(data_set(),
"Martin County",
"~/Work/permin/martin county/martin data/f1.csv",
"~/Work/permin/BestMartinPlotSat.html",
32.1511, -101.5715)
setProgress(1)
})
})
}
)
}
shinyApp(ui = ui, server = server)
Function:
Should not be the problem causer in this.
Plots <- function(df, C_name, PathCSV, PathWidg, Lat, Lon){
f1 <- df
f1$Date <- as.POSIXct(f1$Date)
f1$year <- format(as.POSIXct(f1$Date,format="%y-%m-%d"), "%y")
f1$month <- format(as.POSIXct(f1$Date,format="%y-%m-%d"), "%m")
f1$Cell <- as.factor(f1$Cell)
z <- ddply(f1, c("year", "month", "Cell"), summarise,
yearMonth_Max_sum = max(`Cell Sum (Norm)`))
f1 <- inner_join(f1,z, by = c("year", "month", "Cell"))
f1$Changed <- as.numeric(as.factor(f1$Changed))
f1$Changed[f1$Changed == 1] <- 0
f1$Changed[f1$Changed == 2] <- 1
z <- ddply(f1, c("year", "month", "Cell"), summarise,
ChangedX = max(Changed))
f1 <- inner_join(f1,z, by = c("year", "month", "Cell"))
f1$MY <- paste(f1$year, f1$month, sep = "-")
#preapring data for plotly
q <- matrix(quantile(f1$StdDev))
f1$qunat <- NA
up <- matrix(quantile(f1$StdDev, probs = .95))
up
f1$qunat <- ifelse((f1$StdDev > q[4:4,1]) & (f1$StdDev < up[1,1]), 1, 0)
z <- group_by(f1, Cell) %>%
summarize(Median_Cell = median(`Cell Sum (Norm)`, na.rm = FALSE))
f1 <- inner_join(f1,z, by = c("Cell"))
quantile(round(f1$Median_Cell))
f1$NewMedian <- NA
f1$NewMedian[f1$Median_Cell > 4000] <- 0
f1$NewMedian[f1$Median_Cell <= 4000] <- 1
f1$NewSum <- NA
f1$NewSum <- f1$yearMonth_Max_sum * f1$ChangedX * f1$qunat * f1$NewMedian
write_csv(f1, PathCSV )
f2 <- f1[!duplicated(f1$yearMonth_Max_sum), ]
#plolty plot
Sys.setenv('MAPBOX_TOKEN' = 'pk.eyJ1IjoiY3dvb2RzMjIiLCJhIjoiY2prMnlycmduMDJvNjNxdDEzczNjdGt3YSJ9.RNuCSlHyKZpkTQ8mJmg4aw')
p <- f2[which(f2$yearMonth_Max_sum < 9000),] %>%
plot_mapbox(
lon = ~Lon,
lat = ~Lat,
size = ~yearMonth_Max_sum,
color = ~(NewSum),
frame = ~MY,
type = 'scattermapbox',
mode = 'markers',
colors = c("green","blue")
) %>%
add_markers(text = ~paste("Sum", yearMonth_Max_sum, "/<br>",
"Standard Dev", StdDev, "/<br>",
"Mean", Average, "/<br>",
"Median", Median_Cell, "/<br>",
"Changed", ChangedX, "/<br>",
"Latitude", Lat , "/<br>",
"Longitude", Lon)) %>%
layout(title = C_name,
font = list(color = "black"),
mapbox = list(style = "satellite", zoom = 9,
center = list(lat = Lat,
lon = Lon)))
p
htmlwidgets::saveWidget(p, PathWidg)
}
the last thing in your function is what is returned. you are returning setprogress(1) to renderdatatable()
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
})
Try this instead
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatab <- datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
datatab
})

Resources