shinyTree optimization and benchmarks

shinyTree optimization

## Libs ###################
library(rjson)
library(jsonlite)

## Tree Data ####################
treelist <- rep(list(
  root1 = rep(list(
    SubListA = list(leaf1 = "", leaf2 = ""),
    SubListB = structure(list(leafA = "", leafB = ""))
  ),100),
  root2 = rep(list(
    SubListA = list(leaf1 = "", leaf2 = ""),
    SubListB = structure(list(leafA = "", leafB = ""))
  ), 100)
), 10)


## Original Functions ####################  
Rlist2json <- function(nestedList) {
  as.character(jsonlite::toJSON(get_flatList(nestedList), auto_unbox = T))
}
fixIconName <- function(icon){
  if(is.null(icon)){
    NULL
  }else if(grepl("[/\\]",icon)){ #ie. "/images/ball.jpg"
    icon
  }else{
    iconGroup <- str_subset(icon,"(\\S+) \\1-") #ie "fa fa-file"
    if(length(iconGroup) > 0){
      icon
    }else{
      iconGroup <- str_match(icon,"(fa|glyphicon)-") #ie "fa-file"
      if(length(iconGroup) > 1 && !is.na(iconGroup[2])){
        paste(iconGroup[2],icon)
      }else{ #ie. just "file"
        paste0("fa fa-",icon)
      }
    }
  }
}
get_flatList <- function(nestedList, flatList = NULL, parent = "#") {
  for (name in names(nestedList)) {
    additionalAttributes <- list(
      "icon" = fixIconName(attr(nestedList[[name]],"sticon")),
      "type" = attr(nestedList[[name]],"sttype")
    )
    additionalAttributes <- additionalAttributes[which(sapply(additionalAttributes,Negate(is.null)))]
    
    data <- lapply(names(attributes(nestedList[[name]])),function(key){
      if(key %in% c("icon","type","names","stopened","stselected","sttype", "stdisabled")){
        NULL
      }else{
        attr(nestedList[[name]],key)
      }
    })
    if(!is.null(data) && length(data) > 0){
      names(data) <- names(attributes(nestedList[[name]]))
      data <- data[which(sapply(data,Negate(is.null)))]
    }
    
    nodeData <- append(
      list(
        id = as.character(length(flatList) + 1),
        text = name,
        parent = parent,
        state = list(
          opened   = isTRUE(attr(nestedList[[name]], "stopened")),
          selected = isTRUE(attr(nestedList[[name]], "stselected")),
          disabled = isTRUE(attr(nestedList[[name]], "stdisabled"))
        ),
        data = data
      ),
      additionalAttributes
    )
    
    flatList = c(flatList,list(nodeData))
    if (is.list(nestedList[[name]]))
      flatList =
      Recall(nestedList[[name]], flatList, parent = as.character(length(flatList)))
  }
  flatList
}

## Optimized 1 ####################  
Rlist2json1 <- function(nestedList) {
  d <- rjson::toJSON(get_flatList1(nestedList))
  gsub(d, pattern = "null", fixed = TRUE, replacement = "{}")
}
get_flatList1 <- function(nestedList, flatList = NULL, parent = "#") {
  for (name in names(nestedList)) {
    additionalAttributes <- list(
      "icon" = attr(nestedList[[name]],"sticon"),
      "type" = attr(nestedList[[name]],"sttype")
    )
    additionalAttributes <- additionalAttributes[which(sapply(additionalAttributes,Negate(is.null)))]
    
    data <- lapply(names(attributes(nestedList[[name]])),function(key){
      if(key %in% c("icon","type","names","stopened","stselected","sttype", "stdisabled")){
        NULL
      }else{
        attr(nestedList[[name]],key)
      }
    })
    if(!is.null(data) && length(data) > 0){
      names(data) <- names(attributes(nestedList[[name]]))
      data <- data[which(sapply(data,Negate(is.null)))]
    }
    
    nodeData <- append(
      list(
        id = as.character(length(flatList) + 1),
        text = name,
        parent = parent,
        state = list(
          opened   = isTRUE(attr(nestedList[[name]], "stopened")),
          selected = isTRUE(attr(nestedList[[name]], "stselected")),
          disabled = isTRUE(attr(nestedList[[name]], "stdisabled"))
        ),
        data = data
      ),
      additionalAttributes
    )
    
    flatList = c(flatList,list(nodeData))
    if (is.list(nestedList[[name]]))
      flatList =
      Recall(nestedList[[name]], flatList, parent = as.character(length(flatList)))
  }
  flatList
}

## Optimized 2 ####################  
Rlist2json2 <- function(nestedList) {
  d <- rjson::toJSON(get_flatList2(nestedList))
  gsub(d, pattern = "null", fixed = TRUE, replacement = "{}")
}
get_flatList2 <- function(nstl, fl = NULL, pr = "#") {
  for (name in names(nstl)) {
    nstnm <- nstl[[name]]
    
    typ = attr(nstnm,"sttype")
    ico = attr(nstnm,"sticon")
    if (is.null(typ)) {
      adatr <- list("icon" = ico)
    } else {
      adatr <- list("icon" = ico,"type" = typ)
    }
    
    len = as.character(length(fl) + 1)
    nd <- c(list(
      id = len,
      text = name,
      parent = pr,
      state = list(
        opened   = isTRUE(attr(nstnm, "stopened")),
        selected = isTRUE(attr(nstnm, "stselected"))
      )
    ),
    adatr
    )
    
    fl = c(fl,list(nd))
    if (is.list(nstnm)) {
      fl = Recall(nstnm, fl, pr = len)
    }
  }
  fl
}

## Identical? ####################  
a=Rlist2json(treelist)
b=Rlist2json1(treelist)
c=Rlist2json2(treelist)
identical(a,b)
identical(a,c)

## Benchmarks ####################  
mc <- microbenchmark::microbenchmark(times=5,
  a=Rlist2json(treelist),
  b=Rlist2json1(treelist),
  c=Rlist2json2(treelist)
); mc



## Shiny Apps with all 3 trees / functions ######################
renderTree1 <- function(expr, env = parent.frame(), quoted = FALSE){
  func <- shiny::exprToFunction(expr, env, quoted)
  return(function(shinysession, name, ...) {
    tree <- func()
    updateTree1(shinysession,name,tree) 
    NULL
  })
}
updateTree1 <- function(session, treeId, data=NULL) {
  if(is.list(data)){
    data<-Rlist2json1(data)
  }
  message <- list(type="updateTree",data=data)
  if(!is.null(message)) {
    session$sendInputMessage(treeId, message)
  }
}
renderTree2 <- function(expr, env = parent.frame(), quoted = FALSE){
  func <- shiny::exprToFunction(expr, env, quoted)
  return(function(shinysession, name, ...) {
    tree <- func()
    updateTree2(shinysession,name,tree) 
    NULL
  })
}
updateTree2 <- function(session, treeId, data=NULL) {
  if(is.list(data)){
    data<-Rlist2json2(data)
  }
  message <- list(type="updateTree",data=data)
  if(!is.null(message)) {
    session$sendInputMessage(treeId, message)
  }
}

library(shiny)

ui <- fluidPage(
  column(3, shinyTree("tree", checkbox = TRUE)),
  column(3, shinyTree("tree1", checkbox = TRUE)),
  column(3, shinyTree("tree2", checkbox = TRUE))
)

server <- function(input, output, session) {
  output$tree <- renderTree({
    treelist
  })
  output$tree1 <- renderTree1({
    treelist
  })
  output$tree2 <- renderTree1({
    treelist
  })
}

shinyApp(ui, server)