Skip to content

Instantly share code, notes, and snippets.

@trafficonese
Created August 22, 2019 12:20
Show Gist options
  • Save trafficonese/c783bcd5897ee77077eca54f82cd86ea to your computer and use it in GitHub Desktop.
Save trafficonese/c783bcd5897ee77077eca54f82cd86ea to your computer and use it in GitHub Desktop.
shinyTree optimization and benchmarks
## 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment