使用 R Shiny 中的操作按鈕將行從一個 DT 移動到其他 DT

Question

更新

我正在嘗試使用shiny和DT制作應用程序， 類似於 Shree here 接受的答案。 我想，你，有以下補充：

1. 從 Shree 擴展解決方案，以便左側（源）的DT中的項目可以移動到右側和后面的多個表中並且可以擴展，以便我可以決定要在右側放置多少表. 也就是說，左邊表格中的不同項目可以go在右邊不同的表格中。
2. 此外，在右側的每個表格旁邊都有雙箭頭按鈕，這樣可以通過單擊雙箭頭按鈕來添加或刪除表格中的所有項目，而不僅僅是用於移動所選變量的單箭頭按鈕，就像這里，但仍然可以決定是否顯示它們。
3. 右側的表格即使為空也可見。

有人可以幫忙嗎？

Answer 1

如前所述， shiny 模塊是解決此問題的一種優雅方法。 您必須傳遞一些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 和服務器，並且由於命名空間技術，名稱只需要在一個模塊中是唯一的（並且每個模塊以后也必須有一個唯一的名稱）。 該模塊可以通過傳遞給callModule的reactives與主應用程序通信（請注意，我仍在使用舊功能，因為我尚未更新我的 shiny 庫），或者從服務器 function 返回。

在主應用程序中，我們有一個按鈕，它動態插入 UI 並調用callModule來激活邏輯。 observers也在同一個調用中生成，以使服務器邏輯工作。

Answer 2

為了推廣到任意數量的表，我會使用一個模塊。 該模塊將包含單個DT的 GUI 和邏輯。 對於“輸入 DT”（從中接收行的表）和“輸出 DT”（向其發送行的表），它將具有 arguments。 一個或兩個都可以是NULL 。 GUI 將顯示DT並有一個小部件來啟動各種“發送行”命令。 有關模塊的更多詳細信息，請參見此處。

至於您無法從源表中刪除行：我對DT不太熟悉，但我相信您需要使用代理：正如本頁所述“在 Shiny 應用程序中呈現表后，您可以使用從dataTableProxy()返回的代理 object 來操作它。當前支持的方法是selectRows() 、 selectColumns() 、 selectCells() 、 selectPage()和 addRow addRow() 。"。

Answer 3

要獲得雙箭頭按鈕，您可以使用：

actionButton("add_all", label = NULL, icon("angle-double-right"), 
                                  lib = "font-awesome")

請注意， ?icon鏈接到 fontawesome 頁面，該頁面提供雙箭頭圖標： https://fontawesome.com/icons?d=gallery&q=double%20arrow&m=free 。

要刪除所有項目，您只需切換到默認 state：

observeEvent(input$remove_all, {
  mem$selected <- select_init
  mem$pool <- pool_init
})

其中默認 state 定義為：

pool_init <- data.frame(data = LETTERS[1:10])
select_init <- data.frame(data = "")

要添加所有行，您基本上可以切換狀態：

mem$selected <- pool_init
mem$pool <- select_init

請注意，我使用（幾乎）空的 data.frame 來確保顯示數據表，即使它是空的。 這不是很優雅，因為它有一個空字符串。 可能有更好的方法。 例如，如果您添加一行並再次取消選擇它，則表格為空，它顯示No data available in table 。 這實際上看起來更好。

完全可重現的例子：

library(shiny)
library(DT)

ui <- fluidPage(
  br(),
  splitLayout(cellWidths = c("40%", "10%", "40%", "10%"),
              DTOutput("pool"),
              list(
                br(),br(),br(),br(),br(),br(),br(),
                actionButton("add", label = NULL, icon("arrow-right")),
                br(),br(),
                actionButton("remove", label = NULL, icon("arrow-left"))
              ),
              DTOutput("selected"),
              list(
                br(),br(),br(),br(),br(),br(),br(),
                actionButton("add_all", label = NULL, icon("angle-double-right"), 
                              lib = "font-awesome"),
                br(),br(),
                actionButton("remove_all", label = NULL, icon("angle-double-left"), 
                              lib = "font-awesome")
              )
  )
)


pool_init <- data.frame(data = LETTERS[1:10])
select_init <- data.frame(data = "")

server <- function(input, output, session) {
  
  mem <- reactiveValues(
    pool = pool_init, selected = select_init
  )
  
  observeEvent(input$add, {
    req(input$pool_rows_selected)
    mem$selected <- rbind(isolate(mem$selected), mem$pool[input$pool_rows_selected, , drop = F])
    mem$selected <- mem$selected[sapply(mem$selected, nchar) > 0, , drop = FALSE]
    mem$pool <- isolate(mem$pool[-input$pool_rows_selected, , drop = F])
  })
  
  observeEvent(input$remove, {
    req(input$selected_rows_selected)
    mem$pool <- rbind(isolate(mem$pool), mem$selected[input$selected_rows_selected, , drop = F])
    mem$pool <- mem$pool[sapply(mem$pool, nchar) > 0, , drop = FALSE]
    mem$selected <- isolate(mem$selected[-input$selected_rows_selected, , drop = F])
  })
  
  observeEvent(input$add_all, {
    mem$selected <- pool_init
    mem$pool <- data.frame(data = "")
  })
  
  observeEvent(input$remove_all, {
    mem$selected <- select_init
    mem$pool <- pool_init
  })
  
  
  output$pool <- renderDT({
    mem$pool
  })
  
  output$selected <- renderDT({
    mem$selected
  })
}

shinyApp(ui, server)

關於多個表的要求，請參閱我的評論。