Search code examples
javascriptrshinyjsonlitejstreer

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

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 https://shiny.rstudio.com/articles/communicating-with-js.html for an explanation of handlers but their example is a bit too convoluted for me to understand. (Edit: see comments for references to better explanation sources.)

This illustrates what I am trying to do (I dragged/dropped Bog/Bog/Hog/Hog/Bog in that order):

enter image description here

Reproducible code (please see note above the amended code further below before running the code immediately below):

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)

Below is amended working code that reflects Mikko's solution. Note that OP code above won't work without removing the checkCallback = checkCallback and contextMenu = list(items = customMenu) lines from the mytree <- jstree() object, and adding dplyr to the library. The OP code only ran on my machine because checkCallback and contextMenu were already loaded into memory from running full Apps; one of those annoying periodic overnight reboots (to update some insignificant software like printer driver) cleared my memory and the OP code wouldn't run without the fixes included in the below:

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

  • 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.