How to build a drag and drop hierarchical tree that automatically updates

user_5967581 0
Viewed 688

I am currently working in R and need a way to visualise a hierarchical tree...

I want to be able to initially define a tree where each node has one parent and each parent can have multiple children.

I would like the ability to drag and drop nodes under different parents and carry out some calculation (in R) that is then updated on the visualisaton e.g. let's say each node has a value; when I place a node under a parent I would like to sum the children and compare the value to the parent node.

So the question is if anyone has any ideas how to approach this or has tried anything similar?

I've been looking at shiny (e.g. shinyDND) and javascript (e.g. gojs) but rather than head off down the rabbit hole I could use some advice. The only caveat is that the updated calculations need to be done in R (they are more complicated than sums and will be recursive with analyses that I am running).

data-visualization graph r
1 Answers

shinyTree is a possibility. But there are some potential problems: one can drag a child in a child, or a parent in a child, or a parent in a parent. I don't know whether there is a way to prevent that (there's no built-in way, I think).

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)

enter image description here

EDIT

I started to do a new package: jsTreeR. As shinyTree, it is an R interface to the JavaScript library jsTree, but it allows more controls. As you can see in the example below, you cannot drag a parent and you cannot move a child inside a child:

enter image description here

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
)
user_11001070
Related