r - Shiny 表格中的下拉功能

Question

我正在寻找一种方法(包)，它使我能够从一个表 中“删除”另一个表中的一行 中的一行。我设想的服务器端功能是我可以创建一些更新目标表的逻辑。不幸的是，我没有成功地使用我能找到的可用 Shiny 包来制作原型(prototype)。
下面代码中 MVP 概念的想法是将顶部表中的一个调用者分配(拖放)到第二个表中的一行。
我已经结束了，如下:

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)

我已经尝试过使用 shinyjqui 函数 jqui_draggable() 和 jqui_droppable() 的解决方案，但这些尝试没有成功，我觉得它们实际上离上面的代码草图更远。
我正在寻找实现此功能的创意和建议。希望读到这个问题的你们中的一些人会提出以 Shiny 的方式完成这个功能的建议。

Answer 1

您可以使用 {shinyjqui} 制作一个界面，该界面允许您从某些
表，将它们放到不同的表中，并进行 Shiny 的更新
可拖动的表的基础数据框。
首先，我们需要在我们的服务器函数中定义我们的 draggable 和 droppable。

  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

这里有几件事情正在发生。
首先，jqui_droppable 调用封装在一个函数( droppable )中，
因为我们稍后需要再次调用它。
其次，我们使用Shiny.setInputValue()(一个 javascript 函数)来发送行和
被删除的单元格的列索引 ( source_* ) 和单元格
被放到 ( dest_* ) 到 Shiny 的后端。 Javascript 索引开始
在 0 和 R 索引在 1，所以我们偏移 JS 的以匹配
内部R。但是，因为行名在
HTML 表，但不在 R 数据框中，我们不需要偏移列索引。
接下来我们使 calls_to_be_made 响应式(Reactive)并编写逻辑
更新数据框服务器端。

  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()
    }
  })

if 语句中的条件检查行名是否被拖放，并且在拖放时不更新数据框
案件。这个条件可以扩展到某种验证
限制可拖动单元格可以放置哪些单元格的功能，但这超出了本问题的范围。observableEvent 内部也是我们调用 droppable 的地方
再次发挥作用。因为shiny重绘了整个表格，代码
使该表也需要再次运行。
最后我们需要更新输出调用，所以它使用响应式(Reactive)calls_to_be_made 。

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

这提供了以下服务器功能，可以满足您的要求。

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)
}