How to use a Shiny handler to pass output of R function into JS section of Shiny code?

Question

我对 R 有一些经验，但对 JS 知之甚少。 下面的可重现代码使用 JS 运行 package jsTreeR，因此用户可以自定义构建层次结构树。 该代码允许用户将元素从树的“菜单”部分拖放到下方的“拖动此处以构建树”部分，拖动的项目及其拖入顺序反映在第一个 dataframe 中呈现在上部正确的。

I would like to inject the "choice" output of the R/dplyr addLabel() custom function ( addLabel() outputs shown in the 2nd rendered dataframe when running the code) into each element of the tree, as illustrated below, using a Shiny处理程序。 I use Shiny.setInputValue() in the JS section of the code to send values to the R server, generating the first rendered dataframe, but now I need to figure out how to send values back from R server and into the user/JS section使用 Shiny 处理程序的代码。 我在下面的代码中尝试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)

Answer 1

由于您在copy_node.jstree事件处理程序中添加了消息处理程序，因此每次发生新的复制事件时都会覆盖该处理程序。 在这种情况下，这可能没问题：您可以通过重命名最后复制的节点来始终使用它来处理来自 R 的injectLabel消息。 但是，您实际上需要在 shiny 消息处理程序中进行重命名。 像这样的东西：

Shiny.addCustomMessageHandler("injectLabel", function(newLabel) {
    instance.rename_node(node, newLabel);
});

现在您还需要考虑应该从 R 向浏览器发送哪些数据。 在这里，您只需要最新复制节点的新名称。 相应地更改有效负载：

observe({
  newLabel <- tail(addLabel()$choice, 1)
  session$sendCustomMessage("injectLabel", newLabel)
})

通过这两项更改，您的应用程序应该可以按预期工作。