I've written an R shiny app which uses a module to create an editable datatable. The editable datatable is displayed correctly when the module runs using a reactiveValues I've named rved. However, when I try to return rved from the module after an actionButton is pressed, the module returns NA.
The app is intended to work as follows: A user first selects which rows to view. For each selected case, a module is run. This module creates inputs for how many variables to edit, which variables to edit, and outputs an editable datatable. The user is then meant write in a new value for the selected variables for the selected rows.
When the user presses a confirm actionButton, the module should return the editable datatable and save these results to a .rds file.
It appears the module takes the initial value when I initially define rved = reactiveValues(data = NA) , but does not appear to update rved outside of the observe() and observeEvent({}) environments.
Any help would be greatly appreciated.
library(shiny)
library(DT)
set.seed(2024)
data <- data.frame(rowID=1:4, var1=sample(1:4,4), var2=sample(1:4,4), var3=sample(1:4,4), var4=sample(1:4,4))
ui_module <- function(id, idx){
ns <- NS(id)
tagList(
wellPanel(uiOutput(ns("num_changes")), uiOutput(ns("vars_to_change")),
dataTableOutput(ns("edit_table")),id=paste0("well", idx), class="wells"))
}
server_module <- function(id, rowID, returnedittable=F){
moduleServer(
id,
function(input, output, session) {
ns <- session$ns
output$num_changes <- renderUI({
numericInput(ns("num_changes"), "select number of variables to change:", value=1, min=1, max = 4, step=1)
})
output$vars_to_change <- renderUI({
req(input$num_changes)
vars_to_change_list <- lapply(1:input$num_changes, function(i) {
name <- ns(paste0("vars_to_change_", i, sep=""))
selectInput(name, "Select variable to change", names(data)[2:ncol(data)], selected="")
})
do.call(tagList, vars_to_change_list)
})
edit_table_func <- reactive({
req(rowID)
req(input$num_changes)
df <- data.frame(matrix(nrow=input$num_changes, ncol=4))
colnames(df) <- c("rowID", "var_name", "current_value", "new_value")
df$rowID <- rowID
df$var_name <- sapply(1:input$num_changes, FUN=function(i) {
name <- paste0("vars_to_change_", i, sep="")
input[[name]]
})
df$current_value <- sapply(1:input$num_changes, FUN=function(i) {
data[data$rowID==rowID, as.character(df$var_name[i])]
})
return(df)
})
rved <- reactiveValues(data=NA)
observe({
req(rowID)
req(input$num_changes)
rved$data <- edit_table_func()
})
output$edit_table <- renderDataTable({
req(rowID)
req(input$num_changes)
df <- edit_table_func()
editable_columns = c("new_value")
not_editable_columns = which(!colnames(df) %in% editable_columns) - 1
datatable(rved$data, rownames = F,editable=list(target="cell", disable=list(columns=not_editable_columns)), selection = "none", options = list(iDisplayLength = 1000, dom = 'tir', columnDefs = list(list(className = 'dt-center', targets = "_all"))))
})
observeEvent(input$edit_table_cell_edit, {
req(rowID)
req(input$num_changes)
for(i in 1:input$num_changes){
name_input <- paste0("vars_to_change_", i, sep="")
req(input[[name_input]])
}
rved$data <- data.frame(lapply(rved$data, as.character), stringsAsFactors=FALSE)
req(input$edit_table_cell_edit)
rved$data <<- editData(rved$data, input$edit_table_cell_edit, rownames = FALSE)
})
reactive(for (i in 1:input$num_changes) {
local({
name <- ns(paste0("vars_to_change_", i, sep=""))
input[[name]]
})
})
if(isTRUE(returnedittable)){
return(reactive({rved$data}))
}
}
)
}
ui <- fluidPage(
titlePanel("Simple app w module"),
sidebarLayout(
sidebarPanel(width=2,
uiOutput("rowID"),
actionButton("confirm", "Confirm & save")
),
mainPanel( width=10,
tabPanel("Resolve rowID", value='editor',
wellPanel(style = "background: powderBlue", id="fixed_panel")
)
)
)
)
server <- function(input, output, session) {
get_rowID_options <- reactive({
rowID_options <- unique(data$rowID)
return(rowID_options)
})
output$rowID <- renderUI({
selectInput("rowID", "Select rowID", get_rowID_options(), get_rowID_options(), multiple = T)
})
observeEvent(input$rowID, ignoreNULL = F, {
choices <- get_rowID_options()
num_choices <- length(choices)
if(is.null(input$rowID)){
removeUI(selector = ".wells", multiple = T)
} else{
matches <- match(input$rowID, choices)
lapply(seq_along(matches), FUN=function(x) {
id_name = paste0("id", matches[x])
removeUI(selector = paste0("#well", matches[x]), multiple = T)
if(x==1){
well_id <- "#fixed_panel"
insertUI(
selector = well_id,
where = "beforeEnd",
ui = ui_module(id = id_name, idx=matches[x])
)
}
if(x>1){
well_id <- paste0("#well", matches[x-1])
insertUI(
selector = well_id,
where = "afterEnd",
ui = ui_module(id = id_name, idx=matches[x])
)
}
rowID_idx = choices[matches[x]]
server_module(id=id_name, rowID=rowID_idx)
})
if(length(input$rowID) < num_choices){
lapply(which(!choices %in% input$rowID), FUN=function(i){
id_idx <- paste0("id", i)
removeUI(selector = paste0("#well", i), multiple = T)
})
}
}
})
observeEvent(input$confirm, {
lapply(1:length(input$rowID), FUN=function(i) {
id_name = paste0("id", i)
idx <- paste0("id",i, "-")
rows = input[[paste0(idx, "num_changes")]]
df <- data.frame(matrix(nrow=rows, ncol=5))
colnames(df) <- c("rowID", "edit_date", "var_name", "current_value", "new_value")
df[,] <- NA
rved2 <- server_module(id=id_name, rowID=input$rowID[i], returnedittable = T)
df$var_name <- rved2()$var_name
df$current_value <- rved2()$current_value
df$new_value <- rved2()$new_value
df$rowID <- input$rowID[i]
df$edit_date <- as.character(Sys.Date())
#assuming changes.rds already exists
new_df <- rbind(readRDS("changes.rds"), df)
saveRDS(new_df, "changes.rds")
}
)
})
}
shinyApp(ui = ui, server = server)
This seems to work. A notable change is that I execute the module server for every rowID, not in an observer.
library(shiny)
library(DT)
set.seed(2024)
data <- data.frame(
rowID=1:4,
var1=sample(1:4,4),
var2=sample(1:4,4),
var3=sample(1:4,4),
var4=sample(1:4,4)
)
ui_module <- function(id, idx){
ns <- NS(id)
wellPanel(
uiOutput(ns("ui_num_changes")),
uiOutput(ns("vars_to_change")),
DTOutput(ns("edit_table")),
id = paste0("well", idx),
class = "wells"
)
}
server_module <- function(id, rowID, returnedittable=FALSE){
moduleServer(
id,
function(input, output, session) {
ns <- session$ns
output$ui_num_changes <- renderUI({
numericInput(
ns("num_changes"), "select number of variables to change:",
value=1, min=1, max = 4, step=1
)
})
output$vars_to_change <- renderUI({
req(input$num_changes)
vars_to_change_list <- lapply(1:input$num_changes, function(i) {
name <- ns(paste0("vars_to_change_", i, sep=""))
selectInput(
name, "Select variable to change",
names(data)[2:ncol(data)], selected=""
)
})
do.call(tagList, vars_to_change_list)
})
observe({
print(input$vars_to_change_1)
})
VarsToChange <- reactive({
req(input$num_changes)
vtc <- lapply(1:input$num_changes, FUN=function(i) {
name <- paste0("vars_to_change_", i, sep="")
input[[name]]
})
ok <- sapply(vtc, Negate(is.null))
req(all(ok))
unlist(vtc)
})
edit_table_func <- reactive({
req(VarsToChange())
#req(all(VarsToChange() != ""))
df <- data.frame(matrix(nrow=input$num_changes, ncol=4))
colnames(df) <- c("rowID", "var_name", "current_value", "new_value")
df$rowID <- rowID
df$var_name <- VarsToChange()
df$current_value <- sapply(1:input$num_changes, FUN=function(i) {
data[data$rowID==rowID, as.character(df$var_name[i])]
})
return(df)
})
rved <- reactiveValues(data=NA)
observe({
rved$data <- edit_table_func()
})
output$edit_table <- renderDT({
df <- edit_table_func()
editable_columns = c("new_value")
not_editable_columns = which(!colnames(df) %in% editable_columns) - 1
datatable(
rved$data, rownames = FALSE,
editable=list(target="cell", disable=list(columns=not_editable_columns)),
selection = "none",
options = list(
iDisplayLength = 1000,
dom = 'tir',
columnDefs = list(
list(className = 'dt-center', targets = "_all")
)
)
)
})
observeEvent(input$edit_table_cell_edit, {
rved$data <- editData(rved$data, input$edit_table_cell_edit, rownames = FALSE)
})
if(isTRUE(returnedittable)){
return(reactive({rved$data}))
}
}
)
}
ui <- fluidPage(
titlePanel("Simple app w module"),
sidebarLayout(
sidebarPanel(width=2,
uiOutput("ui_rowID"),
actionButton("confirm", "Confirm & save")
),
mainPanel(
width=10,
wellPanel(style = "background: powderBlue", id="fixed_panel")
)
)
)
server <- function(input, output, session) {
get_rowID_options <- unique(data$rowID)
output$ui_rowID <- renderUI({
selectInput(
"rowID", "Select rowID",
get_rowID_options, multiple = TRUE, selected = NULL
)
})
observeEvent(input$rowID, ignoreNULL = TRUE, {
choices <- get_rowID_options
num_choices <- length(choices)
if(is.null(input$rowID)){
removeUI(selector = ".wells", multiple = T)
} else{
matches <- match(input$rowID, choices)
lapply(seq_along(matches), FUN=function(x) {
id_name = paste0("id", matches[x])
removeUI(selector = paste0("#well", matches[x]), multiple = TRUE)
if(x==1){
well_id <- "#fixed_panel"
insertUI(
selector = well_id,
where = "beforeEnd",
ui = ui_module(id = id_name, idx=matches[x])
)
}
if(x>1){
well_id <- paste0("#well", matches[x-1])
insertUI(
selector = well_id,
where = "afterEnd",
ui = ui_module(id = id_name, idx=matches[x])
)
}
})
if(length(input$rowID) < num_choices){
lapply(which(!choices %in% input$rowID), FUN=function(i){
id_idx <- paste0("id", i)
removeUI(selector = paste0("#well", i), multiple = T)
})
}
}
})
Tables <- setNames(lapply(1:4, function(i) {
id_name <- paste0("id", i)
rowID_idx <- get_rowID_options[i]
server_module(id=id_name, rowID=rowID_idx, returnedittable=TRUE)
}), as.character(get_rowID_options))
observeEvent(input$confirm, {
lapply(input$rowID, FUN=function(rowid) {
tabl <- Tables[[as.character(rowid)]]()
df <- tabl
df$edit_date <- as.character(Sys.Date())
if(file.exists("changes.rds")) {
df <- rbind(readRDS("changes.rds"), df)
}
saveRDS(df, "changes.rds")
}
)
})
}
shinyApp(ui = ui, server = server)