如何使用 Shiny 处理程序将 R 函数的输出传递到 Shiny 代码的 JS 部分？

问：

我对 R 有一些经验，但对 JS 知之甚少或理解不多。下面的可重现代码使用 JS 运行包 jsTreeR，以便用户可以自定义构建层次结构树。该代码允许用户将元素从树的“菜单”部分拖放到下面的“拖动到此处以构建树”部分，拖动的项目及其拖动顺序反映在右上角呈现的第一个数据帧中。

我想使用 Shiny 处理程序将 R/dplyr 自定义函数的“选择”输出（运行代码时在第二个呈现的数据帧中显示的输出）注入到树的每个元素中，如下图所示。我在代码的 JS 部分使用将值发送到 R 服务器，生成第一个呈现的数据帧，但现在我需要弄清楚如何使用 Shiny 处理程序将值从 R 服务器发送回代码的用户/JS 部分。我尝试使用下面的代码，但它不起作用。我做错了什么？addLabel()addLabel()Shiny.setInputValue()Shiny.addCustomMessageHandler()

我一直在参考 https://shiny.rstudio.com/articles/communicating-with-js.html 来解释处理程序，但他们的例子对我来说有点太复杂了，我无法理解。（编辑：请参阅评论以获取更好的解释来源。

这说明了我正在尝试做的事情（我按该顺序拖放了 Bog/Bog/Hog/Hog/Bog）：

可重现的代码（在运行下面的代码之前，请参阅下面修改后的代码上方的注释）：

library(jsTreeR)
library(shiny)

nodes <- list(
  list(
    text = "Menu",
    state = list(opened = TRUE),
    children = list(
      list(text = "Bog",type = "moveable"),
      list(text = "Hog",type = "moveable")
    )
  ),
  list(
    text = "Drag here to build tree",
    type = "target",
    state = list(opened = TRUE)
  )
)

dnd <- list(
  always_copy = TRUE,
  inside_pos = "last", 
  is_draggable = JS(
    "function(node) {",
    "  return node[0].type === 'moveable';",
    "}"
  )
)

mytree <- jstree(
  nodes, 
  dragAndDrop = TRUE, dnd = dnd, 
  checkCallback = checkCallback,
  contextMenu = list(items = customMenu),
  types = list(moveable = list(), target = list())
)

script <- '

$(document).ready(function(){
  $("#mytree").on("copy_node.jstree", function(e, data){
    var orgid = data.original.id;
    var node    = data.node;
    var id      = node.id;
    var basename= node.text;
    var text    = basename; 
    Shiny.setInputValue("choice", text, {priority: "event"});
    var instance  = data.new_instance;
    instance.rename_node(node, text);
    node.type     = "item";
    Shiny.addCustomMessageHandler("injectLabel",function(addLabel){
      node.basename = addLabel;
      });
    node.orgid    = orgid;
    var tree        = $("#mytree").jstree(true);
  });
});
'

ui <- fluidPage(
  tags$div(class = "header", checked = NA,tags$p(tags$script(HTML(script)))),
  fluidRow(
    column(width = 4,jstreeOutput("mytree")),
    column(width = 8,fluidRow(
      h5("First datframe reactively replicates tree elements as they are dragged:"),
      verbatimTextOutput("choices"),
      h5("Second datframe generated by R reactive function `addLabel`:"),
      verbatimTextOutput("choices2")
      )
    )
  )
)

server <- function(input, output, session){
  output[["mytree"]] <- renderJstree(mytree)
  
  Choices <- reactiveVal(data.frame(choice = character(0)))
  
  observeEvent(input[["choice"]], {Choices(rbind(Choices(), data.frame(choice = input[["choice"]])))} )
 
  output[["choices"]] <- renderPrint({Choices()})
  
  addLabel <- reactive({if(nrow(Choices()>0)){
    addLabel <- Choices()
    addLabel <- addLabel %>% 
    group_by(choice) %>%
    mutate(choiceCount = row_number()) %>%
    ungroup() %>%
    mutate(choice = paste(choice,"-",choiceCount)) %>%
    select(-choiceCount)  
    addLabel  
  }})
  
  output[["choices2"]] <- renderPrint({
    if(nrow(Choices())>0) {as.data.frame(addLabel())}
    else {cat('Waiting for drag and drop to begin')}
  }) 
  
  observe({
    session$sendCustomMessage("injectLabel", addLabel()) # send addLabel to the browser for inserting into the tree
  })
  
 }

shinyApp(ui=ui, server=server)

以下是反映 Mikko 解决方案的修改后的工作代码。请注意，如果不从对象中删除 and 行并添加到库中，上面的 OP 代码将不起作用。OP 代码仅在我的机器上运行，因为并且已经通过运行完整的应用程序加载到内存中;其中一个令人讨厌的定期通宵重启（更新一些无关紧要的软件，如打印机驱动程序）清除了我的内存，如果没有下面包含的修复程序，OP 代码将无法运行：checkCallback = checkCallbackcontextMenu = list(items = customMenu)mytree <- jstree()dplyrcheckCallbackcontextMenu

library(dplyr)
library(jsTreeR)
library(shiny)

nodes <- list(
  list(
    text = "Menu",
    state = list(opened = TRUE),
    children = list(
      list(text = "Bog",type = "moveable"),
      list(text = "Hog",type = "moveable")
    )
  ),
  list(
    text = "Drag here to build tree",
    type = "target",
    state = list(opened = TRUE)
  )
)

dnd <- list(
  always_copy = TRUE,
  inside_pos = "last", 
  is_draggable = JS(
    "function(node) {",
    "  return node[0].type === 'moveable';",
    "}"
  )
)

mytree <- jstree(
  nodes, 
  dragAndDrop = TRUE, dnd = dnd, 
  types = list(moveable = list(), target = list())
)

script <- '

$(document).ready(function(){
  $("#mytree").on("copy_node.jstree", function(e, data){
    var orgid = data.original.id;
    var node    = data.node;
    var id      = node.id;
    var basename= node.text;
    var text    = basename; 
    // the JS shiny code below sends tree data to the server for output to the first dataframe
    Shiny.setInputValue("choice", text, {priority: "event"});
    var instance  = data.new_instance;
    instance.rename_node(node, text);
    node.type     = "item";
    // the shiny handler below receives newLabel from the server for injecting labels to tree
    Shiny.addCustomMessageHandler("injectLabel", function(newLabel) {
      instance.rename_node(node, newLabel);
    });
    node.orgid    = orgid;
    var tree        = $("#mytree").jstree(true);
  });
});
'
ui <- fluidPage(
  tags$div(class = "header", checked = NA,tags$p(tags$script(HTML(script)))),
  fluidRow(
    column(width = 4,jstreeOutput("mytree")),
    column(width = 8,fluidRow(
      h5("First datframe reactively replicates tree elements as they are dragged:"),
      verbatimTextOutput("choices"),
      h5("Second datframe generated by R reactive function `addLabel`:"),
      verbatimTextOutput("choices2")
      )
    )
  )
)

server <- function(input, output, session){
  output[["mytree"]] <- renderJstree(mytree)
  
  Choices <- reactiveVal(data.frame(choice = character(0)))
  
  observeEvent(input[["choice"]], {Choices(rbind(Choices(), data.frame(choice = input[["choice"]])))} )
 
  output[["choices"]] <- renderPrint({Choices()})
  
  addLabel <- reactive({if(nrow(Choices()>0)){
    addLabel <- Choices()
    addLabel <- addLabel %>% 
    group_by(choice) %>%
    mutate(choiceCount = row_number()) %>%
    ungroup() %>%
    mutate(choice = paste(choice,"-",choiceCount)) %>%
    select(-choiceCount)  
    addLabel  
  }})
  
  output[["choices2"]] <- renderPrint({
    if(nrow(Choices())>0) {as.data.frame(addLabel())}
    else {cat('Waiting for drag and drop to begin')}
  }) 
  
  # shiny handler sends the new label to the client (UI) inside JS code
  observe({
    newLabel <- tail(addLabel()$choice, 1)
    session$sendCustomMessage("injectLabel", newLabel)
  })
  
 }

shinyApp(ui=ui, server=server)