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