I use in my shiny apps custom shinyInput functions that facilitate building dynamic tables such that users can provide input from checkboxes, drop downs, text boxes, etc. to each row of a table. This functionality relies on calling Javascript in the UI and when generating output from DT::renderDataTable. This all works perfectly well when I use this tooling in the main app.R but I cannot get it to work when placed in a module. The problem almost certainly is that I need to include the namespace in the calls to the Javascript when in the module but I do not know where to do this. I have included code from a toy example illustrating the problem.
Thanks in advance for any assistance.
# libraries ---------------------------------------------------------------
library(shiny)
library(dplyr)
library(DT)
# module UI ---------------------------------------------------------------
moduleUI <- function(id) {
ns <- NS(id)
fluidPage(
DT::dataTableOutput(ns("moduleOutput")),
tags$script(HTML("Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")),
DT::dataTableOutput(ns("moduleWithRatingOutput"))
) # close the page
}
# module server -----------------------------------------------------------
mtcarsModule <- function(input, output, session) {
# helper function to add interactive elements to rows of a table
shinyInputOther <- function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# helper function to extract interactive elements from rows of a table
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
# reactive data
mtcarsReactive <- reactive({
head(mtcars)
}) # close reactive
# reactive data output - allows adding a rating to each row/car
output$moduleOutput <- DT::renderDataTable({
mtcarsReactive() %>%
mutate(
rating = shinyInputOther(FUN = selectInput,
len = nrow(mtcarsReactive()),
id = 'rating_',
choices=c("high", "med", "low"),
width = "60px")
)
},
selection = 'none',
escape = FALSE,
server = FALSE,
options = list(bFilter = 0,
bLengthChange = F,
bPaginate = F,
bSort = F,
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
),
rownames = F) # close output
# reactive data with added rating for each row/car
mtcarsWithRating <- reactive({
mtcarsReactive() %>%
mutate(
rating = shinyValue("rating_",
nrow(mtcarsReactive())
)
)
}) # close reactive
# reactive data output - includes rating for each row/car
output$moduleWithRatingOutput <- DT::renderDataTable({
mtcarsWithRating()
},
selection = 'none',
escape = FALSE,
server = FALSE,
options = list(bFilter = 0,
bLengthChange = F,
bPaginate = F,
bSort = F
),
rownames = F) # close output
} # close module
# app UI ------------------------------------------------------------------
ui <- navbarPage("mtcars",
# app tab
tabPanel("app",
fluidPage(
DT::dataTableOutput("mtcarsOutput"),
tags$script(HTML("Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")),
DT::dataTableOutput("mtcarsWithRatingOutput")
) # close the page
), # close tab
# module tab
tabPanel("module",
moduleUI("mtcarsModule")
) # close tab
) # close navbarPage
# app server --------------------------------------------------------------
server <- function(input, output) {
# helper function to add interactive elements to rows of a table
shinyInputOther <- function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# helper function to extract interactive elements from rows of a table
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
# reactive data
mtcarsReactive <- reactive({
head(mtcars)
}) # close reactive
# reactive data output - allows adding a rating to each row/car
output$mtcarsOutput <- DT::renderDataTable({
mtcarsReactive() %>%
mutate(
rating = shinyInputOther(FUN = selectInput,
len = nrow(mtcarsReactive()),
id = 'rating_',
choices=c("high", "med", "low"),
width = "60px")
)
},
selection = 'none',
escape = FALSE,
server = FALSE,
options = list(bFilter = 0,
bLengthChange = F,
bPaginate = F,
bSort = F,
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
),
rownames = F) # close output
# reactive data with added rating for each row/car
mtcarsWithRating <- reactive({
mtcarsReactive() %>%
mutate(
rating = shinyValue("rating_",
nrow(mtcarsReactive())
)
)
}) # close reactive
# reactive data output - includes rating for each row/car
output$mtcarsWithRatingOutput <- DT::renderDataTable({
mtcarsWithRating()
},
selection = 'none',
escape = FALSE,
server = FALSE,
options = list(bFilter = 0,
bLengthChange = F,
bPaginate = F,
bSort = F
),
rownames = F) # close output
# call module -------------------------------------------------------------
callModule(module = mtcarsModule,
id = "mtcarsModule")
} # close server
# run the application -----------------------------------------------------
shinyApp(ui = ui, server = server)
EDIT (2020-03-26): In case others run into this problem, the fix was to include session$ns in the id of the call to shinyInputOther. Using the included example, that looks like:
rating = shinyInputOther(
FUN = selectInput,
len = nrow(mtcarsReactive()),
id = paste0(session$ns('rating_')),
choices=c("high", "med", "low"),
width = "60px")
