RenderUI with conditional selectInput that dynamically builds more selectInputs in Shiny - r

I am trying to build a Shiny interface with:
a main selector, which decides:
which submenu (input) to show, which decides:
how many subsequent inputs to show
Here's a minimal reproducible example.
If "First" is chosen from the main selector, then a submenu with two possibilities [1,2] exist. These possibilities result in 1 or 2 subsequent inputs being built. So these possibilities:
If "Second" is chosen from the main selector, then a submenu with two possibilities [3,4] exist. These possibilities result in 3 or 4 subsequent inputs being built.
ui <- fluidPage(
radioButtons(inputId="main_selector",label=h5('Select menu'),
choices = list('First','Second'),selected='First'),
uiOutput("ui_selected")
)
server <- function(input, output, session) {
build_inputs <- function(choices){
output = tagList()
for(i in 1:choices){
output[[i]] = tagList()
output[[i]][[1]] = numericInput(inputId = paste0(i),
label = paste0(i),
value = i)
}
}
# Are these reactive elements necessary? Should they be in the renderUI below?
first_submenu <- reactive({
input$first_submenu
})
second_submenu <- reactive({
input$second_submenu
})
output$ui_selected <- renderUI({
if (input$main_selector == 'First'){
selectInput(inputId = "first_submenu", label="First submenu",
choices=list(1,2))
choices_1 <- first_submenu()
# Build a list of inputs dependent on the choice above
output <- build_inputs(choices_1)
} else if (input$main_selector == 'Second'){
selectInput(inputId = "second_submenu", label="Second submenu",
choices=list(3,4))
choices_2 <- second_submenu()
# Build a list of inputs dependent on the choice above
output <- build_inputs(choices_2)
# Return output as output$ui_selected element
output
})
}
shinyApp(ui, server)
The error I receive is Warning: Error in :: argument of length 0. I believe this is because you can't call the outcome of first_submenu from the renderUI element - but I don't know how to structure my code correctly.

I am not sure whether this is what you are after. The main problem was that your function build_inputs does not return anything. The second problem is that choices from selectInput are not numeric, so you need to convert them beforehand. And one other minor problem, related to the error you mention, is that the elements you want to render exist at the same time, so putting a condition on input$first_submenu will trigger errors (even if it is NULL for a couple of milliseconds), so it's (almost always) good practice to take care of possibly null inputs. The last thing I did was to add another uiOutput for the last layer of dynamic inputs. Hope this helps.
ui <- fluidPage(
radioButtons(inputId="main_selector",label=h5('Select menu'),
choices = list('First','Second'),selected='First'),
uiOutput("ui_selected"),
uiOutput("ui_numeric_inputs")
)
server <- function(input, output, session) {
build_inputs <- function(choices) {
output = tagList()
for(i in 1:choices){
output[[i]] = tagList()
output[[i]][[1]] = numericInput(inputId = paste0(i),
label = paste0(i),
value = i)
}
return(output)
}
output$ui_selected <- renderUI({
if (input$main_selector == 'First'){
selectInput(inputId = "first_submenu", label="First submenu",
choices=c(1,2))
} else if (input$main_selector == 'Second'){
selectInput(inputId = "second_submenu", label="Second submenu",
choices=list(3,4))
}
})
output$ui_numeric_inputs <- renderUI({
if (input$main_selector == 'First' &&
(!is.null(input$first_submenu))) {
build_inputs(as.numeric(input$first_submenu))
} else if (input$main_selector == 'Second' &&
(!is.null(input$second_submenu))){
build_inputs(as.numeric(input$second_submenu))
}
})
}
shinyApp(ui, server)

Related

Reactive value does not update when input is first generated

I'm currently trying to develop a large application using modules. One of those module is used to filter a dataset where the user can first select the columns he wants to filter. Once he selects the columns, the user can then select the values for each column.
As it is a two steps process, the option to select the values is not available while no columns have been chosen.
Now, my issue is that when the selectInput used to select values is first generated its value on the server side does not seem to update to the default selection.
Here's an example of what I'm trying to do:
Module UI
filter_ui <- function(id){
ns <- NS(id)
tagList(
uiOutput(outputId = ns("filter")),
uiOutput(outputId = ns("value"))
)
}
Module Server
filter_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
mod_values <- reactiveValues()
output$filter <- renderUI({
selectInput(inputId = ns("filter"),
label = "Filter",
multiple = TRUE,
selected = NULL,
choices = list("variable_a",
"variable_b",
"variable_c"))
})
observeEvent(input$filter, {
output$value <- renderUI({
lapply(input$filter, function(i){
selectInput(inputId = ns(i),
label = paste0("Select ",i),
multiple = FALSE,
choices = list("1",
"2",
"3"))
})
})
mod_values$filter <- input$filter
for (j in input$filter) {
mod_values$values[[paste0(j)]] <- input[[paste0(j)]]
}
})
return(mod_values)
})
}
The reason why I'm using uiOutput instead of just a regular selectInput in the UI is because in the application there are other arguments that will influence what is rendered.
App
ui <- function() {
fluidPage(
filter_ui("filter")
)
}
server <- function(input, output, session) {
filter_value <- filter_server("filter")
variable <- reactive({filter_value$filter})
value <- reactive({filter_value$values})
observeEvent(variable(), {
print(value())
print(variable())
req(value())
n <- 0
for (i in variable()) {
n <- n + 1
print(paste0("the ", n, "th loop value is ", value()[[i]]))
}
})
}
shinyApp(ui, server)
Now, the first time I select any filter the value does not update and I get for example:
[1] "variable_a" "variable_c"
[1] "the 1th loop value is 1"
[1] "the 2th loop value is "
While I need:
[1] "variable_a" "variable_c"
[1] "the 1th loop value is 1"
[1] "the 2th loop value is 1"
I guess my issue comes from a wrong use of reactivity but I can't seem to find what. Any help would be greatly appreciated!

How to add warnings to UI outputs generated dynamically in Shiny

I am working on a shiny app that can generate a determined number of UI outputs in form of inputs based on a value defined by the user. Thanks to the help of #YBS I was able to get the app working. But now I face a new issue. Although I could define min and max value for the inputs generated, I would like to add a warning in the inputs when a value is greater than 100, I found shinyfeedback package can do this but I do not where to put properly the code or what to do in the case of dynamic inputs like the ones generated here.
This is the working app:
library(shiny)
library(shinydashboard)
library(DT)
library(shinyFeedback)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 100, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
uiOutput("t1")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = i+i)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
observeEvent(input$submit, {
lapply(1:(input$numitems), function(i) {
output[[paste0("table",i)]] <- renderDT(seldates$x[[i]])
})
output$t1 <- renderUI({
tagList(
lapply(1:(input$numitems), function(i) {
DTOutput(paste0("table",i))
})
)
})
})
})
shinyApp(ui = ui , server = server)
I tried to add some code inside the dynamic inputs in this way:
#Code demo
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
lapply(1:(input$numitems), function(i) {
observeEvent(input[[paste0('firstitem',i)]], {
shinyFeedback::feedbackWarning(
inputId = paste0('firstitem',i),
show = input[[paste0('firstitem',i)]] > 100,
text = "Number less than 100 required.",
color="red"
)
})
})
})
Unfortunately, this action broke down the app:
And the first input was not generated as you can see.
How can I solve this issue so that I can have warnings when the value is greater than 100? Moreover, this leads to an additional fact, in the action button if working with multiple inputs generated dynamically, how could I do something like this:
#How to extend the if condition so that it can consider the number of inputs defined by the user
observeEvent(input$submit,
{
if(input$firstitem1 < 0 && input$seconditem1 < 0 && input$firstitem2<0 && input$seconditem1<0)
{
showModal(modalDialog(title ="Warning!!!", "Check fields!!!",easyClose = T))
}
else
{
showModal(modalDialog(title ="Congratulations!!!", "Computing Done!!!",easyClose = T))
}
})
How could I change the if so that it considers all the inputs that can be generated.
Many thanks!
I think you have a couple of problems here.
First, you have forgotten to add useShinyFeedback() to your UI definition.
ui = shinyUI(
fluidPage(
useShinyFeedback(),
titlePanel("Compare"),
...
Second, you've put the observeEvents that monitor your first item values inside your renderUI. That's not going to work: R's standard scoping means that these observeEvents won't be available to monitor changes in the corresponding input widgets. The solution is to create a separate observeEvent to create your observers on the inputs:
observeEvent(input$numitems, {
lapply(1:(input$numitems), function(i) {
observeEvent(input[[paste0('firstitem',i)]], {
shinyFeedback::feedbackWarning(
inputId = paste0('firstitem',i),
show = input[[paste0('firstitem',i)]] > 100,
text = "Number less than 100 required.",
color="red"
)
})
})
})
Making these changes gives me, for example,
With regard to your final question about the Submit actionButton, and as a general observation, I think your life will be much easier if you use Shiny modules to solve this problem. This will allow you to delegate the error checking to the indivudual modules and remove the need to continually loop through the indices of the dynamic inputs. This will lead to shorter, simpler, and more understandable code.
One thing to bear in mind if you do this: make sure you put a call to useShinyFeedback in the definition of the module UI.

selectizeInput filter all other menus based on the selection from another menu (every time a selection is made)

I have data that looks something like the data set Orange where there are columns that might contain duplicate values, however, each row is unique.
My code:
library(shiny)
library(DT)
library(data.table)
d <- copy(Orange)
col_names <- names(Orange)
user_friendly_names <- c('TreeNumber', 'TreeAge', 'Circumference')
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
h3("Filters:"),
uiOutput("filters"),
# Plot button
fluidRow(column(2, align = "right",
actionButton("plot_graph_button", "Plot")))
),
mainPanel(tableOutput("summary"))
)
)
server <- function(input, output) {
#### Create the filter lists for UI ####
output$filters <- renderUI({
if(is.null(col_names)) return(NULL)
lapply(1:length(col_names), function(i) {
col <- paste0(col_names[i])
alias <- user_friendly_names[i]
# Populate input with unique values from column
selectizeInput(inputId = alias, label = paste(alias,':'),
choices = c('All', unique(d[[col]])), selected = 'All', multiple = T)
})
})
output$summary <- renderTable({
# Do not show a plot when the page first loads
# Wait until the user clicks "Plot" button
if (input$plot_graph_button == 0){
return()
}
# Update code below everytime the "Plot" button is clicked
input$plot_graph_button
isolate({
# Fresh copy of the full data set every time "Plot" button is clicked
d <- copy(Orange)
# Filter data based on UI
for(f in 1:length(col_names)){
print(paste("This is loop # ", f))
if(eval(parse(text = paste0('is.null(input$',user_friendly_names[f],')')))){
# If the user deleted "All" but failed to pick anything else default to "All" - do not filter
break
}else{
if(eval(parse(text = paste0('input$',user_friendly_names[f]))) != "All"){
print("FALSE -- Input is not == ALL")
d <- d[d[[col_names[f]]] == unlist(eval(parse(text = paste0('input$',user_friendly_names[f])))), ]
}else{
print("TRUE -- Input is defaulted to ALL")
}
}
}
final_summary_table <<- d
})
})
}
shinyApp(ui = ui, server = server)
My issue is that these lists are able to select multiple inputs (which I want), however, I want to initially show all available choices in all menus (which it currently does) but what I need to change is I need to have it start filtering the other lists as soon as a selection is made (no matter which list the user goes to first) based on that unique rowed data set provided.
So, if the user goes to the 2nd list and chooses tree age of 1004 then the TreeNumber menu should change to c(1, 2, 3, 4, 5) - no change in this scenario but the Circumference menu should change to c(115, 156, 108, 167, 125), then if they pick a TreeAge now the menus get filtered down by both TreeAge and TreeNumber and so on.
Right now the way the code works is it doesn't filter anything until you click "Plot", so the user might think a search will yield a bunch of results, when in reality the combination may not exist.
Here is a good example of a search that you may expect to yield a lot of results, yet it only yields 1 row:
Please note: If you do not delete 'All' it will return 'All' even if you selected other options, it is a flaw in the code that I plan to address separately along with some other minor tweaks.
I also wanted to mention that I found this post Filter one selectInput based on selection from another selectInput? which is similar to mine, however, they are dealing with menus in a top-down approach and mine is going to be more flexible about which menu the user goes to first (also mine allows multiple selections).
server <- function(input, output, session) {
output$filters <- renderUI({
# ...
})
lapply(seq_along(d), function(i) {
observeEvent(input[[user_friendly_names[i]]], {
for (j in seq_along(d)[-i]) {
choices <- if ("All" %in% input[[user_friendly_names[i]]])
unique(d[[j]]) else
unique(d[[j]][d[[i]] %in% input[[user_friendly_names[i]]]])
choices <- c("All", choices)
selected <- intersect(choices, input[[user_friendly_names[j]]])
updateSelectInput(session = session, inputId = user_friendly_names[j],
choices = choices, selected = selected)
}
})
})
observeEvent(input$plot_graph_button, {
for (j in seq_along(d)) {
updateSelectInput(session = session, inputId = user_friendly_names[j],
choices = c("All", unique(d[[j]])), selected = "All")
}
})
output$summary <- renderTable({
# ...
})
}

using a function to renderUI(selectInput()) in Shiny app

Here's server.r
server <- function(input, output) {
output$species <- renderUI({
selectInput("species",
label = "blah",
choices = as.list(unique(iris$Species)))
})
}
Then over in ui.r
ui <- fluidPage(
fluidRow(
uiOutput("species")
)
This works as expected, a drop down select input appears like this:
Since I have multiple features I need to create a similar filter for in my actual data frame, I tried to do the same with a function:
In server.r
outputFilters <- function(id, df) {
output$id <- renderUI({
selectInput(id,
label = "blah",
choices = as.list(unique(df$id)))
})
}
outputFilters("species", iris)
Then in ui.r same as before uiOutput("species")
However, now no drop down appears. Presumably my function is flawed. How can I use a function to generate the drop downs?
Note that you could also do without a separate function in this case, by wrapping the desired ui component in lapply, or putting the lapply within the uiOutput to create all inputs at once, below is an example for the both two cases. Hope this helps!
ibrary(shiny)
ui <- fluidPage(
uiOutput('Species'),
uiOutput('Sepal.Length'),
h2('All inputs: '),
uiOutput('my_inputs')
)
server <- function(input, output) {
# Use lapply to create multiple uiOutputs.
lapply(colnames(iris), function(x){
output[[x]] <- renderUI({
selectInput(paste0('input_',x),
label = x,
choices = as.list(unique(iris[['x']])))
})
})
# Create all dropdown's at once.
output$my_inputs <- renderUI({
lapply(colnames(iris), function(x){
selectInput(paste0('input_',x),
label = x,
choices = as.list(unique(iris)))
})
})
}
shinyApp(ui, server)
Your problem is that each UI element needs its own id in the output
outputFilters <- function(id, df) {
output[[id]] <- renderUI({
selectInput(id,
label = "blah",
choices = as.list(unique(df[[id]])))
})
}
now as long as id is a string in the function input it should generate the output element and you can refer with said id
You could then even use lapply to iterate over numerous, kind of how florian suggests.

Extracting values of input widgets after updating dynamic UI using renderUI()

I have successfully updated UI dynamically through renderUI(). I have a long list of inputs to choose from. The check boxes are used to dynamically add numeric inputs. So, to implement this, I used lapply. However, I have used values of selected check boxes in checkboxgroup itself to populate IDs of the dynamically added numerical input instead of using paste(input, i) in lapply.
ui code snippet :
checkboxGroupInput(inputId = "checkboxgrp", label = "Select types",
choices = list("ELECTAPP","NB W $","PUR","MANUAL LTR","REDEMPTION","NB W TRANSFER","NB WOUT $","OUTPUT")),
...
fluidRow(column(12, verbatimTextOutput("value")))
...
uiOutput("numerics")
server code snippet :
renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
lapply(1:numInputs, function(i){
x[i]=input$checkboxgrp[i]
list(numericInput(input$checkboxgrp[i], min = 0, label = input$checkboxgrp[i],
value= input[[x[i]]] ))
})
}
})
output$value <- renderPrint({
numInputs <- length(input$checkboxgrp)
lapply(1:numInputs, function(i){
print(input[[x[i]]]) ## ERROR
})
})
I have used input[[x[i]]] as to instantiate value to be retained after adding or removing a numeric input. But, I want to extract values from input$x[i] or input[[x[i]]] into a vector for further use which I'm unable to do.
*ERROR:Must use single string to index into reactivevalues
Any help is appreciated.
EDIT
using 3 different ways of extracting values from input generate 3 different errors:
Using print(input$x[i]) # ERROR
NULL
NULL
NULL
NULL
[[1]]
NULL
[[2]]
NULL
[[3]]
NULL
[[4]]
NULL
Using print(input[[x[i]]]) # ERROR
Must use single string to index into reactivevalues
Using print('$'(input, x[i])) # ERROR
invalid subscript type 'language'
If I understand you correctly, you want to access values of dynamically generated widgets and then just print them out.
In my example below, which should be easy to generalise, the choices are the levels of the variable Setosa from the iris dataset.
The IDs of the generated widgets are always given by the selected values in checkboxGroupInput. So, input$checkboxgrp says to shiny for which level of setosa there should be generated a widget. At the same time input$checkboxgrp gives IDs of generated widgets. That's why you don't need to store the IDs of "active" widgets in other variable x (which is probably a reactive value).
To print the values out you can do the following:
output$value <- renderPrint({
activeWidgets <- input$checkboxgrp
for (i in activeWidgets) {
print(paste0(i, " = ", input[[i]]))
}
})
This line print(input[[x[i]]]) ## ERROR yields an error because x[i] (whatever it is) is not a vector with a single value but with multiple values.
Full example:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkboxgrp", "levels", levels(iris$Species))
),
mainPanel(
fluidRow(
column(6, uiOutput("dynamic")),
column(6, verbatimTextOutput("value"))
)
)
)
)
server <- function(input, output) {
output$dynamic <- renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
lapply(1:numInputs, function(i){
x[i]=input$checkboxgrp[i]
list(numericInput(input$checkboxgrp[i], min = 0, label = input$checkboxgrp[i],
value= input[[x[i]]] ))
})
}
})
output$value <- renderPrint({
activeWidgets <- input$checkboxgrp
for (i in activeWidgets) {
print(paste0(i, " = ", input[[i]]))
}
})
}
shinyApp(ui = ui, server = server)
Edit:
You could tweak the lapply part a little bit (mind <<- operator :) )
else{
activeWidgets <- input$checkboxgrp
val <- 0
lapply(activeWidgets, function(i){
val <<- val + 1
list(numericInput(i, min = 0, label = i,
value = val ))
})
}
Edit 2 In response to a comment:
server <- function(input, output) {
output$dynamic <- renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
activeWidgets <- input$checkboxgrp
val <- 0
lapply(activeWidgets, function(i){
val <<- val + 1
list(numericInput(i, min = 0, label = i,
value = val ))
})
}
})
allChoices <- reactive({
# Require that all input$checkboxgrp and
# the last generated numericInput are available.
# (If the last generated numericInput is available (is not NULL),
# then all previous are available too)
# "eval(parse(text = paste0("input$", input$checkboxgrp))))" yields
# a value of the last generated numericInput.
# In this way we avoid multiple re-evaulation of allChoices()
# and errors
req(input$checkboxgrp, eval(parse(text = paste0("input$", input$checkboxgrp))))
activeWidgets <- input$checkboxgrp
res <- numeric(length(activeWidgets))
names(res) <- activeWidgets
for (i in activeWidgets) {
res[i] <- input[[i]]
}
res
})
output$value <- renderPrint({
print(allChoices())
})
}

Resources