How to use an input created in renderUI into a reactive function in R Shiny?
You could require that input$server2 is defined and has a valid value before using it further:
d1 <- reactive({
if(input$slider0 == "Yes"){
# Make sure that input$slider2 is ready to be used
req(input$slider2)
# Will be executed as soon as above requirement is fulfilled
d0 %>%
mutate(C3= first_column*input$slider2)
} else {d0 }
})
renderUI with reactive value
First of all, please try to include a fully functioning example in future, with a complete shiny-app and some data. Otherwise your question will probably be downvoted and maybe not answered at all.
There is no function ReactiveValues, it should start with lower case r -> reactiveValues.
To hide the printed NULL, you can use req().
See the following example:
library(shiny)
ui <- fluidPage(
uiOutput("fcomparisons"),
actionButton("go", "setValues"),
actionButton("go1", "setNULL"),
verbatimTextOutput("printValues")
)
server <- function(input, output){
values = reactiveValues(myresults=NULL)
output$fcomparisons <- renderUI({
selectInput("comparisons",label="Select comparisons",
choices = values$myresults)
})
observeEvent(input$go, {
values$myresults <- sample(1:20, 5, T)
})
observeEvent(input$go1, {
values$myresults <- NULL
})
output$printValues <- renderPrint({
req(values$myresults)
values$myresults
})
}
shinyApp(ui, server)
Shiny: How to take a reactive input generated from renderUI as input in a function?
@Morten, I'm not very experienced with sapply, but I wanted to give it a go.
I failed after 2 hours to get anything useful out of sapply structures, but I did provide you with 2 alternative solutions. There is some explanation in the code below in comments
the problem I ran into with sapply is that I either get list() or the names of the inputs printed instead of their values.
Normally I would uses eval(parse(text = 'name of input here')) to process input names presented as string rather than code form, but for this case of using it inside an apply function seems to elude me why it doesn't work.
Anyway, below there is an approach with either lapply over the input names, or by collecting the results in a reactiveVariable, i.e. a list that holds all T/F values of all your checkboxes per group.
list_of_names <- tibble("Name" = c("Name1", "Name2", "Name3"),
"0 pt" = c("Criteria 0 name1", "Criteria 0 name2", "Criteria 0 name3"),
"1 pt" = c("Criteria 1 name1", "Criteria 1 name2", "Criteria 1 name3"),
"2 pt" = c("Criteria 2 name1", "Criteria 2 name2", "Criteria 2 name3"))
vectorx <- c('input$Name1_id', 'input$Name2_id', 'input$Name3_id')
listx <- sapply(sapply(1:3, function(i) { paste0("input$Name", i, "_id")}),function(x) NULL)
mycollapse <- lapply(1:nrow(list_of_names), function(i) {
bsCollapsePanel(paste0(list_of_names$Name[i]),
awesomeCheckboxGroup(inputId = paste0(list_of_names$Name[i], "_id"),label = NULL,
choices = as.character(list_of_names[i,2:4]),
status = "success", width = "75%"))
})
mycollapse[["id"]] <- "collapseID"
mycollapse[["multiple"]] <- FALSE
mycollapse[["open"]] <- "Name1"
#### UI ----------
ui <- dashboardPage(
dashboardHeader(title = "Minimal Example"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "Dashboard", icon = icon("dashboard"),
selected = TRUE))),
dashboardBody(
fluidPage(
column(6, shinyjs::useShinyjs(), withSpinner(uiOutput("Data"))))))
server <- function(input, output, session) {
#approach 1 make a reactive list to store the inputs
values <- reactiveValues(mylist = list())
output$Data <- renderUI({
tagList(
do.call(bsCollapse, args = mycollapse) %>% return(),
actionButton("Save", "Save"))
})
#approach 1 observe changes in the inputs (including deselect of all, which would not work if you use observeEvent as it does not fire if all boxes are FALSE)
observe({ lapply(1:3, function(i) {
values$mylist[[paste0('Name', i, '_id', sep = '')]] <- input[[paste0('Name', i, '_id', sep = '')]]
})
})
####################
observeEvent(input$Save, {
confirmSweetAlert(session, inputId = "Save_SWAL", title =
"Save?", text = "Are you sure?",
type = "warning", danger_mode = TRUE, btn_labels = c("Cancel", "Yes, save please"))
})
observeEvent(input$Save_SWAL, {
if (isTRUE(input$Save_SWAL)) {
#approach 1 simply print the minimums in the reactive list
print("#approach 1")
print(sapply(values$mylist, min) )
##### I tried for over 1.5 hour, but I could not get an sapply block working on strings called "input$Name1_id" etc
## normally I would use eval(parse(text = 'input$Name1_id')) to read what the input is, but for some reason it will not work with a list of names
## This makes a named yet empty list for instance:
## listx <- sapply(sapply(1:3, function(i) { paste0("input$Name", i, "_id")}),function(x) NULL)
## with the idea that I could then try to sapply over the names with eval(parse()) construct, but it doesn't return the minimums
# keeps printing empty 'list()'
# print(sapply(eval(parse(text = names(listx))), min))
##this keeps printing the names of vectorx
# print(sapply(vectorx, min))
#approach 2 run an lapply over all the inputs without the need to store them
print("#approach 2")
lapply(1:3, function(i) {
if(!!length(input[[paste0('Name', i, '_id', sep = '')]])) { ## !!length means it is NOT an empty list, so then we want the min
min(input[[paste0('Name', i, '_id', sep = '')]]) %>% print()
}
})
}
})
}
shinyApp(ui, server)
Update renderPlot() with reactive value inside renderUI()
The easiest solution is to just move the renderPlot from the renderUI function and instead define plot <- renderPlot({ggplot...})
Code below:
library(shiny)
library(ggplot2)
ui <- basicPage(
actionButton("launch", "Launch"),
uiOutput("plotInteractive")
)
server <- function(input, output, session) {
observeEvent(input$launch, {
bins <- reactive({input$binsize})
plot <- renderPlot({
ggplot(diamonds, aes(y = carat)) +
geom_histogram(bins = bins())
})
output$plotInteractive <- renderUI ({
tagList(
plot,
sliderInput(inputId = "binsize", label = "Bin Size", min = 1, max = 40, value = 20)
)
}) #end UI
}) #end run
} #end server
shinyApp(ui, server)
R-Shiny using Reactive renderUI value
You would refer to the elements by their id for example input$compName. As a contrived example here
is a simple shiny app with two selectInput's. The second selectInput choices depend on the value of the first. Referencing the output of widgets created by renderUI is no different from referencing the same widgets if they had been in UI.R from the beginning:
library(shiny)
myDF <- data.frame(A = 1:4, B = 3:6, C = 6:9, D = 10:13)
runApp(
list(
ui = fluidPage(
uiOutput("myList"),
uiOutput("myNumbers")
)
, server = function(input, output, session){
output$myList <- renderUI({
selectInput("compName", "Company Name:", LETTERS[1:4])
})
output$myNumbers <- renderUI({
selectInput("compNo", "Product Line:", myDF[, input$compName])
})
}
)
)
Shiny Reactive renderUI and multiple dependent / coupled inputs
Here is a the code in which I have removed the reactive expression from and used a local variable selected_data instead.
observeEvent(input$submit_request_button, {
# selected_data <- reactive({
# browser()
selected_data <- NULL
if( input$multiple_choice_1_source =="db1"){
selected_data <- mtcars
} else if ( input$multiple_choice_1_source == "db1") {
selected_data <- diamonds
} else if ( input$multiple_choice_1_source == "db3") { selected_data <- NULL
} else if ( input$multiple_choice_1_source == "db4"){selected_data <- NULL
}
# })
user_input_rv$series_picked <- isolate(input$multiple_choice_2_type)
user_input_rv$selected_data <- selected_data
min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data)))
#print(max_cols)
#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({
lapply(min_cols:max_cols, function(z) {
column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(isolate(input$multiple_choice_2_type),": ",colnames(selected_data)[z]),
choices = unique(selected_data[[z]]),
multiple = TRUE
) #selectizeInput
)
})#lapply inner
}) #renderUI for columns
}) #third observeEvent for data selection and customisation
Now when you change the select input options the ColnamesInput do not get triggered. It gets triggered only after you click the submit button.
[EDIT]:
Might not be the best method, but I think I am able to achieve what you wanted. Also, I have taken the liberty on using the reactiveValue that was already defined in your server. Have a look at the modified server code below:
server <- function(input, output)
{
user_input_rv = reactiveValues(
source_picked = NULL,
last_used_source = NULL,
type_picked = NULL,
series_picked = NULL,
last_used_series = NULL,
selected_data = NULL,
final_selection = NULL
)
observeEvent(input$multiple_choice_1_source, {
user_input_rv$source_picked <- input$multiple_choice_1_source
###Start: To check if the source changed#########
if(!is.null(user_input_rv$last_used_source))
{
if(user_input_rv$last_used_source != user_input_rv$source_picked)
{
shinyjs::hide("ColnamesInput")
user_input_rv$last_used_source = user_input_rv$source_picked
}
}else
{
user_input_rv$last_used_source = user_input_rv$source_picked
}
###End: To check if the source changed#########
#change data loaded under type picked.
user_input_rv$type_picked <-
if ( input$multiple_choice_1_source == "db1"){ paste0(colnames(mtcars))
} else if ( input$multiple_choice_1_source == "db2"){ paste0(colnames(diamonds))
} else if ( input$multiple_choice_1_source == "db3"){ NULL
} else if ( input$multiple_choice_1_source == "db4"){ NULL
}
output$multiple_choice_2_type_ui <- renderUI({
selectizeInput( inputId = 'multiple_choice_2_type',
choices = paste(user_input_rv$type_picked),
label= "2. Select type",
multiple = TRUE,
size = 10,
width = '100%',
options = list( placeholder = 'Type',
maxItems =1
)
)
})
}) #first observeEvent for source type and data load.
observeEvent(input$multiple_choice_2_type,{
###Start: To check if the series changed#########
user_input_rv$series_picked <- input$multiple_choice_2_type
if(!is.null(user_input_rv$last_used_series))
{
if(user_input_rv$last_used_series != user_input_rv$series_picked)
{
shinyjs::hide("ColnamesInput")
user_input_rv$last_used_series = user_input_rv$series_picked
}
}else
{
user_input_rv$last_used_series = user_input_rv$series_picked
}
###End: To check if the series changed#########
output$submit_request_button_ui <- renderUI({
actionButton(
inputId = "submit_request_button",
label = " Get data "
)
})
})#second observeEvent for submit_request_button_ui
observeEvent(input$submit_request_button, {
# selected_data <- reactive({
# browser()
shinyjs::show("ColnamesInput")
selected_data <- NULL
if( input$multiple_choice_1_source =="db1"){
selected_data <- mtcars
} else if ( input$multiple_choice_1_source == "db1") {
selected_data <- diamonds
} else if ( input$multiple_choice_1_source == "db3") { selected_data <- NULL
} else if ( input$multiple_choice_1_source == "db4"){selected_data <- NULL
}
# })
user_input_rv$series_picked <- isolate(input$multiple_choice_2_type)
user_input_rv$selected_data <- selected_data
min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data)))
#print(max_cols)
#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({
lapply(min_cols:max_cols, function(z) {
column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(isolate(input$multiple_choice_2_type),": ",colnames(selected_data)[z]),
choices = unique(selected_data[[z]]),
multiple = TRUE
) #selectizeInput
)
})#lapply inner
}) #renderUI for columns
}) #third observeEvent for data selection and customisation
}
Hope it helps!
Possible to nest outputUI and renderUI in R shiny?
Yes, it is possible to nest outputUI/renderUI in R shiny. Resolved code below does this. See how output$Vectors is nested inside of output$Panels, both using renderUI in the server section.
The objective of all this moving around of code was to eliminate the rapid flashing of all ui items when first invoking the App, making it appear sloppy, buggy, unprofessional. The moving of conditional panels from the ui to the server section, using outputUI in the ui section of code and renderUI in the server section, has eliminated the flashing-by of all ui items when first invoking the App.
Below is the final resolved code. The "crashing code" above didn't work because the conditional panels, in the renderUI section under server, needed to be wrapped in tagList as shown below. An accidental omission. Also, the above crashing code was also crashing because the observeEvent for updateMatrixInput also needed to wrapped in renderUI (with respect to this last item, I'm not sure why this worked - I came by it through trial and error and a hunch. I hope this doesn't lead to another problem down the road - usually what happens when I implement a "fix" that I don't 100% understand).
library(shiny)
library(shinyMatrix)
library(shinyjs)
matrix1.input <- function(x){
matrixInput(
x,
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
vector.base <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
ui <-
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(
uiOutput("Panels")
), # close sidebar panel
mainPanel(
tabsetPanel(
tabPanel("About",value=1),
tabPanel("Dynamic",value=2,plotOutput("graph1")),
id = "tabselected"
) # close tabset panel
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods <- reactive(input$periods)
base_input <- reactive(input$base_input)
vector_input <- reactive(input$vector_input)
output$Panels <- renderUI({
tagList(
conditionalPanel(condition="input.tabselected==1"),
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','Input periods:',min=1,max=120,value=60),
matrix1.input("base_input"),
useShinyjs(),
actionButton('showPerfVectorBtn','Show'),
actionButton('hidePerfVectorBtn','Hide'),
actionButton('resetPerfVectorBtn','Reset'),
hidden(uiOutput("Vectors")),
) # close conditional panel
) # close tagList
}) # close renderUI
output$Vectors <- renderUI({
input$resetPerfVectorBtn
tagList(matrix1.input("Plot"))
}) # close render UI
# run observeEvent in renderUI
renderUI({
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,"vector_input",
value=matrix(c(input$periods,input$base_input[1,1]),1,2))})
}) # close renderUI
observeEvent(input$showPerfVectorBtn, {shinyjs::show("Vectors")})
observeEvent(input$hidePerfVectorBtn, {shinyjs::hide("Vectors")})
output$graph1 <- renderPlot(
if(input$showPerfVectorBtn == 0)
plot(vector.base(periods(),input$base_input[1,1]))
else plot(vector.base(periods(),input$base_input[1,1])))
}) # close server
shinyApp(ui, server)
Related Topics
How to Request an Early Exit When Knitting an Rmd Document
Time-Series - Data Splitting and Model Evaluation
Override Column Types When Importing Data Using Readr::Read_Csv() When There Are Many Columns
Choosing Eps and Minpts for Dbscan (R)
Sort Matrix According to First Column in R
Filtering Observations in Dplyr in Combination with Grepl
Shared Memory in Parallel Foreach in R
Transparent Equivalent of Given Color
How to Count How Many Values Per Level in a Given Factor
Automatic Documentation of Datasets
How to Highlight Time Ranges on a Plot
Digging into R Profiling Information
Correlation Corrplot Configuration
Replacing the "Print" Function in Knitr Chunk Evaluation
In R, Evaluate Expressions Within Vector of Strings