使用R Shiny中的操作按钮将行从一个DT移动到其他DT [英] Move rows from one DT to other DTs using action buttons in R Shiny

问题描述

更新

我正在尝试使用 shiny 和 DT ，类似于Shree在这里接受的答案。我希望您可以添加以下内容：

I am trying to make an app using shiny and DT, similar to the accepted answer from Shree here. I would like, thou, to have the following additions to it:

1. 扩展了Shree的解决方案，从而使 DT中的项目左侧的（源）可以移动到右侧的多个表中，并且可以扩展，以便我可以决定要在右侧放置多少个表。也就是说，与左侧表格不同的项目可以放在右侧的不同表格中。


2. 此外，要在右侧的每个表格旁边设置双箭头按钮，以便可以通过单击双箭头按钮来添加或删除表中的所有项目，不仅是用于移动选定变量的单箭头按钮，类似于此处，但仍然能够决定是否显示它们。


3. 即使在空的情况下，右侧的表也可见。

1. Extend the solution from Shree, so that items from the DT on the left (source) can be moved to more than one table on the right and back and be extensible, so that I can decide how many tables I want to put on the right. That is, different items from the table on the left can go in a different table on the right.
2. In addition, to have double arrow buttons next to each table on the right, so that all items in a table can be added or removed by click on the double arrow buttons, not only the single arrow buttons for moving just selected variables, like here, but still be able to decide whether to display them or not.
3. Tables on the right to be visible even when empty.

有人可以帮忙吗？

推荐答案

如前所述，发光模块是解决此问题的一种优雅方法。您必须传递一些反应性来接收行，并且必须返回一些反应性来发送行/告诉主程序

As already mentioned shiny modules are an elegant way to solve this issue. You have to pass in some reactives for receiving rows and you have to return some reactives to send rows / tell the main table that it should remove the rows it just sent.

一个完整的示例如下：

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)

说明

一个模块包含用户界面和服务器，并借助命名空间技术，名称仅需在一个模块内是唯一的（以后每个模块也必须具有唯一的名称）。该模块可以通过 reactives 与主应用程序通信，这些响应可以传递给 callModule （请注意，我仍在使用

A module contains the UI and the server and thanks to the namespacing techniques, names need only to be unique within one module (and each module must later have also a unique name). The module can communicate with the main app via reactives which are either passed to callModule (please note that I am still using the old functions as I have not yet updated my shiny library), or which are returned from the server function.

在主应用中，我们有一个按钮，可动态插入用户界面和调用 callModule 激活逻辑。 观察者也在同一调用中生成，以使服务器逻辑正常工作。

In the main app, we have a button, which dynamically inserts the UI and calls callModule to activate the logic. observers are also generated in the same call to make the server logic work.

这篇关于使用R Shiny中的操作按钮将行从一个DT移动到其他DT的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！