使用 R Shiny 中的操作按钮将行从一个 DT 移动到其他 DT

UPDATE

我正在尝试使用制作一个应用程序shiny and DT, 类似于此处 Shree 接受的答案 https://stackoverflow.com/questions/57853627/moveable-multiple-items-in-r-shiny-boxes-something-similar-to-attached-screens。我想对它进行以下补充：

1. 从 Shree 扩展解决方案，以便来自DT左侧（源）的表格可以移动到右侧和后面的多个表格，并且可以扩展，这样我就可以决定要在右侧放置多少张表格。也就是说，左侧表格中的不同项目可以放入右侧不同的表格中。
2. 此外，右侧每个表格旁边都有双箭头按钮，以便通过单击双箭头按钮可以添加或删除表格中的所有项目，而不仅仅是用于移动选定变量的单箭头按钮，像这儿 https://www.maprecord.com/CM_help/CM_fieldselection.html，但仍然可以决定是否显示它们。
3. 即使右侧的表格为空，也可以看到。

有人可以帮忙解决这些问题吗？

正如已经提到的闪亮的模块 https://shiny.rstudio.com/articles/modules.html是解决这个问题的一种优雅的方法。你必须传递一些reactives用于接收行并且您必须返回一些reactives发送行/告诉主表它应该删除刚刚发送的行。

一个完整的工作示例如下所示：

library(shiny)
library(DT)

receiver_ui <- function(id, class) {
   ns <- NS(id)
   fluidRow(
      column(width = 1,
             actionButton(ns("add"), 
                          label = NULL,
                          icon("angle-right")),
             actionButton(ns("add_all"), 
                          label = NULL,
                          icon("angle-double-right")),
             actionButton(ns("remove"),
                          label = NULL,
                          icon("angle-left")),
             actionButton(ns("remove_all"),
                          label = NULL,
                          icon("angle-double-left"))),
      column(width = 11,
             dataTableOutput(ns("sink_table"))),
      class = class
   )
}

receiver_server <- function(input, output, session, selected_rows, full_page, blueprint) {
   ## data_exch contains 2 data.frames:
   ## send: the data.frame which should be sent back to the source
   ## receive: the data which should be added to this display
   data_exch <- reactiveValues(send    = blueprint,
                               receive = blueprint)
   
   ## trigger_delete is used to signal the source to delete the rows whihc just were sent
   trigger_delete <- reactiveValues(trigger = NULL, all = FALSE)
   
   ## render the table and remove .original_order, which is used to keep always the same order
   output$sink_table <- renderDataTable({
      dat <- data_exch$receive
      dat$.original_order <- NULL
      dat
   })
   
   ## helper function to move selected rows from this display back 
   ## to the source via data_exch
   shift_rows <- function(selector) {
      data_exch$send <- data_exch$receive[selector, , drop = FALSE]
      data_exch$receive <- data_exch$receive[-selector, , drop = FALSE]
   }
   
   ## helper function to add the relevant rows
   add_rows <- function(all) {
      rel_rows <- if(all) req(full_page()) else req(selected_rows())
      data_exch$receive <- rbind(data_exch$receive, rel_rows)
      data_exch$receive <- data_exch$receive[order(data_exch$receive$.original_order), ]
      ## trigger delete, such that the rows are deleted from the source
      old_value <- trigger_delete$trigger
      trigger_delete$trigger <- ifelse(is.null(old_value), 0, old_value) + 1
      trigger_delete$all <- all
   }
   
   observeEvent(input$add, {
      add_rows(FALSE)
   })
   
   observeEvent(input$add_all, {
      add_rows(TRUE)
   })
   
   observeEvent(input$remove, {
      shift_rows(req(input$sink_table_rows_selected))
   })
   
   observeEvent(input$remove_all, {
      shift_rows(req(input$sink_table_rows_current))
   })
   
   ## return the send reactive to signal the main app which rows to add back
   ## and the delete trigger to remove rows
   list(send   = reactive(data_exch$send),
        delete = trigger_delete)
}


ui <- fluidPage(
   tags$head(tags$style(HTML(".odd {background: #DDEBF7;}",
                             ".even {background: #BDD7EE;}",
                             ".btn-default {min-width:38.25px;}",
                             ".row {padding-top: 15px;}"))),
   fluidRow(
      actionButton("add", "Add Table") 
   ),
   fluidRow(
      column(width = 6, dataTableOutput("source_table")),
      column(width = 6, div(id = "container")),
   )
)

server <- function(input, output, session) {
   orig_data <- mtcars
   orig_data$.original_order <- seq(1, NROW(orig_data), 1)
   my_data <- reactiveVal(orig_data)
   
   handlers <- reactiveVal(list())
   
   selected_rows <- reactive({
      my_data()[req(input$source_table_rows_selected), , drop = FALSE]
   })
   
   all_rows <- reactive({
      my_data()[req(input$source_table_rows_current), , drop = FALSE]
   })
   
   observeEvent(input$add, {
      old_handles <- handlers()
      n <- length(old_handles) + 1
      uid <- paste0("row", n)
      insertUI("#container", ui = receiver_ui(uid, ifelse(n %% 2, "odd", "even")))
      new_handle <- callModule(
         receiver_server,
         uid,
         selected_rows = selected_rows,
         full_page = all_rows,
         ## select 0 rows data.frame to get the structure
         blueprint = orig_data[0, ])
      
      observeEvent(new_handle$delete$trigger, {
         if (new_handle$delete$all) {
            selection <- req(input$source_table_rows_current)
         } else {
            selection <- req(input$source_table_rows_selected)
         }
         my_data(my_data()[-selection, , drop = FALSE])
      })
      
      observe({
         req(NROW(new_handle$send()) > 0)
         dat <- rbind(isolate(my_data()), new_handle$send())
         my_data(dat[order(dat$.original_order), ])
      })
      handlers(c(old_handles, setNames(list(new_handle), uid)))
   })
   
   output$source_table <- renderDataTable({
      dat <- my_data()
      dat$.original_order <- NULL
      dat
   })
}


shinyApp(ui, server)

解释

模块包含 UI 和服务器，并且由于命名空间技术，名称只需要在一个模块内是唯一的（并且每个模块以后也必须有一个唯一的名称）。该模块可以通过以下方式与主应用程序通信reactives哪些被传递到callModule（请注意，我仍在使用旧函数，因为我尚未更新我的闪亮库），或者从服务器函数返回的函数。

在主应用程序中，我们有一个按钮，它动态插入 UI 并调用callModule来激活逻辑。observers也在同一调用中生成以使服务器逻辑工作。