如何将特定的节点元素从JSTREE提取到R数据框架？

Question

在运行以下可再现代码时，我正在尝试将特定的节点元素从 jstree （使用 jstreer 软件包）中提取到数据框架中。类似于使用排序 dnd而不是 jstree at 如何从html/css中将列表元素从html/css中拉到r数据框架？

来自 jstree 的特定节点元素用于数据框架？

这是可以进一步的r操作，可以对那些被拖入的元素进行（或更好地复制）元素执行。

底部的图像更好地解释了。

可重复的代码（我在下面的下进行了评论）：

library(jsTreeR)
library(shiny)

nodes <- list(
  list(
    text = "Menu",
    state = list(opened = TRUE),
    children = list(
      list(text = "A", type = "moveable", state = list(disabled = TRUE)),
      list(text = "B", type = "moveable", state = list(disabled = TRUE))
    )
  ),
  list(text = "Drag here:", 
       type = "target", 
       state = list(opened = TRUE)
       )
)

checkCallback <- JS(
  "function(operation, node, parent, position, more) { console.log(node);",
  "  if(operation === 'copy_node') {",
  "    if(parent.id === '#' || node.parent !== 'j1_1' || parent.type !== 'target') {",
  "      return false;", # prevent moving an item above or below the root
  "    }",               # and moving inside an item except a 'target' item
  "  }",
  "  return true;",      # allow everything else
  "}"
)
  
dnd <- list(
  always_copy = TRUE,
  is_draggable = JS(
    "function(node) {",
    "  return node[0].type === 'moveable';",
    "}"
  )
)

ui <- fluidPage(
  tags$head(
    tags$script(
      HTML(
        script <- 
          '
            $(document).ready(function(){
              $("#mytree").on("copy_node.jstree", function(e, data){
                var instance = data.new_instance;
                var node = data.node;
                var id = node.id;
                var text = node.text;
                var index = $("#"+id).index() + 1;
                instance.rename_node(node, index + ". " + text);
              })
            });
          '
      )
    )
  ),
  
  jstreeOutput("mytree"),
  # tableOutput("table1")
  
  )  

server <- function(input, output){
  output[["mytree"]] <- renderJstree({
    jstree(
      nodes, 
      dragAndDrop = TRUE, 
      dnd = dnd, 
      checkCallback = checkCallback,
      types = list(moveable = list(), 
                   target = list()),
    )
  })

  # draggedElements <- reactive({
  #   data.frame(data = paste0(seq_along(jstreeOutput("mytree")), ". ", jstreeOutput("mytree")))
  # })
  
  # output$table1 <- renderTable({draggedElements()})
  
}  

shinyApp(ui, server)

Answer 1

首先，与此问题无关，我在拖放处理程序中添加了选项 insion_pos =“ last” ：

dnd <- list(
  always_copy = TRUE,
  inside_pos = "last",
  is_draggable = JS(
    "function(node) {",
    "  return node[0].type === 'moveable';",
    "}"
  )
)

使用此选项，您可以在 节点“在此处拖动”，然后自动转到最后一个位置（请参见GIF）。非常方便。

现在，出于您的问题。这是 Shiny.setInputValue 的工作。修改脚本：

script <- '
$(document).ready(function(){
  $("#mytree").on("copy_node.jstree", function(e, data){
    var instance = data.new_instance;
    var node = data.node;
    var id = node.id;
    var index = $("#"+id).index() + 1;
    var text = index + ". " + node.text;
    Shiny.setInputValue("choice", text);
    instance.rename_node(node, text);
  })
});
'

这是闪亮的应用程序：

ui <- fluidPage(
  tags$head(tags$script(HTML(script))),
  fluidRow(
    column(
      width = 6,
      jstreeOutput("mytree")
    ),
    column(
      width = 6,
      verbatimTextOutput("choices")
    )
  )
)

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()
  })

}

---

编辑：删除

checkCallback <- JS(
  "function(operation, node, parent, position, more) { ",
  "  if(operation === 'copy_node') {",
  "    if(parent.id === '#' || node.parent !== 'j1_1' || parent.type !== 'target') {",
  "      return false;", # prevent moving an item above or below the root
  "    }",               # and moving inside an item except a 'target' item
  "  }",
  "  if(operation === 'delete_node') {",
  "    Shiny.setInputValue('deletion', position + 1);",
  "  }",
  "  return true;",      # allow everything else
  "}"
)

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"]])
      )
    )
  })

  observeEvent(input[["deletion"]], {
    Choices(
      Choices()[-input[["deletion"]], , drop = FALSE]
    )
  })

  output[["choices"]] <- renderPrint({
    Choices()
  })

}

完整应用，带有图标和 proton 主题：

library(jsTreeR)

nodes <- list(
  list(
    text = "Menu",
    state = list(opened = TRUE),
    a_attr = list(style = "font-weight: bold;"),
    children = list(
      list(
        text = "Dog",
        type = "moveable",
        state = list(disabled = TRUE),
        icon = "fas fa-dog"
      ),
      list(
        text = "Cat",
        type = "moveable",
        state = list(disabled = TRUE),
        icon = "fas fa-cat"
      ),
      list(
        text = "Fish",
        type = "moveable",
        state = list(disabled = TRUE),
        icon = "fas fa-fish"
      )
    )
  ),
  list(
    text = ">>> Drag here <<<",
    type = "target",
    state = list(opened = TRUE),
    a_attr = list(style = "font-weight: bold;")
  )
)

checkCallback <- JS(
  "function(operation, node, parent, position, more) { ",
  "  if(operation === 'copy_node') {",
  "    if(parent.id === '#' || node.parent !== 'j1_1' || parent.type !== 'target') {",
  "      return false;", # prevent moving an item above or below the root
  "    }",               # and moving inside an item except a 'target' item
  "  }",
  "  if(operation === 'delete_node') {",
  "    Shiny.setInputValue('deletion', position + 1);",
  "  }",
  "  return true;",      # allow everything else
  "}"
)

dnd <- list(
  always_copy = TRUE,
  inside_pos = "last",
  is_draggable = JS(
    "function(node) {",
    "  return node[0].type === 'moveable';",
    "}"
  )
)

customMenu <- JS(
  "function customMenu(node) {",
  "  var tree = $('#mytree').jstree(true);", # 'mytree' is the Shiny id or the elementId
  "  var items = {",
  "    'delete' : {",
  "      'label'  : 'Delete',",
  "      'action' : function (obj) { tree.delete_node(node); },",
  "      'icon'   : 'glyphicon glyphicon-trash'",
  "     }",
  "  }",
  "  return items;",
  "}")


mytree <- jstree(
  nodes, dragAndDrop = TRUE, dnd = dnd, checkCallback = checkCallback,
  types = list(moveable = list(), target = list()),
  contextMenu = list(items = customMenu),
  theme = "proton"
)

script <- '
$(document).ready(function(){
  $("#mytree").on("copy_node.jstree", function(e, data){
    var instance = data.new_instance;
    var node = data.node;
    var id = node.id;
    var index = $("#"+id).index() + 1;
    var text = index + ". " + node.text;
    Shiny.setInputValue("choice", text);
    instance.rename_node(node, text);
  });
});
'

library(shiny)
ui <- fluidPage(
  tags$head(tags$script(HTML(script))),
  fluidRow(
    column(
      width = 4,
      jstreeOutput("mytree")
    ),
    column(
      width = 8,
      verbatimTextOutput("choices")
    )
  )
)

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"]])
      )
    )
  })

  observeEvent(input[["deletion"]], {
    Choices(
      Choices()[-input[["deletion"]], , drop = FALSE]
    )
  })

  output[["choices"]] <- renderPrint({
    Choices()
  })

}

shinyApp(ui, server)