default initial value for input with SelectizeGroup - r

I'm using the amazing shinyWidget package inside a shiny app and specifically i'm playing around with SelectizeGroup function in order to create a group of SelectizeInput in order to filter a data.frame.
Is there a way to specify a default value for the input like we do for selectizeInput?
i.e with selectizeInput we have a parameter selected which is
The initially selected value (or multiple values if multiple = TRUE).
If not specified then defaults to the first value for single-select
lists and no values for multiple select lists.
I wonder if there's something similar.
EXAMPLE taken from : https://www.davidsolito.com/post/conditional-drop-down-in-shiny/
a_df <- tibble(
var_one = c("hadley", "charlotte", "rené", "raymond"),
var_two = c("mutate", "filter", "slice", "spread"),
var_three = c("an apple", "a pipe", "a cocktail", "a dog"),
var_four = c("with", "without", "thanks", "out of"),
var_five = c("tidyr", "magrittr", "purrr", "dplyr")
)
ex_df <- expand.grid(a_df)
tib <- as_tibble(sample_n(ex_df, 40))
library(shinyWidgets)
shinyApp(
ui = pageWithSidebar(
headerPanel("Painting 8"),
sidebarPanel(
selectizeGroupUI(
id = "my-filters",
inline = FALSE,
params = list(
var_one = list(inputId = "var_one", title = "Select variable 1", placeholder = 'select'),
var_two = list(inputId = "var_two", title = "Select variable 2", placeholder = 'select'),
var_three = list(inputId = "var_three", title = "Select variable 3", placeholder = 'select'),
var_four = list(inputId = "var_four", title = "Select variable 4", placeholder = 'select'),
var_five = list(inputId = "var_five", title = "Select variable 5", placeholder = 'select')
)
)
),
mainPanel(
tableOutput("table")
)
),
server = function(input, output, session) {
res_mod <- callModule(
module = selectizeGroupServer,
id = "my-filters",
data = tib,
vars = c("var_one", "var_two", "var_three", "var_four", "var_five")
)
output$table <- renderTable({
res_mod()
})
},
options = list(height = 500)
)
I'd like to have , when the app starts, a pre-selected value at least for the first variable var_one

Related

How do I add the option to connect observations by ID in Shiny?

I'm working on my Shiny app that visualizes/summarizes PK data. Anyways, I have a small question. I want to add in the option for the user to connect observations by ID in Shiny, so I want them to choose. This could be a single tickbox which would be: "Connect observations by ID', or just a statement like: 'Connect observations by ID:" with boxes as 'Yes' or 'No'. I hope you get what I mean. How do I do this? I have a pretty large code for my app, as I've come a long way already.
Small note, I can't generate a report yet, as the code is not right, but you can just ignore this. Tab 2 is not finished yet, but the base is there.
UI
ui <- fluidPage(
tabsetPanel(tabPanel("Tab 1",
titlePanel("Shiny App: Concentration vs Time Graphs"),
sidebarLayout(
mainPanel("Concentration vs Time graphs", plotOutput(outputId = "plot")),
sidebarPanel(style = "height:90vh; overflow-y: auto",
p("This app is developed to visualize pharmacokinetic data of different antibodies. Please select the data you want to visualize before running the graph. The graph can be reset with the reset button."),
strong("1. Filter your data for these following variables:"),
checkboxInput('checkbox1', 'Filter by study', FALSE),
conditionalPanel(condition = "input.checkbox1 == 1",
selectInput(inputId = "study", label = "Include study:",
choices = c("GLP Toxicity" = "GLPTOX", "Dose Range Finding" = "DRF", "Single Dose" = "SD", "Repeat Dose" = "RD"),
selected = c("GLPTOX", "DRF", "SD", "RD"),
multiple = T)
),
checkboxInput('checkbox2', 'Filter by platform', FALSE),
conditionalPanel(condition = "input.checkbox2 == 1",
selectInput(inputId = "platform", label = "Include platform:",
choices = c("Hexabody", 'Duobody' = "Doubody", "Bispecific"), selected = c("Hexabody", "Doubody", "Bispecific"),
multiple = T)
),
checkboxInput('checkbox3', 'Filter by species', F),
conditionalPanel(condition = "input.checkbox3 == 1",
selectInput(inputId = "species", label = "Include species:",
choices = c("Monkey", 'Mouse'), selected = c('Monkey', 'Mouse'), multiple = T)
),
checkboxInput('checkbox4', 'Filter by administration route', F),
conditionalPanel(condition = "input.checkbox4 == 1",
selectInput(inputId = "route", label = "Include administration route:",
choices = c('Route 1' = "ROUTE1", 'Route 2' = "ROUTE2"), selected = c("ROUTE1", "ROUTE2"),
multiple = T)
),
selectInput(inputId = "x", label = "2. X-axis:", choices = c("Time" = "TIME", "TLD"), selected = "Time"
),
selectInput(inputId = 'column', label = "3. Columns for:",
choices = c("Dose mg/kg" = "DOSEMGKG", "Species" = "SPECIES", "Antibody" = "ABXID", "Subspecies" = "SUBSPECIES", "Age" = "AGE", "Animal ID" = "ANIMALID"),
selected = "DOSEMGKG"
),
conditionalPanel(condition = "input.column == 'DOSEMGKG'",
selectInput(inputId = 'dose', label = "Choose dose(s):",
choices = c("0.05", '0.5', "20", '5'), selected = c('0.05', '0.5', '20', '5'), multiple = T
)
),
selectInput(inputId = 'row', label = "4. Rows for:",
choices = c("Dose mg/kg" = "DOSEMGKG", "Species" = "SPECIES", "Antibody" = "ABXID", "Subspecies" = "SUBSPECIES", "Age" = "AGE", "Animal ID" = "ANIMALID",
"Platform" = "PLATFORM", "Mutation" = "MUTATION"),
selected = "ABXID"
),
conditionalPanel(condition = "input.row == 'MUTATION'",
selectInput(inputId = 'mutation', label = "Choose mutation(s):", choices = c('M1', "M2", "M3"), selected = c('M1', "M2", "M3"), multiple = T
)
),
conditionalPanel(
condition = "input.row == 'ABXID'",
selectInput(
inputId = 'antibody',
label = "Choose antibody(s):",
choices = c('Duobody-XXXXX', "Duobody-CD3x5T4"), selected = c('Duobody-XXXXX', 'Duobody-CD3x5T4'), multiple = T
)
),
selectInput(
inputId = "group",
label = "5. Group by:",
choices = c("Dose mg/kg" = "DOSEMGKG", "Species" = "SPECIES", "Antibody" = "ABXID", "Subspecies" = "SUBSPECIES", "Age" = "AGE", "Animal ID" = "ANIMALID",
'Administration route' = 'ROUTE'),
selected = "ANIMALID"
),
sliderInput(
inputId = 'trange',
label = "6. Time range:",
min = 0,
max = 1704,
value = c(0, 1704 )
),
actionButton(
inputId = 'runbutton',
label = 'Run graph'
),
actionButton(
inputId = 'resetbutton',
label = 'Reset graph'
),
downloadButton(outputId = 'report', label = "Generate report"),
br(),
br(),
br(),
p("----------")
))
)),
tabsetPanel(tabPanel("Tab 2",
titlePanel("Tab 2"),
sidebarLayout(
mainPanel("Plot #2", plotOutput(outputId = "plot2")),
sidebarPanel(helpText("Whatever text..."),
selectInput(
inputId = 't',
label = "Example",
choices = c("#1", "#2", "#3"),
selected = "#1"
)
)
)))
)
Server
server <- function(input, output, session){
observeEvent(input$runbutton, {output$plot <- renderPlot({
ggplot(data = df %>% filter(STUDYID %in% input$study & ABXID %in% input$antibody & MUTATION %in% input$mutation & PLATFORM %in% input$platform
& SPECIES %in% input$species & DOSEMGKG %in% input$dose & ROUTE %in% input$route),
aes_string(x = input$x, y = "DV", col = input$group)) + xlab("Time") + ylab("Concentration (ug/mL)") +
geom_point() + facet_grid(get(input$row) ~ get(input$column)) + scale_x_continuous(limits = input$trange) +
scale_color_viridis(discrete = T, option = 'F', begin = 0, end = 0.8) + theme_bw() + scale_y_log10()})})
observeEvent(input$resetbutton, {output$plot <- renderPlot({ NULL })})
output$report <- downloadHandler(filename = "report.pdf", content = function(file){
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = T)
params <- list(n = input$x)
rmarkdown::render(tempReport, output_file = file, params = params, envir = new.env(parent = globalenv()))
})
}
shinyApp(ui = ui, server = server)
I know that it's something with geom_line(aes(group = "ANIMALID")), but I do not yet know how to make this an option to include/exclude.
Here is a simple app, that has a ggplot2 with some data, and whether the points are to be drawn connected by lines (within relevant groups) is toggleable.
I hope it helps you; your posted code is not reproducible as it uses private data, (and it is not minimal, its a lot of content to look at).
perhaps you can use this example as a base to ask further questions from as you complicate it, or account for relevant differences. but notice how my example is at least reproducible (you can run it; it is based on public, not private data).
library(shiny)
library(tidyverse)
some_data <- distinct(
iris,
Species, Petal.Width, Petal.Length
) |>
group_by(Species, Petal.Width) |>
summarise(avg_Petal.Length = mean(Petal.Length)) |>
ungroup()
ui <- fluidPage(
plotOutput("myplot", width = 400, height = 400),
checkboxInput("mytog", "line?")
)
server <- function(input, output, session) {
output$myplot <- renderPlot({
plot_to_show <-
ggplot(data = some_data) +
aes(
x = Petal.Width,
y = avg_Petal.Length,
colour = Species
) +
geom_point()
if (isTruthy(input$mytog)) {
plot_to_show <- plot_to_show + geom_line()
}
plot_to_show
})
}
shinyApp(ui, server)

Map either numerical values or a character string

I'm trying to create a ShinyApp and hoping I could get some pointers.
I'm trying to get a summary table ("Summary score") to represent either i) the minimum value associated with user input for radio buttons (e.g., Id037_crit1 & Id038_crit1) or the text string "NA" if a checkbox is selected (Id039_crit1).
I'm not sure how to change the code such that the summary table shows either the minimum value for the radio buttons or the character string if the checkbox is selected. I'm assuming there's some kind of if-else statement but I can't get it to work.
library(shinydashboard)
library(shinythemes)
library(shiny)
library(shinyWidgets)
library(DT)
library(tidyverse)
ui <- fluidPage(
theme = shinytheme("united"),
# Application title
titlePanel("TITLE"),
sidebarLayout(
sidebarPanel(
selectInput("select",
label = helpText("Select a critera"),
choices = list("Criteria_1", "Criteria_2"),
selected = c("NULL")
)
),
mainPanel(tabsetPanel(
tabPanel(
"Criteria", conditionalPanel(h3("Question 1", align = "left"),
condition = "input.select == 'Criteria_1'",
prettyRadioButtons(
inputId = "Id037_crit1",
label = "Predictions:",
choices = c(
"Option 1" = 1,
"Option 2" = 2,
"Option 3" = 3
),
inline = TRUE,
status = "danger",
fill = TRUE
),
),
conditionalPanel(h3("Question 2", align = "left"),
condition = "input.select == 'Criteria_1'",
prettyRadioButtons(
inputId = "Id038_crit1",
label = "Hypotheses:",
choices = c(
"Option 1" = 1,
"Option 2" = 2,
"Option 3" = 3
),
inline = TRUE,
status = "danger",
fill = TRUE)
),
conditionalPanel(h3("Or", align = "left"),
condition = "input.select == 'Criteria_1'",
awesomeCheckbox(
inputId = "Id039_crit1",
label = "NA",
status = "danger")
),
# User side-pannel selection - criteria 2
conditionalPanel(h3("Question 1", align = "left"),
condition = "input.select == 'Criteria_2'",
prettyRadioButtons(
inputId = "Id040_crit2",
label = "Methods:",
choices = c(
"Option 1" = 1,
"Option 2" = 2
),
inline = TRUE,
status = "danger",
fill = TRUE)),
# Second Tab --------------------------------------------------------------
tabPanel(
"Summary score",
DTOutput("summary")
),
))
)
)
# SERVER ------------------------------------------------------------------
server <- function(input, output) {
calc_min_val <- function(contains) {
radios_inputid <- str_subset(names(input), contains)
map_dbl(radios_inputid, ~ as.numeric(input[[.x]])) %>%
min()
}
summ <- reactive({
min_values <- c("crit1$", "crit2$") %>%
map(calc_min_val)
tibble(
Lowest_Criteria = c("Specific hypotheses and prediction are provided?", "Predictions regarding the electromagnetic area of
interest are sufficient?"),
value = map(min_values, ~.)
)
})
output$summary <- DT::renderDT({
datatable(summ())
})
# Downloadable csv of selected dataset ----
output$downloadData <- downloadHandler(
filename = function() {
paste("DATA", ".csv", sep = "")
},
content = function(file) {
write.csv(datasettable(summ()), file, row.names = FALSE)
}
)
}
shinyApp(ui, server)
Perhaps you are looking for this
summ <- reactive({
min_values <- c("crit1$", "crit2$") %>%
map(calc_min_val)
if (input$Id039_crit1 & input$select == 'Criteria_1') value = "NA" else value = map(min_values, ~.)
tibble(
Lowest_Criteria = c("Specific hypotheses and prediction are provided?", "Predictions regarding the electromagnetic area of
interest are sufficient?"),
value = value
)
})

Update new table with rows appended using actionButton in R Shiny

I have a Forecast table in Aurora, which I am able to read and filter-load using reactive. I am writing new rows to the table using an action button 'write_to_forecast_table', but I am not able to load the newly added row in the main table simultaneously.
tabPanel("Plant-Screen",
fluidRow(id='forecast_section',
column(width = 3, class='div-box-shadow',
tags$div(selectInput("fb_plant_input", label = 'Select Plant: ', choices= c(" All"), selected = NULL, multiple = FALSE, width = "100%"),
selectInput("fb_material_input", label = 'Commodity', choices = c(" All"), multiple=FALSE, width="100%"),
selectInput("fb_for_month_year", label = 'Procured for Month_Year', choices = c(" All"), multiple=FALSE, width="100%"),
br(),
tags$div(shinyWidgets::actionBttn(inputId = 'view_existing_forecasts', label='View Volume Forecast')),
tags$div(shinyWidgets::actionBttn(inputId = 'create_new_forecast', label='Create New Forecast')
),
bsModal(id="modal_demand_view",
title = "Create Volume Demand Forecast",
trigger = "create_new_forecast",
size="medium",
fluidRow(id = 'new_demand_form',
column(width = 12,
tags$div(style="display:contents;",
selectizeInput("selected_plant",
label = 'Plant',
options = list(placeholder = 'Select Plant'),
choices= unique(fb_plant_table$plant_name),
multiple=FALSE,
width="100%"),
br(),
selectizeInput("selected_material",
label = 'Commodity',
options = list(placeholder = 'Select Commodity'),
choices = unique(fb_material_table$commodity),
multiple=FALSE,
width="100%"),
br(),
airDatepickerInput("selected_month_year",
label = "Enter for Month-Year :",
value = lubridate::ymd(today()),
minDate = lubridate::ymd(today()) %m+% months(1),
maxDate = lubridate::ymd(today()) %m+% months(12),
view = "months",
minView = "months",
dateFormat = "yyyy-mm",
width = "50%",
autoClose = TRUE
),
br(),
numericInput("volume_requested",
label = "Enter Additional Volume",
value = 0,
width = "50%"),
br(),
selectizeInput("volume_unit", label = "Unit of Volume",
choices = c("pounds"),
multiple = FALSE,
width = "50%"),
br(),
selectInput("selected_supplier", label = "Supplier",
choices = "",
multiple = FALSE,
width = "50%")
)
)
),
br(),
tags$hr(),
tags$div(shinyWidgets::actionBttn(inputId = 'write_to_forecast_table',
label='New Volume Demand Created',
color="success",
style="material-flat")
)
)
)
),
column(width = 9, class='div-box-shadow',
tags$div(tags$h4 ('Volume Forecast Tabular View',
style="font-weight:bold;color: #ffd207;text-align: center;"
),
br(),
dataTableOutput("vol_forecast_meta_data") %>% shinycssloaders::withSpinner(color="#78620e")
)
Server Side:
#reading table from Aurora:
c <- dcon_iam()
vol_forecast_aurora <- DBI::dbGetQuery(c, 'select * from database_name.vol_forecast_aurora')
vol_forecast_aurora <- vol_forecast_aurora %>% group_by(plant_name, commodity, for_month_year) %>% mutate(cum_sum = cumsum(additional_volume))
DBI::dbDisconnect(c)
#Viewing forecast based on inputs selected from Select Input:
observeEvent(input$view_existing_forecasts, {
view_fc_reactive <- reactive({
vol_forecast_aurora %>%
filter(plant_name == input$fb_plant_input) %>%
filter(commodity == input$fb_material_input) %>%
filter(for_month_year == input$fb_for_month_year)
})
output$vol_forecast_meta_data <- DT::renderDataTable(view_fc_reactive(),
options = list(paging = FALSE, searching = FALSE),
rownames = FALSE)
})
#update table based on the new row added using Modal:
observeEvent(input$write_to_forecast_table, {
forecast_temp <- z$vol_forecast_aurora
forecast_temp$entered_by=input$user_id
forecast_temp$entered_on=lubridate::ymd(today())
forecast_temp$plant_name=input$selected_plant
forecast_temp$commodity=input$selected_material
forecast_temp$for_month_year=input$selected_month_year
forecast_temp$additional_volume=input$volume_requested
forecast_temp$unit_of_vol=input$volume_unit
forecast_temp$supplier=input$selected_supplier
forecast_temp = forecast_temp[, c('entered_by', 'entered_on', 'plant_name', 'commodity', 'for_month_year', 'additional_volume', 'unit_of_vol', 'supplier')]
c = dcon_iam()
write_to_caspian_aurora(c,
value= z$forecast_temp,
name="vol_forecast_aurora",
append = TRUE,
overwrite=FALSE,
row.names=FALSE
)
#removeModal('modal_demand_view')
showNotification({"Demand Forecast Submitted"})
DBI::dbDisconnect(c)
#reloading the data to the app:
c <- dcon_iam()
vol_forecast_aurora <- DBI::dbGetQuery(c, 'select * from spendanalytics_ico.vol_forecast_aurora')
vol_forecast_aurora <- vol_forecast_aurora %>% group_by(plant_name, commodity, for_month_year) %>% mutate(cum_sum = cumsum(additional_volume))
DBI::dbDisconnect(c)
})
I need help sorting the last part of the server: observeEvent(input$write_to_forecast_table, {})
Your problem is that the underlying data vol_forecast_aurora is only fetched once when the app is loaded (and that it is not reactive, so that the last lines in observeEvent(input$write_to_forecast_table only create a local object within the observer). Therefore, you don't see the changes when you update the DB within the app. I suggest that you store vol_forecast_aurora within a reactiveValues object, so that you can easily update it.
Untested code:
#reading table from Aurora:
c <- dcon_iam()
data <- reactiveValues(vol_forecast_aurora = DBI::dbGetQuery(c, 'select * from database_name.vol_forecast_aurora') %>% group_by(plant_name, commodity, for_month_year) %>% mutate(cum_sum = cumsum(additional_volume)))
DBI::dbDisconnect(c)
#Viewing forecast based on inputs selected from Select Input:
observeEvent(input$view_existing_forecasts, {
view_fc_reactive <- reactive({
data$vol_forecast_aurora %>%
filter(plant_name == input$fb_plant_input) %>%
filter(commodity == input$fb_material_input) %>%
filter(for_month_year == input$fb_for_month_year)
})
output$vol_forecast_meta_data <- DT::renderDataTable(view_fc_reactive(),
options = list(paging = FALSE, searching = FALSE),
rownames = FALSE)
})
#update table based on the new row added using Modal:
observeEvent(input$write_to_forecast_table, {
forecast_temp <- z$vol_forecast_aurora
forecast_temp$entered_by=input$user_id
forecast_temp$entered_on=lubridate::ymd(today())
forecast_temp$plant_name=input$selected_plant
forecast_temp$commodity=input$selected_material
forecast_temp$for_month_year=input$selected_month_year
forecast_temp$additional_volume=input$volume_requested
forecast_temp$unit_of_vol=input$volume_unit
forecast_temp$supplier=input$selected_supplier
forecast_temp = forecast_temp[, c('entered_by', 'entered_on', 'plant_name', 'commodity', 'for_month_year', 'additional_volume', 'unit_of_vol', 'supplier')]
c = dcon_iam()
write_to_caspian_aurora(c,
value= z$forecast_temp,
name="vol_forecast_aurora",
append = TRUE,
overwrite=FALSE,
row.names=FALSE
)
#removeModal('modal_demand_view')
showNotification({"Demand Forecast Submitted"})
DBI::dbDisconnect(c)
#reloading the data to the app:
c <- dcon_iam()
vol_forecast_aurora_local <- DBI::dbGetQuery(c, 'select * from spendanalytics_ico.vol_forecast_aurora')
data$vol_forecast_aurora <- vol_forecast_aurora_local %>% group_by(plant_name, commodity, for_month_year) %>% mutate(cum_sum = cumsum(additional_volume))
DBI::dbDisconnect(c)
})

Creating inputs that depend on each other with Shiny and Flexdashboard

I have tried creating a drop-down that depends on a different widget ID.
In this app, the symbol drop-down-list depends on the input from the Stock Class chckboxGroupButtons()
I've successfully implemented that, but after inserting an eventReactive () that delays the reactive filtering and only starts filtering once "apply" is selected, the app shows an empty dataframe to start with.
Only AFTER clicking on either "Apply" or "Reset" then the app works the way it should.
I just need the unfiltered dataframe when rendering the app for the first time.
How do I fix this?
Code:
---
title: "Sample App"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
library(flexdashboard)
library(shiny)
library(shinyWidgets)
library(shinyjs)
# Core
library(tidyverse)
library(lubridate)
# Make data
symbols <- purrr::cross_df(list(numbers = 1:90,letters = LETTERS))
symbols$symbol <- paste(symbols$numbers,symbols$letters,sep = " - ")
set.seed(123)
stock_prices_tbl <- tibble(
date = seq.Date(from = ymd("2018-01-01"), to = Sys.Date(), length.out = 90),
class = sample(c("marketing", "sales", "research"), size = 90, replace = TRUE),
symbol = sample(symbols$symbol,size = 90,replace = F),
adjusted = runif(n = 90,min = 0,90)
)
Sidebar {.sidebar}
---
# Allow shiny js
shinyjs::useShinyjs(rmd = T)
dateRangeInput(
inputId = "date_range",
label = h4("Date Range"),
start = min(stock_prices_tbl$date),
end = max(stock_prices_tbl$date),
min = min(stock_prices_tbl$date),
max = max(stock_prices_tbl$date),
startview = "month")
shinyWidgets::checkboxGroupButtons(
inputId = "class",
label = h4("Stock Class"),
choices = unique(stock_prices_tbl$class),
selected = unique(stock_prices_tbl$class),
checkIcon = list(
yes = icon("ok", lib = "glyphicon"),
no = icon("remove", lib = "glyphicon")
))
shiny::renderUI({
shinyWidgets::pickerInput(
inputId = "symbol",label = h4("Symbol"),
choices = unique(stock_prices_tbl[stock_prices_tbl$class %in% input$class,]$symbol),
selected = unique(stock_prices_tbl[stock_prices_tbl$class %in% input$class,]$symbol),
multiple = TRUE,
options = list(
`actions-box` = TRUE,
size = 10,
`selected-text-format` = "count",
`live-search` = TRUE
))
})
br()
hr()
br()
shiny::actionButton(inputId = "apply",label = "Apply",icon = shiny::icon("play"))
# Resetting app to default values:
actionButton(inputId = "reset", label = "Reset", icon = shiny::icon("sync"))
observeEvent(eventExpr = input$reset, handlerExpr = {
updateCheckboxGroupButtons(
session = session,
inputId = "class",
selected = unique(stock_prices_tbl$class))
updatePickerInput(
session = session,
inputId = "symbol",
selected = unique(stock_prices_tbl$symbol))
updateDateRangeInput(
session = session,
inputId = "date_range",
start = min(stock_prices_tbl$date),
end = max(stock_prices_tbl$date))
# We'll need to mimic a click when resetting our app to defaults
shinyjs::delay(ms = 300,expr = {shinyjs::click(
id = "apply" # The input id that you want to enforce when resetting to defaults
)
})
})
# Delay Reactions
stocks_reactive <- shiny::eventReactive(eventExpr = input$apply ,valueExpr = {
stock_prices_tbl %>%
filter(
between(date,input$date_range[1],input$date_range[2]) &
class %in% input$class &
symbol %in% input$symbol
)
},ignoreNULL = F, ignoreInit = F)
Column {data-width=1000}
---
renderPrint(expr = {stocks_reactive()})

How to render dynamic UIs based on user selection with shiny

Given the set of shiny UIs and their differings arguments (to be read from a rdf, here given as explicit lists) how can the user select a desired type of input (for a data-model with many different inputs, all presetted with defaults) to be changed?
library(shiny)
library(shinyWidgets)
library(DT)
library(purrr)
library(dplyr)
library(data.table)
#-----------------someWidgetsAndArguments-------------------.
inputWidget <- list("selectInput", "sliderInput", "textInput", "numericInput")
inpWidgArgs <- list(list(inputId = "inpUI01", label = "seInp01", choices = "seq(1,20,1)", selected = 10),
list(inputId = "inpUI02", label = "slInp02", min= 0, max = 100, value = "c(25,75)" ),
list(inputId = "inpUI03", label = "txInp03", value = "enter some text"),
list(inputId = "inpUI04", label = "nrInp04", value = 1000000) )
#----------------presetPickerInput---------------------
if (interactive()) {
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
pickerInput(inputId = "pkInp01",
label = "Select CF-Model Inputs for change",
choices = inputWidget,
selected = inputWidget[1:2],
multiple = TRUE,
options = list(`actions-box` = TRUE,
`selected-text-format`= "count",
`count-selected-text` = "{0} inputs of {1} selected") ),
uiOutput("inpUI"),
),
mainPanel(
dataTableOutput("table01")
)
)
)
#-----------------generateArguments4invoke_map---------------------------.
server <- function(input, output, session) {
#B: obs <- reactiveValues(
#A: pckdWdgt <- inputWidget[match(input$pkInp01, inputWidget)],
#A: wdgtArgs <- inpWidgArgs[match(input$pkInp01, inputWidget)]
#B: )
#B: observe({
#B: obs$pW01 = inputWidget[match(input$pkInp01, inputWidget)]
#B: obs$wA02 = inpWidgArgs[match(input$pkInp01, inputWidget)]
#B: })
#------------------renderAsManyInputUisAsPicked------------
output$inpUI <- renderUI({
#A: invoke_map(match.fun(pckdWdgt), wdgtArgs)
#B: invoke_map(match.fun(obs$pW01), obs$WA02)
invoke_map(list(selectInput, sliderInput), list(
list(inputId = "inpUI01", label = "selectInput01", choices = seq(1,20,1), selected = 10),
list(inputId = "inpUI02", label = "sliderInput02", min= 0, max = 100, value = c(25,75) )
)
)
})
}
}
#-----------------------------------------------------
shinyApp(ui, server)
With map() or invoke_map() it should be possible to pass the type of function/UIinput and its arguments (compare: https://hadley.shinyapps.io/ms-render-palette-full).
Two approaches (A: and B:) below fail (possible reason: environment/namespace?) Any suggestion highly appreciated.
Many thanks in advance
I cleaned some of your code and created the solution. To start a few minor things: The choices argument in seInp01 shouldn't be between quotations. The same goes for the value argument in slInp01. Lastly there is a trailing comma behind your uiOutput argument in the UI. For the functionality of the code I just put some codes that you already came up with in the right place, you had the right idea.
The code:
library(shiny)
library(shinyWidgets)
library(DT)
library(purrr)
library(dplyr)
library(data.table)
#-----------------someWidgetsAndArguments-------------------.
inputWidget <- list("selectInput", "sliderInput", "textInput", "numericInput")
inpWidgArgs <- list(list(inputId = "inpUI01", label = "seInp01", choices = seq(1,20,1), selected = 10),
list(inputId = "inpUI02", label = "slInp02", min= 0, max = 100, value = c(25,75) ),
list(inputId = "inpUI03", label = "txInp03", value = "enter some text"),
list(inputId = "inpUI04", label = "nrInp04", value = 1000000) )
#----------------presetPickerInput---------------------
if (interactive()) {
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
pickerInput(inputId = "pkInp01",
label = "Select CF-Model Inputs for change",
choices = inputWidget,
selected = inputWidget[1:2],
multiple = TRUE,
options = list(`actions-box` = TRUE,
`selected-text-format`= "count",
`count-selected-text` = "{0} inputs of {1} selected") ),
uiOutput("inpUI")
),
mainPanel(
dataTableOutput("table01")
)
)
)
#-----------------generateArguments4invoke_map---------------------------.
server <- function(input, output, session) {
#------------------renderAsManyInputUisAsPicked------------
output$inpUI <- renderUI({
wdgtArgs <- inpWidgArgs[match(input$pkInp01, inputWidget)]
invoke_map(input$pkInp01, wdgtArgs)
})
}
}
#-----------------------------------------------------
shinyApp(ui, server)

Resources