Transferring Rows between Shiny Module tables

Question

I am attempting to move rows between a source DataTable and DataTables contained within modules. I am having trouble filtering my original table outside the renderDataTable environment so that the correct row is passed to the module. Right now the app runs but is referencing the wrong table with _rows_selected.

My plan was to use the .original_order column as a unique key. I can print this in the UI but I am unable to access this value in the server function (outside of renderDataTable). I tried inserting this:

  filtered_df <- reactive({
    filtered_data <- my_data() %>% filter(cyl >= input$cyl_slide)

    filtered_data
  })

and then referencing filtered_df() instead of my_data() in the renderDataTable function but got the error that the object 'cyl' could not be found. I know the app is not perfect as this is my first attempt at using modules and I adapted the code found here, but the below app does run, I just need to tweak it to move the correct row even when filtered.

library(shiny)
library(DT)
library("shinydashboard")

receiver_ui <- function(id, class) {
  ns <- NS(id)
  fluidRow(
    column(width = 1,
           actionButton(ns("add"), 
                        label = NULL,
                        icon("angle-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 <- reactiveValues(send    = blueprint,
                              receive = blueprint)
  
  trigger_delete <- reactiveValues(trigger = NULL, all = FALSE)
  
order
  output$sink_table <- renderDataTable({
    dat <- data_exch$receive
    dat$.original_order <- NULL
    dat
  })
  
  shift_rows <- function(selector) {
    data_exch$send <- data_exch$receive[selector, , drop = FALSE]
    data_exch$receive <- data_exch$receive[-selector, , drop = FALSE]
  }
  
  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))
  })
  
  ## this is the original code, attempts to pass a reactive were unsuccessful

  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(
    sliderInput("cyl_slide", '', min = 4, max = 8, value = 4)
  ),
  fluidRow(
    column(width = 6, dataTableOutput("source_table")),
    column(width = 6, div(id = "container")),
  ),
  fluidRow(
    box(width = 12,title="Selected ID:",textOutput('id_selected'))
  )
)

orig_data <- mtcars
orig_data$.original_order <- seq(1, NROW(orig_data), 1)
my_data <- reactiveVal(orig_data)

server <- function(input, output, session) {
  #orig_data <- orig_data[orig_data$cyl >= input$cyl_slide,]
  cyl_re <- reactive({input$cyl_slide}) #try this?
   #{orig_data[orig_data$cyl >= cyl_re(),]} why does it need to be reactiveVal and not reactive?
  
  # filtered_df <- reactive({
  #   filtered_data <- my_data() %>% filter(cyl >= input$cyl_slide)
  # 
  #   filtered_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( #I know this is outdated but attempts to reconfigure to moduleServer were unsuccessful because I didn't know where to put the extra arguments (uid, selected_rows,...etc)
      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 <- dat[dat$cyl >= input$cyl_slide,]
    #dat$.original_order <- NULL
    
    output$id_selected = renderText({
      s = input$source_table_rows_selected
      if (length(s)>0 & dat$.original_order[s]!="") {
        dat$.original_order[s]
      }
    })
    
    dat
  })
}


shinyApp(ui, server)

Transferring Rows between Shiny Module tables

Answers (1)

Related Questions