I have a shiny app that utilizes a data table with drop down menus to control the updates of select columns. When I modularize the shiny app, I am no longer able to capture the results of the updated table. The approach I am following for the drop down menus is based on a response I received to an earlier question (@ismirsehregal).
Below I’ve provided two versions of my app, nonmod2_app and mod2_app. The first is without modules and works as desired. The second is a modularized version and I am getting NULL in the output.
When the User runs the app they are presented with a Load Data button which loads the cars data as cars_df and creates a new table I call cars_meta with three values. It then creates a list called cars_object to which cars_df and cars_meta are added. This is then made a reactive value, cars_reactive.
The User is then presented with a an editable data table (initTbl) of the reactive cars_reactive$cars_meta for which they can update the values of two fields via drop down menus. When the User is done making updates and selects the Commit button, the results of the selections are saved as cars_reactive$cars_meta. I display the updated cars_reactive$cars_meta as verbatimTextOutput so one can see how it was updated.
In both examples, I update the first class value from “numeric” to “character” and select Commit. In the nonmod2_app version the results table holds the original values and reflects the one I updated.
In the mod2_app version, I get NULL for all values of the two selectable fields.
I suspect it has something to do with namespace, but am at a loss to figure out what is missing.
Here is the ui and server code for the non modularized version.
#------- LIBRARIES ---------------------
library(dplyr)
library(tidyselect)
library(stringr)
library(purrr)
library(shinyjs)
library(DT)
# ------ UI ------------------
shiny_ui <- function() {
fluidPage(
actionButton("new_data", "Load Data"),
br(),
DT::dataTableOutput("main_table"),
br(),
actionButton("commit_meta", "Commit"),
br(),
verbatimTextOutput("cars_meta")
)
}
# -------- SERVER ---------------
shiny_server <- function(input, output, session) {
v <- reactiveValues()
#place holders
selectInputIDclass <- "class"
selectInputIDusage <- "usage"
observeEvent(input$new_data, once = TRUE, {
cars_df <- mtcars
#simulate creating meta table
cars_meta <- dplyr::tibble(variable = names(cars_df), class = sapply(cars_df, class), usage = c("val1", "val2", "val3","val1", "val2", "val3","val1", "val2", "val3","val1", "val2"))
cars_meta$class <- factor(cars_meta$class, c("numeric", "character", "factor"))
cars_meta$usage <- factor(cars_meta$usage, c("val1", "val2", "val3"))
#simulate creating the cars_object
cars_object <- list()
cars_object$cars_df <- cars_df
cars_object$cars_meta <- cars_meta
#make initTbl
selectInputIDclass <<- paste0("sel_class", 1:nrow(cars_object$cars_meta))
selectInputIDusage <<- paste0("sel_usage", 1:nrow(cars_object$cars_meta))
v$initTbl <- dplyr::tibble(
variable = cars_object$cars_meta$variable,
class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor"),
selected = cars_object$cars_meta$class[which(selectInputIDclass == x)]))}),
usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"),
selected = cars_object$cars_meta$usage[which(selectInputIDusage == x)]))})
)
v$cars_reactive <- reactive({
cars_object
})
})
displayTbl <- reactive({
dplyr::tibble(
variable = v$cars_reactive()$cars_meta$variable,
class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor"), selected = input[[x]]))}),
usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"), selected = input[[x]]))})
)
})
resultTbl <- reactive({
dplyr::tibble(
variable = v$cars_reactive()$cars_meta$variable,
class = sapply(selectInputIDclass, function(x){input[[x]]}),
usage = sapply(selectInputIDusage, function(x){input[[x]]})
)
})
output$main_table = DT::renderDataTable({
req(isTruthy(input$new_data))
DT::datatable(
v$initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}, server = TRUE)
main_table_proxy <- DT::dataTableProxy(outputId = "main_table", session = session)
observeEvent({sapply(selectInputIDclass, function(x){input[[x]]})}, {
replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
}, ignoreInit = TRUE)
observeEvent({sapply(selectInputIDusage, function(x){input[[x]]})}, {
replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
}, ignoreInit = TRUE)
observeEvent(input$commit_meta, {
object = v$cars_reactive()
table = resultTbl()
object$cars_meta <- table
v$cars_reactive <- reactive({object})
})
output$cars_meta <- renderPrint({
req (input$commit_meta > 0)
isolate({v$cars_reactive()$cars_meta})
})
}
# ------- APP ----------
nonmod2_app <- function(...) {
app <- shiny::shinyApp(
ui = shiny_ui,
server = shiny_server
)
shiny::runApp(app, ...)
}
Here is the code for the modularized version.
#------- LIBRARIES ---------------------
library(dplyr)
library(tidyselect)
library(stringr)
library(purrr)
library(shinyjs)
library(DT)
# ------ UI MODULE ------------------
mod_ui <- function(id) {
fluidPage(
actionButton(NS(id,"new_data"), "Load Data"),
br(),
DT::dataTableOutput(NS(id, 'main_table')),
br(),
actionButton(NS(id, "commit_meta"), "Commit"),
br(),
verbatimTextOutput(NS(id, "cars_meta"))
)
}
# -------- SERVER MODULE ---------------
mod_server <- function(id) {
shiny::moduleServer(id, function(input, output,session){
v <- reactiveValues()
#place holders
selectInputIDclass <- "class"
selectInputIDusage <- "usage"
observeEvent(input$new_data, once = TRUE, {
cars_df <- mtcars
#simulate creating meta table
cars_meta <- dplyr::tibble(variable = names(cars_df), class = sapply(cars_df, class), usage = c("val1", "val2", "val3","val1", "val2", "val3","val1", "val2", "val3","val1", "val2"))
cars_meta$class <- factor(cars_meta$class, c("numeric", "character", "factor"))
cars_meta$usage <- factor(cars_meta$usage, c("val1", "val2", "val3"))
#simulate creating the cars_object
cars_object <- list()
cars_object$cars_df <- cars_df
cars_object$cars_meta <- cars_meta
#make initTbl
selectInputIDclass <<- paste0("sel_class", 1:nrow(cars_object$cars_meta))
selectInputIDusage <<- paste0("sel_usage", 1:nrow(cars_object$cars_meta))
v$initTbl <- dplyr::tibble(
variable = cars_object$cars_meta$variable,
class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor"),
selected = cars_object$cars_meta$class[which(selectInputIDclass == x)]))}),
usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"),
selected = cars_object$cars_meta$usage[which(selectInputIDusage == x)]))})
)
v$cars_reactive <- reactive({
cars_object
})
})
displayTbl <- reactive({
dplyr::tibble(
variable = v$cars_reactive()$cars_meta$variable,
class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor"), selected = input[[x]]))}),
usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"), selected = input[[x]]))})
)
})
resultTbl <- reactive({
dplyr::tibble(
variable = v$cars_reactive()$cars_meta$variable,
class = sapply(selectInputIDclass, function(x){input[[x]]}),
usage = sapply(selectInputIDusage, function(x){input[[x]]})
)
})
output$main_table = DT::renderDataTable({
req(isTruthy(input$new_data))
DT::datatable(
v$initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}, server = TRUE)
main_table_proxy <- DT::dataTableProxy(outputId = "main_table", session = session)
observeEvent({sapply(selectInputIDclass, function(x){input[[x]]})}, {
replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
}, ignoreInit = TRUE)
observeEvent({sapply(selectInputIDusage, function(x){input[[x]]})}, {
replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
}, ignoreInit = TRUE)
observeEvent(input$commit_meta, {
object = v$cars_reactive()
table = resultTbl()
object$cars_meta <- table
v$cars_reactive <- reactive({object})
})
output$cars_meta <- renderPrint({
req (input$commit_meta > 0)
isolate({v$cars_reactive()$cars_meta})
})
})
}
# ------- UI SERVER APP ----------
shiny_ui <- function() {
fluidPage(
mod_ui("data")
)
}
shiny_server <- function(input, output, session) {
sv <- mod_server("data")
}
mod2_app <- function(...) {
app <- shiny::shinyApp(
ui = shiny_ui,
server = shiny_server
)
shiny::runApp(app, ...)
}
Your help is much appreciated.
