How to customize tabPanel added by clicking a button in Shiny - r

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)

Related

How to replace an observeEvent with a more comprehensive reactive function in R Shiny?

The code at the bottom of this post works as intended, using observeEvent(input$choices...) in the server section. The use of input$choices is a simplification for sake of example ease. In the fuller code this excerpt derives from, the equivalent of "choices" is molded by many different inputs (call it a "floating reactive"), and unless I misunderstand observeEvent(), it won't be feasible to use observeEvent() in the fuller code because I would have to list the myriad inputs that can alter it. So, is there a way to genericize this code where it instantly captures any change to "choices" (again, "choices" is a simplified analogy for my more complex floating reactive) and outputs it to the 2nd row of the table, including added rows?
Also in the below image, I show how "choices" is a always parachuted into the 2nd position of the dataframe in all circumstances (maybe there's a simpler way to do this too):
Code:
library(rhandsontable)
library(shiny)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D')
ui <- fluidPage(br(),
useShinyjs(),
uiOutput("choices"),br(),
rHandsontableOutput('hottable'),br(),
fluidRow(
column(1,actionButton("addSeries", "Add",width = '70px')),
column(3,hidden(uiOutput("delSeries2")))
)
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observeEvent(input$choices,{
tmpTable <- uiTable()
tmpTable[2,]<- as.numeric(input$choices)
uiTable(tmpTable)
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$addSeries, {
newCol <- data.frame(c(1,1,0,1))
newCol[2,] <- as.numeric(input$choices)
names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol))
})
output$delSeries2 <-
renderUI(
selectInput(
"delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$hottable))
)
)
}
shinyApp(ui,server)
Not sure if I get the point here, but you might want to use observe instead of observeEvent to avoid managing the reactive dependencies (eventExpr) yourself:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D')
ui <- fluidPage(br(),
useShinyjs(),
uiOutput("choices"),br(),
rHandsontableOutput('hottable'),br(),
fluidRow(
column(1,actionButton("addSeries", "Add",width = '70px')),
column(3,hidden(uiOutput("delSeries2")))
)
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observe({
req(input$choices)
tmpTable <- uiTable()
tmpTable[2,] <- as.numeric(input$choices)
uiTable(tmpTable)
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$addSeries, {
newCol <- data.frame(c(1,1,0,1))
newCol[2,] <- as.numeric(input$choices)
names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol))
})
output$delSeries2 <-
renderUI(
selectInput(
"delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$hottable))
)
)
}
shinyApp(ui,server)

Using two reactives in shiny that depend on each other

I have been trying to create a dashboard with up to 3 inputs and then plot some data. I have done this part but the requirement now has changed that every time there is a selection of a new variable they should also be able to filter the data based on the new input. Here has been my attempt so far:
UI:
library(shiny)
ui <- fluidPage(
sidebarPanel(
tags$br(),
uiOutput("textbox_ui"),
uiOutput("filter_ui"),
tags$br(),
actionButton("add_btn", "Add Factor"),
actionButton("rm_btn", "Remove Factor"),
tags$br(),
actionButton("make","Create Graph and Tables")
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Data stuff")
)
)
)
Server:
server <- function(input, output) {
# Track the number of input boxes to render
counter <- reactiveValues(n = 0)
AllInputs <- reactive({
x <- reactiveValuesToList(input)
})
observeEvent(input$add_btn, {
if(counter$n >2){
2
}else{
counter$n <- counter$n + 1
}
})
observeEvent(input$rm_btn, {
if (counter$n > 0) counter$n <- counter$n - 1
})
textboxes <- reactive({
n <- counter$n
if (n > 0) {
isolate({
lapply(seq_len(n), function(i) {
selectInput(inputId = paste0("var", i+1),
label = "",
choices = colnames(mtcars),
selected = AllInputs()[[paste0("var", i+1)]])
})
})
}
})
filterboxes <- reactive({
n <- counter$n
extrainputs <- sapply(seq_len(n), function(i) {
AllInputs()[[paste0("var", i+1)]]
})
summvar <- c(input$var1, extrainputs)
if(n > 0 ){
isolate({
lapply(1:length(summvar), function(x){
text <- summvar[x]
val_level <- unique(mtcars[[text]])
selectInput(inputId = paste0("fil",x+1),
label = paste0("Filter for ", text),
choices = val_level,
multiple = TRUE,
selected = val_level)
})
})
}
})
output$textbox_ui <- renderUI({ textboxes() })
output$filter_ui <- renderUI({ filterboxes() })
}
Two problems arise with this set up so far. One I cannot unselect any of the values when they appear in the filter second I see this warning on the sever side "Warning: Error in .subset2: invalid subscript type 'list'". My reactive skills are quite poor and any suggestions (reactive or not) would be appreciated.
As suggested in my comment...
library(shiny)
myfun <- function(df, var1) {
df %>% mutate(newvar = !!sym(var1)) # create newvar
}
ui <- fluidPage(
sidebarPanel(
tags$br(),
# uiOutput("textbox_ui"),
# uiOutput("filter_ui"),
tags$br(),
tags$div(id = 'placeholder'),
actionButton("add_btn", "Add Factor"),
actionButton("removeBtn", "Remove Factor"),
tags$br(),
actionButton("make","Create Graph and Tables")
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Data stuff")
)
)
)
server <- function(input, output, session) {
# Track the number of variables
numvars <- reactiveVal(0)
### keep track of elements/lines inserted and not yet removed
inserted <- c()
observeEvent(input$add_btn, {
if(input$add_btn==0) {
return(NULL)
}
else {
if (numvars()<0) {
numvars(0) # clicking on remove button too many times yields negative number; reset it to zero
}
newValue <- numvars() + 1 # newValue <- rv$numvars + 1
numvars(newValue) # rv$numvars <- newValue
# btn needs to be adjusted if removing and adding factors
if (input$removeBtn==0){
btn <- input$add_btn
}else {
if (input$add_btn > input$removeBtn) {
btn <- input$add_btn - input$removeBtn # add_btn counter does not decrease
}else btn <- numvars()
}
id <- paste0('txt', btn)
insertUI(
selector = '#placeholder',
## wrap element in a div with id for ease of removal
ui = tags$div(
selectInput(inputId = paste0("var", btn),
label = "",
choices = colnames(mtcars)
),
selectInput(inputId = paste0("fil",btn),
label = paste0("Filter for ", id),
choices = "",
multiple = TRUE),
id = id
)
)
}
# inserted <<- c(id, inserted) ## removes first one first
inserted <<- c(inserted, id) ## removes last one first
}, ignoreInit = TRUE) ## end of observeevent for add_btn
observe({
#print(numvars())
lapply(1:numvars(), function(i){
observeEvent(input[[paste0("var",i)]], {
mydf <- mtcars
mydf2 <- myfun(mydf,input[[paste0("var",i)]])
mysub <- unique(mydf2$newvar)
nam <- as.character(input[[paste0("var",i)]])
updateSelectInput(session = session,
inputId = paste0("fil",i),
label = paste0("Filter for ", nam),
choices = mysub,
selected = mysub
)
})
})
})
observeEvent(input$removeBtn, {
newValue <- numvars() - 1
numvars(newValue)
removeUI(
## pass in appropriate div id
selector = paste0('#', inserted[length(inserted)])
)
inserted <<- inserted[-length(inserted)]
print(inserted)
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)

How to combine multiple inputs in one vector in shiny. Number of inputs depends on user's choice

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)

R Shiny Scrollable List of Tables in TabPanel

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

Adding and removing tabPanel by clicking buttons in Shiny

I'm trying to design a Shiny app such that a user can click on buttons to add or remove a tabPanel. I've been able to do this successfully with the code below, but there is a problem. In the code below every time the user clicks on Add L2 or Remove L2, the entire panel is recreated, thus resetting all inputs in each tabPanel. This is problematic because the goal is for the user to dynamically add tabPanels and save their inputs. Is there any way to do this?
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(
)
)
)
server <- function(input, output) {
more <- reactiveValues(i=1)
less <- reactiveValues(i=1)
observe({
input$moreL2
isolate({
more$i <- more$i + 1
})
})
observe({
input$lessL2
isolate({
less$i <- less$i + 1
})
})
output$panelset <- renderUI({
if(less$i > more$i) less$i <- more$i
n <- seq(max(more$i - less$i + 1, 1))
lapply(n, function(i) {
tabPanel(
title = paste0('Pan', i),
numericInput(paste0('L2amount', i), 'Select L2 Amount', value = 0),
selectInput(paste0('L2type', i), 'Select L2 Type', c('Percent', 'Absolute')),
dateRangeInput(paste0('L2daterange',i), 'Select Adjustment Period',
start='01-01-2010', end='01-12-2015'))
})
})
}
shinyApp(ui, server)

Resources