Drop-on functionality in table in Shiny

Question

I am searching for a method (package) that enables me to 'drop' a row from one table on a row in another table. The server-side functionality that I am envisioning with it is that I can create some logic that will update the destination table. Unfortunately, I have not been successful prototyping this with the packages with the available shiny packages I could find.

The idea of the MVP concept in the code below is to assign (with drag 'n drop on) one of the callers in the top table to a row in the second table.

The closes I have come to it, is the following:

library(shiny)
library(shinyjqui)
library(tidyverse)

ui <- fluidPage(
  h1("UI functionality: Drop-on table"),
  h3("Callers - (source)"),
  tableOutput("callers"),
  h3("Calls to be made - (destination)"),
  tableOutput("calls_to_be_made"),
  hr()
)

server <- function(input, output, session) {
  
  callers <- tibble(
    Caller = c("Jerry", "Donald")
  )
  
  calls_to_be_made <- tibble(
    Name = c("John", "Fred", "Bill", "Freddy"),
    PhoneNumber = c("0123 456 785", "0123 456 6453", "9876 532 432","235 63 430"),
    Caller = c("Jerry",NA,NA,NA )
  )
  
  jqui_sortable(
    ui      = "#callers table",
    options = list(items = "tbody tr", connectWith = "#calls_to_be_made table")
  )

  jqui_sortable(
    ui      = "#calls_to_be_made table",
    options = list(items = "tbody tr")
  )

  output$callers <-  renderTable(callers, rownames = T)
  output$calls_to_be_made <-  renderTable(calls_to_be_made, rownames = T)
}

shinyApp(ui, server)

I have tried solutions with the shinyjqui functions jqui_draggable() and jqui_droppable() but those attempts didn't work out and I have the feeling that they were actually further away from what the code above sketches.

I am looking for creative ideas and suggestions to implement this functionality. Hopefully some of you who read this question will have create suggestions of accomplishing this functionality in shiny.

user_16094100 · Answer

You can make an interface using {shinyjqui} that allows you to drag cells from some table, drop them into a different table, and have shiny update the underlying data frame of the table the draggable was dropped in.

First we need to define our draggable and droppable in our server function.

  jqui_draggable(
    ui = "#callers td",
    options = list(
      revert = "invalid",
      helper = "clone"))
  
  droppable <- function() {
    jqui_droppable(
      ui = "#calls_to_be_made td",
      options = list(
        drop = JS("function(event, ui) {
                     Shiny.setInputValue(\"update_cells\", {
                       source_col: ui.draggable.index(),
                       source_row: ui.draggable.parent().index() + 1,
                       dest_col: $(this).index(),
                       dest_row: $(this).parent().index() + 1
                     });
                   }")))
  }

  droppable() #Initialisation

There are a couple of things going on here.

First, the jqui_droppable call is encapsulated in a function (droppable), because we need to call it again later.

Second, we use Shiny.setInputValue() (a javascript function) to send the row- and column indices of the cell that was dropped (source_*) and the cell that was dropped on (dest_*) to the shiny backend. Javascript indices start at 0 and R indices at 1, so we offset the JS ones to match the internal R ones. However, because rownames take up a column in the HTML table, but not in the R data frame, we do not need to offset the column indices.

Next we make calls_to_be_made reactive and write the logic that updates the data frame server side.

  calls_to_be_made_react <- reactiveVal(calls_to_be_made)

  observeEvent(input$update_cells, {
    ## Update dataset
    if (min(unlist(input$update_cells)) > 0) {
      updated_ctbm <- calls_to_be_made_react()
      ## Specify what row and column to drop in
      updated_ctbm[
        input$update_cells[["dest_row"]],
        "Caller"] <- callers[
          input$update_cells[["source_row"]],
          input$update_cells[["source_col"]]]
      
      calls_to_be_made_react(updated_ctbm)

      ## Make sure the newly drawn table becomes droppable again
      droppable()
    }
  })

The condition in the if-statement checks if rownames are being dragged & dropped and does not update the data frame when that is the case. This condition could be extended to some sort of validation function that limits what cells can be dropped on by which draggable cell, but that is beyond the scope of this question.

Inside the observableEvent is also where we call our droppable function again. Because shiny redraws the entire table, the code that makes that table droppable needs to be run again as well.

Lastly we need to update the output call, so it uses the reactive calls_to_be_made.

  output$calls_to_be_made <-  renderTable(calls_to_be_made_react(), rownames = T)

This gives the following server function that does what you are asking for.

server <- function(input, output, session) {

  callers <- tibble(
    Caller = c("Jerry", "Donald")
  )

  calls_to_be_made <- tibble(
    Name = c("John", "Fred", "Bill", "Freddy"),
    PhoneNumber = c("0123 456 785", "0123 456 6453", "9876 532 432","235 63 430"),
    Caller = c("Jerry",NA,NA,NA )
  )

  jqui_draggable(
    ui = "#callers td",
    options = list(
      revert = "invalid",
      helper = "clone"))
  
  droppable <- function() {
    jqui_droppable(
      ui = "#calls_to_be_made td",
      options = list(
        drop = JS("function(event, ui) {
                     Shiny.setInputValue(\"update_cells\", {
                       source_col: ui.draggable.index(),
                       source_row: ui.draggable.parent().index() + 1,
                       dest_col: $(this).index()
                       dest_row: $(this).parent().index() + 1
                     });
                   }")))
  }

  droppable() #Initialisation

  calls_to_be_made_react <- reactiveVal(calls_to_be_made)

  observeEvent(input$update_cells, {
    ## Update dataset
    if (min(unlist(input$update_cells)) > 0) {
      updated_ctbm <- calls_to_be_made_react()
      ## Specify what row and column to drop in
      updated_ctbm[
        input$update_cells[["dest_row"]],
        "Caller"] <- callers[
          input$update_cells[["source_row"]],
          input$update_cells[["source_col"]]]
      
      calls_to_be_made_react(updated_ctbm)

      ## Make sure the newly drawn table becomes droppable again
      droppable()
    }
  })
  
  output$callers <-  renderTable(callers, rownames = T)
  output$calls_to_be_made <-  renderTable(calls_to_be_made_react(), rownames = T)
}

Drop-on functionality in table in Shiny

1 Answers