I am trying to create a dynamic UI based on user inputs. First, I am using an lapply inside Mod2.R to return the values of Mod1 onto Mod2 and save it in a reactiveVal object, which lives inside mod2.R and is saved as binner_step_data. The main app then also does an lapply on the return value of Mod2.R (which depends on Mod1.R) and saves it in a reactiveVal object, which is saved as binner_data.
Mod1.R
mod1_UI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
column(
width = 6,
selectInput(ns("sel_step_name"), "Step Name", choices = c("step1", "step2"))
) # Column
,
column(
width = 3,
numericInput(ns("num_threshold"), "Threshold", value = 0)
) # Column
) # Row
) # tag list
}
mod1_Server <- function(input, output, session) {
return(
list(
step_name = reactive({input$sel_step_name}),
threshold = reactive({input$num_threshold})
)
)
}
Mod2.R
mod2_UI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
column(
width = 12,
selectInput(ns("sel_n_steps"), "Number of Steps", selected = NULL, choices = 1:3),
uiOutput(ns("ui_mod1_steps"))
)
),
fluidRow(
column(
width = 12,
textInput(ns("txt_bin_name"), "Bin Name", placeholder = "Name of Bin e.g., Blocker", value = "**")
) # Column
) # Fluid Row
) # tag list
}
mod2_Server <- function(input, output, session) {
ns <- session$ns
binner_step_data <- reactiveVal()
observeEvent(input$sel_n_steps{
req(input$sel_n_steps)
lapply(
1:input$sel_n_steps,
function(i) {
res <- callModule(mod1_Server, paste0("binner_step", i), binner_number = reactive(i), dat = reactive(dat()))
return(res)
}
) %>% binner_step_data(.)
})
output$ui_mod1_steps <- renderUI({
req(input$sel_n_steps)
tagList(
fluidRow(
column(
width = 12,
lapply(
1:as.numeric(input$sel_n_steps),
function(i) {
mod1_UI(ns(paste0("binner_step_", i)))
}
) # lapply
) # Column
) # Fluid Row
) # Tag List
})
return(
list(
bin_name = reactive({input$txt_bin_name}),
bin_criteria = reactive({lapply(binner_step_data(), function(step_data) { step_data() })})
)
)
}
Here are my first two modules, in which Mod2.R is using the return values of Mod1.R. Now here's the main app.R file that is using the return value of Mod2.R.
app.R
library(shiny)
library(tidyverse)
# Modules
source("Mod1.R")
source("Mod2.R")
ui <- fluidPage(
fluidRow(
column(
width = 12,
numericInput("num_bins", "Number of Bins", value = NULL, min = 1, max = 10)
) # Column
) # Fluid Row
,
fluidRow(
column(
width = 12,
uiOutput("ui_binners")
) # Column
), # FLuid Row
fluidRow(
column(
width = 12,
verbatimTextOutput("reactive_output_from_mod2")
)
)
)
server <- function(input, output, session) {
binner_data <- reactiveVal()
# Modules -----------------------------------------------------------------
observeEvent(input$num_bins, {
req(input$num_bins)
lapply(
1:input$num_bins,
function(i) {
res <- callModule(mod2_Server, paste0("binner_", i))
return(res)
}
) %>% binner_data(.)
})
output$ui_binners <- renderUI({
req(input$num_bins)
tagList(
fluidRow(
column(
width = 12,
lapply(
1:input$num_bins,
function(i) {
mod2_UI(paste0("binner_", i))
}
) # lapply
) # Column
) # Fluid Row
) # Tag List
})
output$reactive_output_from_mod2 <- renderPrint({
# req(input$sel_n_steps)
binner_data()
})
}
shinyApp(ui, server)
At the end, I'm using a renderPrint to confirm that the values I need are getting passed to the main server but apparently they are not. I should get back a list of two, with the first element being the Bin name and the second element being the Bin Criteria (Step Name + Threshold Value). What is the best way to handle the return values from the two modules to get back the data that I need? Thanks.
To move values out of the server modules, you want the individual elements to be reactive, not the entire list. This structure at the end of BinnerStep.R should provide a list of reactive elements returned from the server module.
return(list(
step_name = reactive({input$sel_step_name}),
threshold = reactive({input$num_threshold}),
rank_direction = reactive({input$sel_rank_direction})
))
Related
I have two modules that takes the same from dateRangeInput, and therefore I want to create this input completely on the UI side, and use it globally.
However, the output does not change with the input as the MWE shows below.
UI:
library(shiny)
# Generate User Interface; ####
ui <- fluidPage(
column(
width = 2,
h1("Controls"),
p("This input should appear in both modules reactively."),
dateRangeInput(
inputId = NS(id = NULL,"daterange"),
label = "Pick Date:",
start = Sys.Date() - 8,
end = Sys.Date()
)
),
column(
width = 5,
h1("Module 1"),
p("This output should change as date range changes."),
moduleUI("mod1")
),
column(
width = 5,
h1("Module 2"),
p("This output should change as date range changes."),
moduleUI("mod2")
)
)
Server:
server <- function(input,output,server) {
# Module 1
module_1("mod1",my_input = input$daterange)
# Module 2
module_1("mod2",my_input = input$daterange)
}
The modules are created as shown below,
module_1 <- function(id, my_input = NULL) {
moduleServer(
id, function(input, output, session) {
output$userdate <- renderText(
paste(my_input)
)
}
)
}
module_2 <- function(id, my_input = NULL) {
moduleServer(
id, function(input, output, session) {
output$userdate <- renderText(
paste(my_input)
)
}
)
}
moduleUI <- function(id) {
ns <- NS(id)
textOutput(ns("userdate"))
}
It accepts the initial values, but does change according to the input.
A few points:
NS(id = NULL,"daterange") in the main app is a bit unusual, it's not wrong but in my opinion it decreases the readability, so I would just use inputId = "daterange"
input$daterange is only reactive within the main app, so you need to wrap it into a reactive to pass it to the modules
then you also have to adapt how the argument is evaluated within the modules (add brackets)
Examples with your code:
# Module 2
module_2("mod2",my_input = reactive({input$daterange)})
in the module server:
output$userdate <- renderText(
paste(my_input())
)
I have created a tutorial for modules, maybe it helps you: https://github.com/jonas-hag/structure_your_app
I'm trying to create an UI in which user can choose some objects (as many as they want) and their respective weights. The weight input fields appear only when there's more than one object and increase as the user selects more objects. This part already works.
What I need is a vector that holds all the weights saved in the w1, w2 and so on.
I've tried using for loops and sapply with get() function but can't access the input$w1, input$w2 etc.
library(shiny)
# Create list of objects
object_list <- vector()
object_list <- paste0("O_", 1:10)
names(object_list) <- paste("Object", 1:10)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic UI"),
dashboardSidebar(
width = 700,
fluidRow(
column(7, selectInput("chosen_objects", "Chosen objects", choices = object_list, multiple = TRUE, width = "100%")),
column(5, uiOutput("weights"))
)
),
dashboardBody(
fluidPage(tabBox(width=2500,
tabPanel(
title = "Table"
)
)
)
)
)
server <- function(input,output) {
objects_number <- reactive({length(input$chosen_objects)})
output$weights <- renderUI({
if (is.na(objects_number()) | objects_number() <= 1)
return(NULL)
lapply(1:objects_number(), function(i) {
id <- paste0("w", i)
textInput(id, paste("Weight of", input$chosen_objects[i]), value = input[[id]], width = "50%", placeholder = "%")
})
})
}
shinyApp(ui, server)
Is there a way to collect the dynamic inputs in one vector or list?
I have made a few changes and based on your code I think you are good enough to see and get them by yourself. Let me know if you have any questions -
library(shiny)
# Create list of objects
object_list <- vector()
object_list <- paste0("O_", 1:10)
names(object_list) <- paste("Object", 1:10)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic UI"),
dashboardSidebar(
width = 700,
fluidRow(
column(7, selectInput("chosen_objects", "Chosen objects",
choices = object_list, multiple = TRUE, width = "100%")),
column(5, uiOutput("weights"))
)
),
dashboardBody(
fluidPage(tabBox(width=2500,
tabPanel(
title = "Table",
verbatimTextOutput("weight_output")
)
)
)
)
)
server <- function(input,output) {
objects_number <- reactive({length(input$chosen_objects)})
output$weights <- renderUI({
if (is.na(objects_number()) | objects_number() <= 1)
return(NULL)
lapply(gsub("[A-Z]+_", "", input$chosen_objects), function(i) {
id <- paste0("w", i)
textInput(id, paste("Weight of", paste0("O_", i)),
value = NULL, width = "50%", placeholder = "%")
})
})
output$weight_output <- renderPrint({
req(input$chosen_objects)
sapply(paste0("w", gsub("[A-Z]+_", "", input$chosen_objects)), function(a) input[[a]])
})
}
shinyApp(ui, server)
How do I create a scrollable list of tables within a tabPanel?
Based on Outputing N tables in shiny, where N depends on the data, I have tried the following
Server.R
userHist <- list(
data.frame(X=1:10,Y=11:20),
data.frame(X=1:10,Y=11:20))
output$groupHistory <- renderUI({
userHistList <- lapply( seq(userHist), function(i){
hist_i <- userHist[[i]]
TabName <- paste0("User", i)
fluidRow( column(10,
h2(TabName),
hr(),
column(3, renderTable(hist_i, rownames=TRUE) )
) )
} )
userHistList
})
ui.R
tabsetPanel(id="tabsetpanel",
tabPanel(h1("Group History"),
style="overflow-y:scroll;",
uiOutput("groupHistory")
)
)
There is a main firefox scrollbar that shows up when the list gets long, but there is a second scrollbar for the table that does not scroll vertically. Ideally I would also eliminate horizontal scrolling.
You need to call the render first to create the output objects and the compose the UI with those objects:
ui <- fluidPage(
tabsetPanel(
id = "tabsetpanel",
tabPanel(
style = "overflow-y:scroll; max-height: 600px",
h1("Group History"),
numericInput("n_users", "Number of Users", value = 5, min = 1, max = 10),
uiOutput("group_history")
)
)
)
server <- shinyServer(function(input, output) {
df_list <- reactive({
n <- input$n_users
# generate some observations
obs_x <- seq(3)
obs_y <- obs_x + n
# generate the df
df_template <- data.frame(x = obs_x, y = obs_y)
# make a list of df and return
lapply(seq(n), function(n) {
df_template
})
})
# use the constructed renders and compose the ui
output$group_history <- renderUI({
table_output_list <- lapply(seq(input$n_users), function(i) {
table_name <- paste0("table", i)
tab_name <- paste("User", i)
fluidRow(
column(
width = 10,
h2(tab_name),
hr(), column(3, tableOutput(table_name))
)
)
})
# Convert the list to a tagList - this is necessary for the list of items
# to display properly.
do.call(tagList, table_output_list)
})
# Call renderTable for each one. Tables are only actually generated when they
# are visible on the web page.
observe({
data <- df_list()
for (i in seq(input$n_users)) {
# Need local so that each item gets its own number. Without it, the value
# of i in the renderPlot() will be the same across all instances, because
# of when the expression is evaluated.
local({
my_i <- i
tab_name <- paste0("table", my_i)
output[[tab_name]] <- renderTable(data[[my_i]], rownames = TRUE)
})
}
})
})
shinyApp(ui, server)
Based off of Winston Chang's work here
I wrapped the list in fluidPage or wellPanel and everything works as I want.
Server.R
userHist <- list(
data.frame(X=1:10,Y=11:20),
data.frame(X=1:10,Y=11:20))
output$groupHistory <- renderUI({
userHistList <- lapply( seq(userHist), function(i){
hist_i <- userHist[[i]]
TabName <- paste0("User", i)
fluidRow( column(10,
h2(TabName),
hr(),
column(3, renderTable(hist_i, rownames=TRUE) )
) )
} )
table_output_list <- fluidPage(userHistList,
style="overflow-y:scroll; max-height: 90vh")
})
UI.R
tabsetPanel(id="tabsetpanel",
tabPanel(h1("Group History"),
style="overflow: visible",
uiOutput("groupHistory")
)
)
I have a sidebarLayout app in which I've set up buttons to add and remove tabPanels in the sidebarPanel. However, I can't figure out how to customize those tabPanels. My code is below:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width = 3, fixed=T,
h3("L2 Machine"),
actionButton('moreL2', tags$b('Add L2')),
actionButton('lessL2', tags$b('Remove L2')),
uiOutput('panelset'),
tabPanel("L2panel",
numericInput(inputId='L2amount', 'Select L2 Amount', value=0),
selectInput(inputId='L2type', 'Select L2 Type', c('Percent', 'Absolute')),
uiOutput('L2daterange')
)
),
mainPanel(
verbatimTextOutput('L2a'),
verbatimTextOutput('L2t')
)
)
)
server <- function(input, output) {
output$L2a <- renderPrint(input$L2amount)
output$L2t <- renderPrint(input$L2type)
output$panelset <- renderUI({
n <- seq(max(input$moreL2 - input$lessL2 + 1, 1))
tabList <- lapply(paste("Pan", n), tabPanel)
do.call(tabsetPanel, tabList)
})
output$L2daterange <- renderUI({
dateRangeInput(inputId='L2daterange',
label='Select Adjustment Period',
start='01-01-2010', end='01-12-2015'
)
})
}
shinyApp(ui, server)
Currently, I have numericInput(), selectInput(), and uiOutput() inside tabPanel(). Instead I want each tabPanel created by clicking the button "Add L2" to have it's own set of numericInput, selectInput and uiOutput.
You create indeed different tabPanels but they are empty - both numericInput and selectInput are not inside of dynamic tabPanels. The solution is based on https://gist.github.com/wch/5436415/ and you can find there an extensive explanation why do you need a function local to render outputs with a for loop.
As said above, you created correctly dynamic tabPanels but they are empty. Within lapply you should specify unique widgets as arguments to tabPanel.
output$panelset <- renderUI({
n <- seq(max(input$moreL2 - input$lessL2 + 1, 1))
tabList <- lapply(paste("Pan", n), tabPanel)
do.call(tabsetPanel, tabList)
})
Here I coded an example of how you can do it the correct way. Each time you create a unique tabPanel with a unique set of widgets.
tabList <- lapply(n, function(i) {
tabPanel(
title = paste0('Pan', i),
numericInput(inputId = paste0('L2amount', i), 'Select L2 Amount', value = 0),
selectInput(inputId = paste0('L2type', i), 'Select L2 Type', c('Percent', 'Absolute')),
dateRangeInput(inputId = paste0('L2daterange',i),
label = 'Select Adjustment Period',
start = '01-01-2010', end = '01-12-2015'))
})
do.call(tabsetPanel, tabList)
})
Then for each tabPanel with unique set of widgets you have to create unique set of outputs and then you can render values of your widgets.
Full solution:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width = 3, fixed=T,
h3("L2 Machine"),
actionButton('moreL2', tags$b('Add L2')),
actionButton('lessL2', tags$b('Remove L2')),
uiOutput('panelset')
),
mainPanel(
uiOutput("dynamic")
)
)
)
TMAX <- 10 # specify maximal number of dynamic panels
server <- function(input, output) {
output$panelset <- renderUI({
n <- seq(max(input$moreL2 - input$lessL2 + 1, 1))
# You have to create each time a new set of unique widgets
tabList <- lapply(n, function(i) {
tabPanel(
title = paste0('Pan', i),
numericInput(inputId = paste0('L2amount', i), 'Select L2 Amount', value = 0),
selectInput(inputId = paste0('L2type', i), 'Select L2 Type', c('Percent', 'Absolute')),
dateRangeInput(inputId = paste0('L2daterange',i),
label = 'Select Adjustment Period',
start = '01-01-2010', end = '01-12-2015'))
})
do.call(tabsetPanel, tabList)
})
output$dynamic <- renderUI({
n <- seq(max(input$moreL2 - input$lessL2 + 1, 1))
# You want to render n-times different outputs and each time you have
# k different outputs -- > need a list within a list.
lapply(n, function(i) {
list(
h5(paste0("Pan", i, " widgets")),
verbatimTextOutput(paste0('L2a', i)),
verbatimTextOutput(paste0('L2t', i)),
verbatimTextOutput(paste0('L2dat', i)),
br()
)
})
})
for (i in 1:TMAX) {
local({
my_i <- i
# Outputs
L2a <- paste0('L2a', my_i)
L2t <- paste0('L2t', my_i)
L2dat <- paste0('L2dat', my_i)
list(
output[[L2a]] <- renderPrint({ input[[paste0('L2amount', my_i)]] }),
output[[L2t]] <- renderPrint({ input[[paste0('L2type', my_i)]] }),
output[[L2dat]] <- renderPrint({ input[[paste0('L2daterange', my_i)]] })
)
})
}
}
shinyApp(ui, server)
I am making an app that takes input from a slider to create the matching number of input text boxes. However, when I print the values from the input boxes it does not always update.
Example:
Pick 3 on slider input. Put 1,2,3 into the 3 text boxes respectively.Hit submit. Prints number = 1 number = 2 number = 3. When I move the slider to 2 and hit enter, I get number = 1 number = 2 despite no values being in the text input anymore. If I move the slider to 4, I will than get the output number = NA number = NA number = 3 number = NA.
Clearly it is remembering previous input values, but I cannot understand why or how to fix it.
ui.R
shinyUI(fluidPage(
fluidRow(
column(4, wellPanel(
sliderInput("numObs", "Number of observations", 1, 30, 3),
uiOutput("buttons"),
submitButton(text = "Apply Changes", icon = NULL)
)),
column(8,
textOutput("a")
)
)
))
server.R
shinyServer(function(input, output) {
output$buttons <- renderUI({
obs <- input$"numObs";
objs <-list();
for (i in 1:obs ){
objs <- list(objs, numericInput(inputId = paste0("t", i), "Day:", NA),br());
}
objs <- fluidRow(objs);
})
t<- function(){
for(i in 1:input$"numObs"){
if(i ==1){
t <- c(as.numeric(input[[paste0("t",i)]])[1]);
}
else{
t <- c(t,as.numeric(input[[paste0("t",i)]])[1]);
}
}
return(t);
}
output$a<- renderText({
paste("number = ", t());
})
})
I made some changes and introduced a few things to your code. Its better to use actionButton than the submitButton as it is more flexible. If you dont like the style of the actionButton, look into Shiny Themes
rm(list = ls())
library(shiny)
ui =(fluidPage(
fluidRow(
column(4, wellPanel(
sliderInput("numObs", "Number of observations", 1, 30, 3),
uiOutput("buttons"),
actionButton("goButton", "Apply Changes")
)),
column(8,textOutput("a"))
) ))
server = (function(input, output) {
output$buttons <- renderUI({
obs <- input$"numObs";
objs <-list();
for (i in 1:obs ){
objs <- list(objs, numericInput(inputId = paste0("t", i), "Day:", NA),br());
}
objs <- fluidRow(objs);
})
# keep track if the Number of obseervations change
previous <- eventReactive(input$goButton, {
input$numObs
})
t <- eventReactive(input$goButton, {
for(i in 1:input$"numObs"){
if(i ==1){
t <- c(as.numeric(input[[paste0("t",i)]])[1]);
}
else{
t <- c(t,as.numeric(input[[paste0("t",i)]])[1]);
}
}
return(t)
})
output$a<- renderText({
if(previous() != input$numObs){
return()
}
paste("number = ", t());
})
})
runApp(list(ui = ui, server = server))