在闪亮的应用程序中动态创建可编辑的DT

Question

我想创建一个具有以下流程的应用程序：

1. 用户选择一些数据组
2. 这些组成为动态选项卡，每个选项卡都包含可使用相应组进行编辑的子集 DT
3. 每个选项卡都包含一个额外的反应DT，它对 #2 中创建的可编辑 DataTable 中的更改做出反应（在下面的示例中，只需将数字列乘以 2）

这是执行 #1 和 #2 的示例。但是，#3 不起作用，因为通常通过可编辑公开的信息DT不会出现在 my 中input，可能是由于某些范围或渲染顺序问题。

library(shiny)
library(DT)
library(dplyr)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel = 
      sidebarPanel(
        selectInput("cars", "Pick a vehicle", rownames(mtcars), multiple = T),
        actionButton("add", "Create Tabs")
      ),
    mainPanel = 
      mainPanel(
        tabsetPanel(
          id = "panel"
        )
      )
  )
)

server <- function(input, output, session) {
  
  df <- tibble::rownames_to_column(mtcars, "car")
  data <- reactiveVal()
  observe({
    req(df, input$cars)
    # Step 1) split data by user input groups
    df |>
      filter(car %in% input$cars) |>
      split(~ car) |>
      data()
  })
  
  observeEvent(input$add, {
    req(input$cars, data())
    
    # Step 2) Editable DT with respective group
    # Creates output$<car name>
    lapply(input$cars, \(x) { output[[x]] <- renderDT(data()[[x]], 
                                                      rownames = F,
                                                      editable = "cell",
                                                      selection = "none")
    })
    
    # Step 3) Reactive DT that responds to user changes
    # Creates output$<car name>tbl
    lapply(input$cars, \(x) { output[[paste0(x, "tbl")]] <- renderDT({
      mutate(data()[[x]], across(where(is.numeric), ~ . * 2))
      })
    })
    
    # insert dynamic tabs with data
    lapply(input$cars, \(x) {
      insertTab("panel", tabPanel(x, 
                                  DTOutput(x), # access output$<car name>
                                  br(),
                                  DTOutput(paste0(x, "tbl")) # access output$<car name>
      )
      )
    })
    # input does not contain input$<vehicle selection>_cell_edit
    print(names(input)) # [1] "cars"  "add"   "panel"
  })
}

shinyApp(ui, server)

---

您可以在此示例中看到，更改mpg为 10 后，第二个表不会反应性地显示 10*2 = 20。

DT通常，当您在服务器端创建一个类似的对象时output$table <- renderDT(iris , editable = "cell")，您可以访问存储在input对象中的信息（请参阅2.2 DataTables信息）。其中之一是input$table_cell_edit（input$table_bc 作业是output$table <-）可用于创建反应性事件。

由于我需要动态地执行此操作，因此我无法以这种方式对分配进行硬编码。lapply确实有效，我可以引用动态创建的项目（请参阅 参考资料DTOutput(...)）。但是，您可以从语句中看到，当通过 完成分配print时，不会创建 DataTable 信息来捕获用户交互。outputlapply

这个SO问题有类似的问题，但没有回应。与此DT GitHub 问题相同，该问题也因没有响应而关闭。

问题

所以，我的问题是如何DT在output对象中动态创建可编辑对象，以便我可以访问input有关编辑的对象信息以创建反应链？

回答

在任何响应中，如果代码能够完成上述 1-3 的任务，那就太好了，而且：

• 当用户编辑时调整第一个表的数据
• 当用户编辑第一个表时调整第二个表的数据
• 提供有关为什么我的代码不起作用的更多详细信息（如何访问 DataTablesoutput$<car name>和output$<car name>tbl，但无法input访问任何信息？）

Answer 1

下面的代码应该可以实现您的目标。我不需要做任何事情，只需添加“# APPLY EDITS”部分，看起来编辑所需的输入是在打开选项卡时创建的。

我还添加了options = list(dom = "t")几个地方来消除表格中的混乱（这消除了最终应用程序可能不需要的“搜索”等功能，请参阅https://datatables.net/reference/option/dom ）更多详细信息），并rownames = F为修改后的表进行设置。请注意，如果没有行名，我们需要+ 1ininput[[paste0(x, "_cell_edit")]][["col"]] + 1来获取截至 DT（版本 0.27）的正确列。

希望这可以帮助！如果这个答案与通常的约定不一致，我深表歉意，我是 Stack Overflow 的新手。

library(shiny)
library(DT)
library(dplyr)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel = 
      sidebarPanel(
        selectInput("cars", "Pick a vehicle", rownames(mtcars), multiple = T),
        actionButton("add", "Create Tabs"),
        actionButton("update", "Update")
      ),
    mainPanel = 
      mainPanel(
        tabsetPanel(
          id = "panel"
        )
      )
  )
)

server <- function(input, output, session) {
  
  df <- tibble::rownames_to_column(mtcars, "car")
  data <- reactiveVal()
  observe({
    req(df, input$cars)
    # Step 1) split data by user input groups
    df |>
      filter(car %in% input$cars) |>
      split(~ car) |>
      data()
  })
  
  observeEvent(input$add, {
    req(input$cars, data())
    
    # Step 2) Editable DT with respective group
    # Creates output$<car name>
    lapply(input$cars, \(x) { output[[x]] <- renderDT(data()[[x]], 
                                                      rownames = F,
                                                      editable = "cell",
                                                      selection = "none",
                                                      options = list(dom = "t"))
    })
    
    # Step 3) Reactive DT that responds to user changes
    # Creates output$<car name>tbl
    lapply(input$cars, \(x) { output[[paste0(x, "tbl")]] <- renderDT(rownames = F, options = list(dom = "t"), {
      mutate(data()[[x]], across(where(is.numeric), ~ . * 2))
    })
    })
    
    # insert dynamic tabs with data
    lapply(input$cars, \(x) {
      insertTab("panel", tabPanel(x, 
                                  DTOutput(x), # access output$<car name>
                                  br(),
                                  DTOutput(paste0(x, "tbl")) # access output$<car name>
      )
      )
    })
    # input does not contain input$<vehicle selection>_cell_edit
    print(names(input)) # [1] "cars"  "add"   "panel"
  })
  
  # APPLY EDITS
  observeEvent(input$update, {
    
    lapply(input$cars, \(x) {
      holder <- as.data.frame(data()[[x]])
      holder[input[[paste0(x, "_cell_edit")]][["row"]], input[[paste0(x, "_cell_edit")]][["col"]] + 1] <- input[[paste0(x, "_cell_edit")]][["value"]]
      df[which(df == holder[1, 1], arr.ind = T)[1], ] <- holder
      df <<- df
    })
    
    data(df |>
           filter(car %in% input$cars) |>
           split(~ car))
    
    print("edit saved")
  })
}

shinyApp(ui, server)

Answer 2

TL;DR：如果您只是添加处理编辑的逻辑，并且 \xe2\x80\x9cdidn\xe2\x80\x99 不用担心，那么您的代码就可以工作。\xe2\x80\x9d 要理解为什么需要一些细节。

\n

您正确地注意到，当观察者运行时，您在其中创建的输入不会立即反映在对象中input。\n 中的值input在服务器代码中是只读的。它们由客户端\nJavaScript 在每个反应周期开始时发送。当您调用时，appendTab()您实际上是从服务器 R 进程发送一些 HTML 到客户端 Web 浏览器，并要求使用 JavaScript 将其包含在页面中。只有在下一个反应周期中，客户端代码才会执行​​此操作。已执行，并且input已包含动态创建的值。

\n

但是，输入不存在并不意味着您可以\xe2\x80\x99t 使用它们。input毕竟，对象本质上是一个奇特的列表，用于跟踪所请求的键。如果访问的键不存在，您只需\nNULL像常规 R 列表一样返回。但重要的是，input对象仍然注册对键的反应依赖性，因此当稍后为该键分配值时，请求它的上下文将失效，所有内容都会相应更新。

\n

您提到能够 \xe2\x80\x9caccess\xe2\x80\x9d 创建的输出。但是，调用\nDTOutput()不会访问output对象中的任何数据。它只是\n创建一些 HTML 代码，客户端 JavaScript 可以将其解释为\n用 R 进程发送的结果进行填充；尝试DT::DTOutput("foo")在控制台中执行\n。当您将DT::renderDT()结果分配给output对象时，您就创建了 JS 处理的结果。

\n

将各个部分放在一起，这里\xe2\x80\x99s 是具有您正在寻找的行为的应用程序的代码：

\n

library(shiny)\n\nui <- fluidPage(\n  sidebarLayout(\n    sidebarPanel(\n      selectInput("cars", "Pick vehicles", rownames(mtcars), multiple = TRUE)\n    ),\n    mainPanel(tabsetPanel(id = "tabset"))\n  )\n)\n\nserver <- function(input, output, session) {\n  # Keep track of user-edited data\n  car_datasets <- reactiveValues()\n\n  # Create tabs for selections as needed\n  observeEvent(input$cars, {\n    added_cars <- setdiff(input$cars, names(car_datasets))\n    lapply(added_cars, function(car) {\n      # Populate initial data\n      car_datasets[[car]] <- mtcars[car, ]\n\n      # Create UI panel\n      appendTab("tabset", tabPanel(\n        title = car,\n        DT::DTOutput(NS(car)("original")),\n        DT::DTOutput(NS(car)("transformed"))\n      ), select = TRUE)\n\n      # Create outputs\n      output[[NS(car)("original")]] <- DT::renderDT({\n        DT::datatable(car_datasets[[car]], editable = "cell", selection = "none")\n      })\n      output[[NS(car)("transformed")]] <- DT::renderDT({\n        dplyr::mutate_if(car_datasets[[car]], is.numeric, \\(x) x * 2)\n      })\n\n      # Create observer to handle edits\n      edit_input_id <- paste0(NS(car)("original"), "_cell_edit")\n      observeEvent(input[[edit_input_id]], {\n        car_datasets[[car]] <- DT::editData(car_datasets[[car]], input[[edit_input_id]])\n      })\n    })\n  })\n}\n\nshinyApp(ui, server)\n

\n