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

I have some experience with R but little knowledge or understanding of JS. The below reproducible code uses JS to run package jsTreeR so the user can custom build a hierarchy tree. The code allows the user to drag/drop elements from the "Menu" section of the tree to the "Drag here to build tree" section beneath, with the dragged items and their drag-in order reflected in the first dataframe rendered in the upper right.

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 handler. 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 of the code using a Shiny handler. I try Shiny.addCustomMessageHandler() in the below code but it doesn't work. What am I doing wrong?

I have been referring to

Reproducible code:

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)

CodePudding user response：

Since you added the message handler inside the copy_node.jstree event handler, you are overwriting the handler each time a new copy event happens. In this case, that's probably fine: you can use that to always handle an injectLabel message from R by renaming the last copied node. You will however need to actually do the renaming inside the shiny message handler, though. Something like this:

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

Now you need to also consider what data should be sent to the browser from R. Here you only need the new name for the latest copied node. Change the payload accordingly:

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

With these two changes, your app should work as intended.