How to repeatedly update the same table using shiny modules
I have a shiny app that uses modules. In this app there are several drop downs with choices that need to be populated in a table. The first drop down relates to the second and gives the row filter to change the value of the second dropdown in the second column of the table, however the values in the first drop down should not change the values in first column of the table.
The table should first automatically populate with the default values of the drop downs (these vary so this cant be hard coded). The user of the app will look at choices and click the update button when they want a change to happen in the table. It is not obvious from this reproducible example but in the larger app the user will need to continuously update the table from the last update they did, not just send a full table of data to repopulate the whole thing. I know how to use the values from the drop downs to populate a table once, but I am having trouble understanding how I can store a table (or any object) somewhere so it can be accessed and updated continuously.
In case the description is not totally clear, I expect a table like this to appear on initialization:
then if I change dropdown 2 to 'b' and click update table I expect it to look like this:
finally if I change dropdown 1 to 'sandwich' and then change dropdown 2 to 'a' and click update table, I expect the table to look like this:
Below is the code for a minimal example and in the TabButtonServer module you will see my best attempt at getting this to work but it does not. As mentioned above the crux of the issue is I don't know how I am supposed to store the table when its updated so that it can be referenced again later. I very much appreciate any help someone could offer.
## first drop down
ChooseUI1 <- function(id) {
selectInput(NS(id, "choice1"),
label=NULL,
choices=c("foo", "bar", "ham", "sandwich"))
}
ChooseServer1 <- function(id) {
moduleServer(id, function(input, output, session) {
reactive({
input$choice1
})
})
}
## second drop down
ChooseUI2 <- function(id) {
selectInput(NS(id, "choice2"),
label=NULL,
choices=c("a", "b", "c", "d"))
}
ChooseServer2 <- function(id) {
moduleServer(id, function(input, output, session) {
reactive({
input$choice2
})
})
}
## button to change table
TabButtonUi <- function(id){
actionButton(NS(id, "tab_change"),
label="Update Table")
}
TabButtonServer <- function(id, c1, c2) {
stopifnot(is.reactive(c1))
stopifnot(is.reactive(c2))
moduleServer(id, function(input, output, session) {
start_table <- reactive({
cbind.data.frame(col1=c("foo", "bar", "ham", "sandwich"),
col2=c("a", "b", "c", "d"),
stringsAsFactors=FALSE)
})
new_table <- data.frame(col1=character(), col2=character())
output_change <- eventReactive(input$tab_change, {
if(input$tab_change == 0) {
new_table <- start_table()
} else {
new_table[new_table[ , "col1"] == c1(), "col2"] <<- c2()
}
new_table
}, ignoreNULL=FALSE)
reactive({
output_change()
})
})
}
## view table
viewTabUi <- function(id){
tableOutput(NS(id, "view_tab"))
}
viewTabServer <- function(id, tab) {
stopifnot(is.reactive(tab))
moduleServer(id, function(input, output, session) {
output$view_tab <- renderTable(tab())
})
}
## the app
ui <- navbarPage(
title="test",
tabPanel(title="first page",
sidebarLayout(
sidebarPanel(
ChooseUI1("c1"),
ChooseUI2("c2"),
TabButtonUi("tab"),
viewTabUi("view_tab")
),
mainPanel(
)
)
)
)
server <- function(input, output, session) {
c1 <- ChooseServer1("c1")
c2 <- ChooseServer2("c2")
tab <- TabButtonServer("tab", c1, c2)
viewTabServer("view_tab", tab)
}
shinyApp(ui, server)
One way to do is to use reactiveValues() object as shown below.
## first drop down
ChooseUI1 <- function(id) {
selectInput(NS(id, "choice1"),
label=NULL,
choices=c("foo", "bar", "ham", "sandwich"))
}
ChooseServer1 <- function(id) {
moduleServer(id, function(input, output, session) {
reactive({
input$choice1
})
})
}
## second drop down
ChooseUI2 <- function(id) {
selectInput(NS(id, "choice2"),
label=NULL,
choices=c("a", "b", "c", "d"))
}
ChooseServer2 <- function(id) {
moduleServer(id, function(input, output, session) {
reactive({
input$choice2
})
})
}
## button to change table
TabButtonUi <- function(id){
actionButton(NS(id, "tab_change"),
label="Update Table")
}
TabButtonServer <- function(id, c1, c2) {
stopifnot(is.reactive(c1))
stopifnot(is.reactive(c2))
moduleServer(id, function(input, output, session) {
start_table <- cbind.data.frame(col1=c("foo", "bar", "ham", "sandwich"),
col2=c("a", "b", "c", "d"),
stringsAsFactors=FALSE)
rv <- reactiveValues(df=NULL)
observeEvent(input$tab_change, {
if(input$tab_change == 0) {
rv$df <- start_table
} else {
rv$df[rv$df$col1 == c1(), "col2"] <<- c2()
}
}, ignoreNULL=FALSE)
reactive({
rv$df
})
})
}
## view table
viewTabUi <- function(id){
tableOutput(NS(id, "view_tab"))
}
viewTabServer <- function(id, tab) {
stopifnot(is.reactive(tab))
moduleServer(id, function(input, output, session) {
output$view_tab <- renderTable(tab())
})
}
## the app
ui <- navbarPage(
title="test",
tabPanel(title="first page",
sidebarLayout(
sidebarPanel(
ChooseUI1("c1"),
ChooseUI2("c2"),
TabButtonUi("tab"),
viewTabUi("view_tab")
),
mainPanel(
)
)
)
)
server <- function(input, output, session) {
c1 <- ChooseServer1("c1")
c2 <- ChooseServer2("c2")
tab <- TabButtonServer("tab", c1, c2)
viewTabServer("view_tab", tab)
}
shinyApp(ui, server)
Alternative answer: To take advantage of the modules programming, you could use one selectInput module multiple times as shown below
#### drop down
ChooseUI1 <- function(id) {
selectInput(NS(id, "choice1"), label=NULL, choices=NULL)
}
ChooseServer1 <- function(id,df_col) {
moduleServer(id, function(input, output, session) {
updateSelectInput(session, "choice1", choices= unique(df_col))
reactive({
input$choice1
})
})
}
## button to change table
TabButtonUi <- function(id){
actionButton(NS(id, "tab_change"), label="Update Table")
}
TabButtonServer <- function(id, c1, c2, start_table) {
stopifnot(is.reactive(c1))
stopifnot(is.reactive(c2))
moduleServer(id, function(input, output, session) {
rv <- reactiveValues(df=NULL)
observeEvent(input$tab_change, {
if(input$tab_change == 0) {
rv$df <- start_table
} else {
rv$df[rv$df$col1 == c1(), "col2"] <<- c2()
}
}, ignoreNULL=FALSE)
reactive({ rv$df })
})
}
## view table
viewTabUi <- function(id){
tableOutput(NS(id, "view_tab"))
}
viewTabServer <- function(id, tab) {
stopifnot(is.reactive(tab))
moduleServer(id, function(input, output, session) {
output$view_tab <- renderTable(tab())
})
}
## the app
ui <- navbarPage(
title="test",
tabPanel(title="first page",
sidebarLayout(
sidebarPanel(
ChooseUI1("c1"),
ChooseUI1("c2"),
TabButtonUi("tab"),
viewTabUi("view_tab")
),
mainPanel()
)
)
)
server <- function(input, output, session) {
df <- cbind.data.frame(col1=c("foo", "bar", "ham", "sandwich"),
col2=c("a", "b", "c", "d"),
stringsAsFactors=FALSE)
cc1 <- ChooseServer1("c1",df$col1)
cc2 <- ChooseServer1("c2",df$col2)
tab <- TabButtonServer("tab", cc1, cc2, df)
viewTabServer("view_tab", tab)
}
shinyApp(ui, server)
- Start a PowerShell script in R via system2()
- plot from sankeyNetwork in networkD3 does not show output (issue is not number of unique nodes)
- "Target position can only be set for new windows" in chromote in R
- Extract the correct data type in a PDF table
- Time conversion in R
- Comparing the values of a certain number previous rows with the current row
- Run a single test function in R's testthat
- rpart package installation in R
- An efficient way to assign value based on a min-max range and category
- Change output of the `purrr::map` function
- osmdata_sf returns failed to perform HTTP request curl::curl_fetch_memory() error in R?
- Comparing nls() to nls2() - what am I doing wrong
- How to add "variables grid" below ggplot
- How can I use predefined code snippets outside of code chunks in Quarto within RStudio/Posit?
- Wrap text for collapse rows in KableExtra for a long table in R
- Implementation of Breusch-Pagan test for random effects in plm with unbalanced panels
- Finding a value of a dataset in different ones
- Replicate matrix
- Unexpected results after converting raster data from geographic to projected coordinate system using the terra package
- How to remove rows by condition in R?
- How do I add an alias for magrittr pipe from R in vscode
- Package ‘neuralnet’ in R, rectified linear unit (ReLU) activation function?
- Sub-subtitle in a graph made with `ggplot2`
- How can I execute a statement and ignore warnings with tryCatch?
- Enumerate events where n consecutive values are not NA
- Serialize/deserialize a column with R and DuckDB
- How can I structure my sapflow data to analyze using "TREX" package in R?
- Putting multiple plots on the same page in R?
- NA values in a non-editable date column in a datatable in a shiny app change to "Invalid Date" when clicked on
- How to enable/disable checkboxInput when certain panel is selected