如何构建自动更新的拖放分层树

Question

我目前在 R 工作，需要一种方法来可视化分层树...

我希望能够最初定义一棵树，其中每个节点都有一个父节点，每个父节点可以有多个子节点。

我希望能够在不同的父节点下拖放节点并执行一些计算（在 R 中），然后在可视化上更新，例如假设每个节点都有一个值；当我将节点放在父节点下时，我想对子节点求和并将值与父节点进行比较。

所以问题是是否有人有任何想法如何解决这个问题或尝试过类似的方法？

我一直在研究闪亮的（例如，shinyDND）和 javascript（例如 gojs），但与其钻牛角尖，我还可以使用一些建议。唯一需要注意的是，更新的计算需要在 R 中完成（它们比总和更复杂，并且会在我正在运行的分析中递归）。

Answer 1

shinyTree是一种可能性。但是有一些潜在的问题：可以在孩子中拖一个孩子，或者在孩子中拖一个父级，或者在父级中拖一个父级。我不知道是否有办法防止这种情况（我认为没有内置方法）。

library(shiny)
library(shinyTree)

values_parents <- function(tree){
  sapply(tree, function(parent) attr(parent, "stinfo"))
}

total_values_children <- function(tree){
  sapply(
    lapply(tree, function(parent){
      sapply(parent, function(children){
        attr(children, "stinfo")
      })
    }),
    function(x){if(is.list(x)) NA else sum(x)}
  )
}

ui <- fluidPage(
  tags$head(
    tags$style(HTML("pre {font-size: 17px;} .jstree-anchor {font-size: large;}"))
  ),
  fluidRow(
    column(
      width = 6,
      shinyTree("tree", dragAndDrop = TRUE, checkbox = FALSE)
    ),
    column(
      width = 6,
      tags$fieldset(
        tags$legend("Values of parents:"),
        verbatimTextOutput("parentsValues")
      ),
      br(),
      tags$fieldset(
        tags$legend("Total value of children:"),
        verbatimTextOutput("childrenTotalValue")
      )
    )
  )
)


server <- function(input, output, session) {
  
  output[["tree"]] <- renderTree({
    list(
      
      ParentA = structure(list(
        ChildrenA1 = structure(NA, stinfo = 5),
        ChildrenA2 = structure(NA, stinfo = 4)
      ), 
      stinfo = 10, stopened = FALSE),
      
      ParentB = structure(list(
        ChildrenB1 = structure(NA, stinfo = 6),
        ChildrenB2 = structure(NA, stinfo = 8)
      ), 
      stinfo = 12, stopened = FALSE)
      
    )
  })
  
  output[["parentsValues"]] <- renderPrint({
    values_parents(input[["tree"]])
  })
  
  output[["childrenTotalValue"]] <- renderPrint({
    total_values_children(input[["tree"]])
  })
    
}

shinyApp(ui, server)

编辑

我开始做一个新包：jsTreeR。由于shinyTree，它是 JavaScript 库的 R 接口jsTree，但它允许更多控件。正如您在下面的示例中看到的，您不能拖动父级，也不能在子级中移动子级：

library(jsTreeR)

dat <- list(
  list(
    text = "RootA",
    data = list(value = 999),
    type = "root",
    children = list(
      list(
        text = "ChildA1",
        type = "child"
      ),
      list(
        text = "ChildA2",
        type = "child"
      )
    )
  ),
  list(
    text = "RootB",
    type = "root",
    children = list(
      list(
        text = "ChildB1",
        type = "child"
      ),
      list(
        text = "ChildB2",
        type = "child"
      )
    )
  )
)

types <- list(
  root = list(
    icon = "glyphicon glyphicon-ok"
  ),
  child = list(
    icon = "glyphicon glyphicon-file"
  )
)

checkCallback <- JS(
  "function(operation, node, parent, position, more) {",
  "  if(operation === 'move_node') {",
  "    if(parent.id === '#' || parent.type === 'child') {",
  "      return false;", # prevent moving a child above or below the root
  "    }",               # and moving inside a child
  "  }",
  "  return true;", # allow everything else
  "}"
)

dnd <- list(
  is_draggable = JS(
    "function(node) {",
    "  if(node[0].type !== 'child') {",
    "    return false;",
    "  }",
    "  return true;",
    "}"
  )
)

jstree(
  dat,
  dragAndDrop = TRUE, dnd = dnd,
  types = types,
  checkCallback = checkCallback
)