Я использую в своих приложениях Блестящие пользовательские функции блестящий вывод, которые облегчают создание динамических таблиц c, чтобы пользователи могли вводить данные из флажков, раскрывающихся списков, текстовых полей и т. Д. c. к каждому ряду таблицы. Эта функциональность основана на вызове Javascript в пользовательском интерфейсе и при генерации вывода из DT :: renderDataTable. Это все прекрасно работает, когда я использую этот инструмент в основном приложении. R, но я не могу заставить его работать, когда помещен в модуль. Проблема почти наверняка состоит в том, что мне нужно включить пространство имен в вызовы к Javascript, когда он находится в модуле, но я не знаю, где это сделать. Я включил код из игрушечного примера, иллюстрирующего проблему.
Заранее благодарен за любую помощь.
# 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)
РЕДАКТИРОВАТЬ (2020-03-26): В случае, если другие столкнутся с этой проблемой исправление должно было включать session$ns в id вызова shinyInputOther. Используя приведенный пример, он выглядит так:
rating = shinyInputOther(
FUN = selectInput,
len = nrow(mtcarsReactive()),
id = paste0(session$ns('rating_')),
choices=c("high", "med", "low"),
width = "60px")