为什么这个 Shiny Handler 没有正确更新客户端的 JS 部分？

问：

当运行底部的可重现代码时，我在左侧呈现的树中得到了奇怪的结果，如下图所示。我在使用处理程序或在 JS 脚本中做错了什么？

“Elements” 读取树的位置，“Elements2” 执行一些示例转换，“Elements2” 中的 Element 列应使用 Shiny 处理程序反馈给客户端以重新标记树节点。

可重现的代码：

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",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 <- '
var LETTERS = ["A", "B", "C", "D", "E"];
var Visited = {};
function updateSubItems(parent){
  var tree = $("#mytree").jstree(true);
  for (var i = 0; i< parent.children.length; ++i){
    sibling = tree.get_node(parent.children[i]);
    tree.rename_node(sibling, parent.text + " - " + (i+1))
  }
}
// Returns letter of a new copied node
function getSuffix(orgid){
  if (Object.keys(Visited).indexOf(orgid) === -1){
    Visited[orgid] = 0;
  }else{
    Visited[orgid]++;
  }
  return LETTERS[Visited[orgid]];
}
$(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 + " " + getSuffix(orgid); 
    Shiny.setInputValue("Element", 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(verbatimTextOutput("Elements"),verbatimTextOutput("Elements2")))
  )
)

server <- function(input, output, session){
  output[["mytree"]] <- renderJstree(mytree)
  
  Elements <- reactiveVal(data.frame(Element = character(0)))
  
  observeEvent(input[["Element"]], {Elements(rbind(Elements(), data.frame(Element = input[["Element"]])))} )

  addLabel <- reactive({if(nrow(Elements()>0)){
    addLabel <- Elements()
    addLabel <- addLabel %>% 
      group_by(Element) %>%
      mutate(ElementCount = row_number()) %>%
      ungroup() %>%
      mutate(Element = paste(Element,"-",ElementCount)) %>% select(-ElementCount)
    addLabel  
  }})
  
  output[["Elements"]] <- renderPrint({Elements()})
  output[["Elements2"]] <- renderPrint({as.data.frame(addLabel())})
 
  observe({
    newLabel <- addLabel()$Element
    session$sendCustomMessage("injectLabel", newLabel)
  })
}

shinyApp(ui=ui, server=server)