Move rows from one DT to other DTs using action buttons in R Shiny

Question

UPDATE

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. 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.

Can someone help with these?

Answer 1

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.

A fully working example looks as follows:

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)

Explanation

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.

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.

Answer 2

To generalise to an arbitrary number of tables, I'd use a module. The module would contain the GUI and logic for a single DT . It would have arguments for the "input DT" (the table from which rows are received) and the "output DT" (the table to which rows are sent). Either or both could be NULL . The GUI would display the DT and have a widgets to initiate the various "send rows" commands. See here for more details on modules.

As for your inability to remove rows from the source table: I'm not overly familiar with DT , but I believe you need to use a proxy: as this page says "After a table has been rendered in a Shiny app, you can use the proxy object returned from dataTableProxy() to manipulate it. Currently supported methods are selectRows() , selectColumns() , selectCells() , selectPage() , and addRow() .".

Answer 3

To get double arrow buttons, you can use:

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

Note that ?icon links to the fontawesome page, which provides double arrow icons: https://fontawesome.com/icons?d=gallery&q=double%20arrow&m=free .

To remove all items you can just switch to the default state:

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

where the default state was defined as:

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

To add all rows you can basically just switch the states:

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

Note that i use an (almost) empty data.frame to ensure that a datatable is shown even if it is empty. That is not very elegant as it has an empty string in it. There might be better ways for that. Eg if you add a row and deselect it again, so that the table is empty it shows No data available in table . That actually looks better.

Full reproducible example:

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)

Concerning the requirements for multiple tables, please see my comment.