2

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?

panman
  • 1,179
  • 1
  • 13
  • 33
  • In general it would be good if you show us what you tried so far. Also makes it easier to get what you want to achieve. For 1) i am not sure if you want to show the same output for all n tables on the right or if you even want to be able to select a subset of the n tables and only add rows to them. for 2) and 3) i added an answer. – Tonio Liebrand Jul 13 '20 at 19:54
  • @Tonio Liebrand: Sorry, you are right, I was unclear for #1. What I meant is that different items from the table on the left go to different tables on the right. I have edited the question. – panman Jul 13 '20 at 20:19

3 Answers3

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

Tonio Liebrand
  • 17,189
  • 4
  • 39
  • 59
  • Thank you for the explanation and the solution. Concerning the requirement for the multiple tables, I have updated the question. I hope it is now clearer - move different items from the left to different tables on the right. – panman Jul 14 '20 at 12:11
  • Tonio? Any news on the multiple tables on the right? – panman Jul 16 '20 at 12:01
  • i worked on it but ran out of time. Adding modules and have dynamic memory for each of these tables is more work, but i think you have a good answer by now right? – Tonio Liebrand Jul 17 '20 at 08:04
3

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.

thothal
  • 16,690
  • 3
  • 36
  • 71
  • Thank you very much! The solution is rather impressive. Just one additional question/request. Can this be generalized, so that the number of tables on the right is passed as a function argument of the module, so the module can be reused multiple times (say in different tabs in the application) instead of having the "Add Table" button. – panman Jul 16 '20 at 16:29
  • Well, you can call the module from wherever you want. You do not need to add it dynamically. In any UI you can also simply call the UI function directly. for example `fluidPage(receiver_ui("my_fixed_ui", "odd"))` would work as well. So if you want to have several tables, just use sort of a loop, e.g. `fluidPage(lapply(1:4, function(i) receiver_ui(paste0("row",i), "odd"))` – thothal Jul 17 '20 at 07:12
  • Thank you. I tried the suggestions in your comment, but I am getting empty blue fields with buttons on top of the page. Sorry, I am new to Shiny and (especially) the modules are a magic to me. Can you modify the solution? – panman Jul 17 '20 at 15:55
  • You also need to define the server function of course. Did you read the article in the link? – thothal Jul 20 '20 at 07:02
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().".

Limey
  • 10,234
  • 2
  • 12
  • 32