如何访问嵌入在DT表中的selectInput小部件的输入值？

问题描述 投票：0回答：1

我有一个完美工作的闪亮应用程序，它呈现一个带有一个或多个 DT 列的 DT 表，其中行包含 selectInput 小部件。

给定一个带有一个列表列的数据框 df，我创建数据表如下：

output$table <- renderDataTable({
            DT::datatable(df,  
                          escape = FALSE, rownames = FALSE, selection = 'none',
                          options = list(
                            sort = FALSE, paging = FALSE, searching = FALSE, dom = 't',
                            fixedheader = TRUE,
                            pageLength = 5,
                            preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                            drawCallback = JS('function() { Shiny.bindAll(this.api().table().node());}')
                            ))
          })

在 df 列中创建 selectInput 小部件的函数将为每个小部件构造一个唯一的 inputId：例如，

pasteo("select_", rowID)
，其中 rowID 将是数据框 df 中的行号。

在我的应用程序中，列表列的内容被转换为小部件，如下所示：

CreateWidget <- function(data){
  widget <- apply(data, 1, function(x){
    ifelse(length(x$listcol) == 1 , x$listcol, as.character(selectizeInput(paste0("select_", x$row), choices = x$listcol,
                                                       label = NULL,
                                                       selected = 1,
                                                       width = '100%',
                                                       multiple = TRUE, # Make a direct selection
                                                       size = length(x$listcol))))
  })
}

渲染 DT 表后，我可以在 selectInput 小部件中进行适当的选择。选择后，所选值即可在服务器上使用：

input$select_1

这种方法效果很好，我有一个正在生产中的闪亮应用程序。

现在我正在尝试更改我的闪亮应用程序，使其使用模块（我根本没有使用模块的经验）。我本以为只需在生成 selectInput 小部件的函数中命名 inputId 就足够了。

CreateWidget <- function(data, ns){
  widget <- apply(data, 1, function(x){
    ifelse(length(x$listcol) == 1 , x$listcol, as.character(selectizeInput(ns(paste0("select_", x$row)), choices = x$listcol,
                                                       label = NULL,
                                                       selected = 1,
                                                       width = '100%',
                                                       multiple = TRUE, # Make a direct selection
                                                       size = length(x$listcol))))
  })
}

我在服务器模块中使用 

ns = session$ns
的地方，即调用该函数的地方。 例如，如果模块 ID 为“main”，我的输入值现在可用为：

input$main-select_1

或者在我的代码中：

input[[ns(paste0("select_", row))]]

但是可惜，这根本不起作用！ 在我基于模块的应用程序中，我什至看不到与我的 selectInput 小部件关联的输入值。我可以使用浏览器检查器检查它们的 ID，因此我知道它们存在，但我无法访问它们。我可以看到与其他小部件和 DT 表关联的所有其他输入对象。

在 ismirsehregal 的请求后添加了工作代表示例：

全球.R

# module_server.R
library(shiny)
library(dplyr)
library(DT)

source("./R/modules/app_ui.R", local = TRUE)
source("./R/modules/app_server.R", local = TRUE)

ui.R

ui <- fluidPage(
  carTableUI("main")
)

服务器.R

# Module Server
server <- function(input, output, session) {
  carTableServer("main")
}

app_ui.R

# Module UI
carTableUI <- function(id) {
  ns <- NS(id)
  tagList(
    DTOutput(ns("car_table")),
    textOutput(ns("selected_cars"))
  )
}

应用服务器.R

# module_server.R


carTableServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    # function to create a selectizeInput widget for the DT table
    CreateWidget <- function(cars, ns) {
      
      sel_widget <- apply(cars, 1, function(x){
        if (length(x$Type) == 1) {
          x$Type
        } else {
          as.character(
            selectizeInput(
              inputId = session$ns(paste0("car_sel_", x$Brand)),
              #inputId = paste0("car_sel_", x$Brand),
              choices = x$Type,
              label = NULL,
              selected = 1,
              width = '100%',
              multiple = TRUE,
              size = length(x$Type)
            )
          )
        }
      })
      return(sel_widget)
    }
    
    Cars <- tibble(
      Brand = c("Tesla", "Kia", "Toyota"),
      Model = c("Model X", "Seltos", "Corolla"),
      Type = list(
        list("normal car", "sports car", "luxury car"),
        list("normal car", "sports car", "luxury car"),
        list("normal car", "sports car", "luxury car")
      )
    )
    
    Cars$selectize <- CreateWidget(Cars, ns)
    glimpse(Cars) # check how the df looks like
    
    output$car_table <- renderDT({
      datatable(Cars[, c("Brand", "Model", "selectize")], 
                escape = FALSE, rownames = FALSE, selection = 'none',
                options = list(
                  paging = FALSE, 
                  searching = FALSE, 
                  dom = 't',
                  preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                  drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
                ))
    }, server = FALSE)
    
    # Reactive expression to collect selected values
    selected_cars <- reactive({
      browser()
      selected <- sapply(Cars$Brand, function(x) {
        input[[ns(paste0("car_sel_", x))]]
      })
      selected <- selected[!sapply(selected, is.null)]
    })
    
    # Output the selected values
    output$selected_cars <- renderText({
      selected_values <- selected_cars()
      if (length(selected_values) == 0) {
        "No cars selected"
      } else {
        paste("Selected cars:", paste(selected_values, collapse = ", "))
      }
    })
    
    observeEvent(input[["main-car_sel_Tesla"]],
                 print(input[["main-car_sel_Tesla"]])
    )
    
    # print all input objects to the console
    # observe({
    #   print(reactiveValuesToList(input))
    # })
    
  })
}
r shiny dt shinymodules
1个回答
0
投票

为了让这项工作正常进行，我需要解决两个问题。

第一个描述于here。从闪亮的 1.8.0 开始。在 DataTable 中使用 selectize 的依赖项时，您需要“手动”将它们附加到 UI。请参阅下面的 

findDependencies
电话。

第二个问题是，在 

app_server.R
中，您不需要使用 
ns()
来访问输入（selected_cars 反应式）：

全球.R

# module_server.R
library(shiny)
library(dplyr)
library(DT)

select_input <- selectizeInput("dummy", label = NULL, choices = NULL)
deps <- htmltools::findDependencies(select_input)

source("./R/modules/app_ui.R", local = TRUE)
source("./R/modules/app_server.R", local = TRUE)

ui.R

ui <- fluidPage(
  tagList(deps),
  carTableUI("main")
)

服务器.R

# Module Server
server <- function(input, output, session) {
  carTableServer("main")
}

app_ui.R

# Module UI
carTableUI <- function(id) {
  ns <- NS(id)
  tagList(
    DTOutput(ns("car_table")),
    textOutput(ns("selected_cars"))
  )
}

应用服务器.R

# module_server.R

carTableServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    # function to create a selectizeInput widget for the DT table
    CreateWidget <- function(cars, ns) {
      
      sel_widget <- apply(cars, 1, function(x){
        if (length(x$Type) == 1) {
          x$Type
        } else {
          as.character(
            selectizeInput(
              inputId = session$ns(paste0("car_sel_", x$Brand)),
              #inputId = paste0("car_sel_", x$Brand),
              choices = x$Type,
              label = NULL,
              selected = 1,
              width = '100%',
              multiple = TRUE,
              size = length(x$Type)
            )
          )
        }
      })
      return(sel_widget)
    }
    
    Cars <- tibble(
      Brand = c("Tesla", "Kia", "Toyota"),
      Model = c("Model X", "Seltos", "Corolla"),
      Type = list(
        list("normal car", "sports car", "luxury car"),
        list("normal car", "sports car", "luxury car"),
        list("normal car", "sports car", "luxury car")
      )
    )
    
    Cars$selectize <- CreateWidget(Cars, ns)
    glimpse(Cars) # check how the df looks like
    
    output$car_table <- renderDT({
      datatable(Cars[, c("Brand", "Model", "selectize")], 
                escape = FALSE, rownames = FALSE, selection = 'none',
                options = list(
                  paging = FALSE, 
                  searching = FALSE, 
                  dom = 't',
                  preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                  drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
                ))
    }, server = FALSE)
    
    # Reactive expression to collect selected values
    selected_cars <- reactive({
      selected <- sapply(Cars$Brand, function(x) {
        input[[paste0("car_sel_", x)]]
      })
      selected <- selected[!sapply(selected, is.null)]
      selected
    })
    
    observe({
      print(names(input))
    })
    
    # Output the selected values
    output$selected_cars <- renderText({
      selected_values <- selected_cars()
      if (length(selected_values) == 0) {
        "No cars selected"
      } else {
        paste("Selected cars:", paste(selected_values, collapse = ", "))
      }
    })
    
    observeEvent(input[["main-car_sel_Tesla"]],
                 print(input[["main-car_sel_Tesla"]])
    )
    
    # print all input objects to the console
    # observe({
    #   print(reactiveValuesToList(input))
    # })
    
  })
}
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.