Nothing
R/visTreeModule.R
In visNetwork: Network Visualization using 'vis.js' Library
Defines functions
.ctrlPckTree
visTreeModuleUI
visTreeModuleServer
Documented in
visTreeModuleServer
visTreeModuleUI
#' Module shiny for visualize and customize a \code{rpart} tree
#'
#' Needed packages : shiny, rpart, colourpicker, shinyWidgets, sparkline
#'
#' @param id \code{character} id of module, linked to \link{visTreeModuleServer}
#' @param rpartParams \code{boolean}, add tabs for rpart parameters (in case of \code{data.frame} in input)
#' @param visTreeParams \code{boolean}, add tabs for visTree parameters. Default to TRUE. Force to TRUE if \code{rpartParams}
#' @param quitButton \code{boolean}, add a button to quit module and get back network in R ?
#'
#' @param input \code{list} shiny input
#' @param output \code{list}, shiny output
#' @param session \code{list}, shiny session
#' @param data \code{reactive}, a \code{data.frame} or a \code{rpart} result. Must be a reactive object
#' @param tooltip_data \code{reactive}, a \code{data.frame}. if \code{data} is a \code{rpart},
#' data.frame used to build tree in order to plot \code{sparkline}
#'
#' @inheritParams visTree
#'
#'
#' @examples
#' \dontrun{
#'
#' require(rpart)
#' # simple module editor on rpart
#' data <- iris
#' shiny::shinyApp(ui = shiny::fluidPage(
#' visTreeModuleUI(id = "id1", rpartParams = FALSE, visTreeParams = FALSE)),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(rpart(data)))
#' })
#'
#' # full module editor on rpart + data.frame for sparkline
#' data <- iris
#' shiny::shinyApp(ui = shiny::fluidPage(
#' visTreeModuleUI(id = "id1", rpartParams = FALSE, visTreeParams = TRUE)),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(rpart(data)),
#' tooltip_data = data)
#' })
#'
#' # module on data.frame
#' shiny::shinyApp(ui = shiny::fluidPage(visTreeModuleUI(id = "id1",
#' rpartParams = TRUE)),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(data))
#' })
#'
#' # multiple modules
#' shiny::shinyApp(ui =
#' navbarPage("Menu",shiny::tabPanel(
#' "tt1",shiny::fluidPage(visTreeModuleUI(id = "id1",
#' rpartParams = TRUE,
#' visTreeParams = TRUE))
#' ),
#' shiny::tabPanel(
#' "tt2",shiny::fluidPage(visTreeModuleUI(id = "id2",
#' rpartParams = FALSE,
#' visTreeParams = FALSE)))
#' ),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(iris))
#' shiny::callModule(visTreeModuleServer, "id2", data = shiny::reactive(rpart(iris)))
#' })
#' }
#'
#' @name visNetwork-treeModule
#'
#' @export
#'
#' @importFrom stats as.formula
#' @importFrom grDevices col2rgb
#'
#' @references See online documentation \url{https://datastorm-open.github.io/visNetwork/}
#'
visTreeModuleServer <- function(input, output, session, data,
tooltip_data = NULL,
tooltipColumns = "",
main = "",
submain = "",
footer = "",
direction = "UD",
fallenLeaves = FALSE,
rules = TRUE,
simplifyRules = TRUE,
shapeVar = "dot",
shapeY = "square",
colorVar = NULL,
colorY = NULL,
colorEdges = "#8181F7",
nodesFontSize = 16,
edgesFontSize = 14,
edgesFontAlign = "horizontal",
legend = TRUE,
legendNodesSize = 22,
legendFontSize = 16,
legendWidth = 0.1,
legendNcol = 1,
legendPosition = "left",
nodesPopSize = FALSE,
minNodeSize = 15,
maxNodeSize = 30,
highlightNearest = list(enabled = TRUE,
degree = list(from = 50000, to = 0), hover = FALSE,
algorithm = "hierarchical"),
collapse = list(enabled = TRUE, fit = TRUE, resetHighlight = TRUE,
clusterOptions = list(fixed = TRUE, physics = FALSE)),
updateShape = TRUE,
tooltipDelay = 500,
digits = 3,
height = 650,
width = "100%",
export = TRUE) {
ns <- session$ns
# reactive controls
if (!shiny::is.reactive(tooltip_data)){
get_tooltip_data <- shiny::reactive({tooltip_data})
} else {
get_tooltip_data <- tooltip_data
}
if (!shiny::is.reactive(tooltipColumns)){
get_tooltipColumns <- shiny::reactive({tooltipColumns})
} else {
get_tooltipColumns <- tooltipColumns
}
if (!shiny::is.reactive(main)){
get_main <- shiny::reactive({main})
} else {
get_main <- main
}
if (!shiny::is.reactive(submain)){
get_submain <- shiny::reactive({submain})
} else {
get_submain <- submain
}
if (!shiny::is.reactive(footer)){
get_footer <- shiny::reactive({footer})
} else {
get_footer <- footer
}
if (!shiny::is.reactive(direction)){
get_direction <- shiny::reactive({direction})
} else {
get_direction <- direction
}
if (!shiny::is.reactive(fallenLeaves)){
get_fallenLeaves <- shiny::reactive({fallenLeaves})
} else {
get_fallenLeaves <- fallenLeaves
}
if (!shiny::is.reactive(rules)){
get_rules <- shiny::reactive({rules})
} else {
get_rules <- rules
}
if (!shiny::is.reactive(simplifyRules)){
get_simplifyRules <- shiny::reactive({simplifyRules})
} else {
get_simplifyRules <- simplifyRules
}
if (!shiny::is.reactive(shapeVar)){
get_shapeVar <- shiny::reactive({shapeVar})
} else {
get_shapeVar <- shapeVar
}
if (!shiny::is.reactive(shapeY)){
get_shapeY <- shiny::reactive({shapeY})
} else {
get_shapeY <- shapeY
}
if (!shiny::is.reactive(colorVar)){
get_colorVar <- shiny::reactive({colorVar})
} else {
get_colorVar <- colorVar
}
if (!shiny::is.reactive(colorY)){
get_colorY <- shiny::reactive({colorY})
} else {
get_colorY <- colorY
}
if (!shiny::is.reactive(colorEdges)){
get_colorEdges <- shiny::reactive({colorEdges})
} else {
get_colorEdges <- colorEdges
}
if (!shiny::is.reactive(nodesFontSize)){
get_nodesFontSize <- shiny::reactive({nodesFontSize})
} else {
get_nodesFontSize <- nodesFontSize
}
if (!shiny::is.reactive(edgesFontSize)){
get_edgesFontSize <- shiny::reactive({edgesFontSize})
} else {
get_edgesFontSize <- edgesFontSize
}
if (!shiny::is.reactive(edgesFontAlign)){
get_edgesFontAlign <- shiny::reactive({edgesFontAlign})
} else {
get_edgesFontAlign <- edgesFontAlign
}
if (!shiny::is.reactive(legend)){
get_legend <- shiny::reactive({legend})
} else {
get_legend <- legend
}
if (!shiny::is.reactive(legendNodesSize)){
get_legendNodesSize <- shiny::reactive({legendNodesSize})
} else {
get_legendNodesSize <- legendNodesSize
}
if (!shiny::is.reactive(legendFontSize)){
get_legendFontSize <- shiny::reactive({legendFontSize})
} else {
get_legendFontSize <- legendFontSize
}
if (!shiny::is.reactive(legendWidth)){
get_legendWidth <- shiny::reactive({legendWidth})
} else {
get_legendWidth <- legendWidth
}
if (!shiny::is.reactive(legendNcol)){
get_legendNcol <- shiny::reactive({legendNcol})
} else {
get_legendNcol <- legendNcol
}
if (!shiny::is.reactive(legendPosition)){
get_legendPosition <- shiny::reactive({legendPosition})
} else {
get_legendPosition <- legendPosition
}
if (!shiny::is.reactive(nodesPopSize)){
get_nodesPopSize <- shiny::reactive({nodesPopSize})
} else {
get_nodesPopSize <- nodesPopSize
}
if (!shiny::is.reactive(minNodeSize)){
get_minNodeSize <- shiny::reactive({minNodeSize})
} else {
get_minNodeSize <- minNodeSize
}
if (!shiny::is.reactive(maxNodeSize)){
get_maxNodeSize <- shiny::reactive({maxNodeSize})
} else {
get_maxNodeSize <- maxNodeSize
}
if (!shiny::is.reactive(highlightNearest)){
get_highlightNearest <- shiny::reactive({highlightNearest})
} else {
get_highlightNearest <- highlightNearest
}
if (!shiny::is.reactive(collapse)){
get_collapse <- shiny::reactive({collapse})
} else {
get_collapse <- collapse
}
if (!shiny::is.reactive(updateShape)){
get_updateShape <- shiny::reactive({updateShape})
} else {
get_updateShape <- updateShape
}
if (!shiny::is.reactive(tooltipDelay)){
get_tooltipDelay <- shiny::reactive({tooltipDelay})
} else {
get_tooltipDelay <- tooltipDelay
}
if (!shiny::is.reactive(digits)){
get_digits <- shiny::reactive({digits})
} else {
get_digits <- digits
}
if (!shiny::is.reactive(height)){
get_height <- shiny::reactive({height})
} else {
get_height <- height
}
if (!shiny::is.reactive(width)){
get_width <- shiny::reactive({width})
} else {
get_width <- width
}
if (!shiny::is.reactive(export)){
get_export <- shiny::reactive({export})
} else {
get_export <- export
}
# create input
output$input_legend <- shiny::renderUI({
legend <- get_legend()
shiny::isolate({
shiny::checkboxInput(ns("legend"), "Display legend", value = legend)
})
})
shiny::outputOptions(output, "input_legend", suspendWhenHidden = FALSE)
output$input_fallenLeaves <- shiny::renderUI({
fallenLeaves <- get_fallenLeaves()
shiny::isolate({
shiny::checkboxInput(ns("fallenLeaves"), "Fallen leaves", fallenLeaves)
})
})
shiny::outputOptions(output, "input_fallenLeaves", suspendWhenHidden = FALSE)
output$input_rules <- shiny::renderUI({
rules <- get_rules()
shiny::isolate({
shiny::checkboxInput(ns("rules"),"Display rules", value = rules)
})
})
shiny::outputOptions(output, "input_rules", suspendWhenHidden = FALSE)
output$input_updateShape <- shiny::renderUI({
updateShape <- get_updateShape()
shiny::isolate({
shiny::checkboxInput(ns("updateShape"), "Update shape", value = updateShape)
})
})
shiny::outputOptions(output, "input_updateShape", suspendWhenHidden = FALSE)
output$input_export <- shiny::renderUI({
export <- get_export()
shiny::isolate({
shiny::checkboxInput(ns("export"), "Export", value = export)
})
})
shiny::outputOptions(output, "input_export", suspendWhenHidden = FALSE)
output$input_height <- shiny::renderUI({
height <- get_height()
shiny::isolate({
shiny::numericInput(ns("height"), "Height :", value = height)
})
})
shiny::outputOptions(output, "input_height", suspendWhenHidden = FALSE)
output$input_digits <- shiny::renderUI({
digits <- get_digits()
shiny::isolate({
shiny::numericInput(ns("digits"), "Digits : ", value = digits, min = 0)
})
})
shiny::outputOptions(output, "input_digits", suspendWhenHidden = FALSE)
output$input_tooltipDelay <- shiny::renderUI({
tooltipDelay <- get_tooltipDelay()
shiny::isolate({
shiny::numericInput(ns("tooltipDelay"), "Tooltip delay :", value = tooltipDelay, min = 0, step = 100)
})
})
shiny::outputOptions(output, "input_tooltipDelay", suspendWhenHidden = FALSE)
output$input_legendWidth <- shiny::renderUI({
legendWidth <- get_legendWidth()
shiny::isolate({
shiny::numericInput(ns("legendWidth"), "Width :", value = legendWidth, min = 0, max = 0.5, step = 0.05)
})
})
shiny::outputOptions(output, "input_legendWidth", suspendWhenHidden = FALSE)
output$input_legendNcol <- shiny::renderUI({
legendNcol <- get_legendNcol()
shiny::isolate({
shiny::numericInput(ns("legendNcol"), "Number of columns :", value = legendNcol, min = 1, max = 50, step = 1)
})
})
shiny::outputOptions(output, "input_legendNcol", suspendWhenHidden = FALSE)
output$input_legendPosition <- shiny::renderUI({
legendPosition <- get_legendPosition()
shiny::isolate({
shiny::selectInput(ns("legendPosition"), "Position", choices = c("left", "right"), selected = legendPosition)
})
})
shiny::outputOptions(output, "input_legendPosition", suspendWhenHidden = FALSE)
output$input_shapeY <- shiny::renderUI({
shapeY <- get_shapeY()
shiny::isolate({
shiny::selectInput(ns("shapeY"), "shape Y", choices = c("diamond",
"dot",
"star",
"triangle",
"triangleDown",
"square",
"ellipse",
"circle",
"database",
"box",
"text"), selected = shapeY)
})
})
shiny::outputOptions(output, "input_shapeY", suspendWhenHidden = FALSE)
output$input_shapeX <- shiny::renderUI({
shapeVar <- get_shapeVar()
shiny::isolate({
shiny::selectInput(ns("shapeX"), "shape X", choices = c("diamond",
"dot",
"star",
"triangle",
"triangleDown",
"square",
"ellipse",
"circle",
"database",
"box",
"text"), selected = shapeVar)
})
})
shiny::outputOptions(output, "input_shapeX", suspendWhenHidden = FALSE)
output$input_nodesSize <- shiny::renderUI({
nodesSize <- (get_maxNodeSize() + get_minNodeSize()) / 2
shiny::isolate({
shiny::numericInput(ns("nodesSize"), "Nodes size", value = nodesSize, min = 1)
})
})
shiny::outputOptions(output, "input_nodesSize", suspendWhenHidden = FALSE)
output$input_maxNodeSize <- shiny::renderUI({
value = get_maxNodeSize()
shiny::isolate({
shiny::numericInput(ns("maxNodeSize"), "Max nodes size", value = value, min = 1)
})
})
shiny::outputOptions(output, "input_maxNodeSize", suspendWhenHidden = FALSE)
output$input_minNodeSize <- shiny::renderUI({
value = get_minNodeSize()
shiny::isolate({
shiny::numericInput(ns("minNodeSize"), "Min nodes size", value = value, min = 1)
})
})
shiny::outputOptions(output, "input_minNodeSize", suspendWhenHidden = FALSE)
output$input_legendNodesSize <- shiny::renderUI({
legendNodesSize <- get_legendNodesSize()
shiny::isolate({
shiny::numericInput(ns("legendNodesSize"), "Legend size", value = legendNodesSize, min = 1)
})
})
shiny::outputOptions(output, "input_legendNodesSize", suspendWhenHidden = FALSE)
output$input_nodesFontSize <- shiny::renderUI({
nodesFontSize <- get_nodesFontSize()
shiny::isolate({
shiny::numericInput(ns("nodesFontSize"), "Nodes font", value = nodesFontSize, min = 1)
})
})
shiny::outputOptions(output, "input_nodesFontSize", suspendWhenHidden = FALSE)
output$input_legendFontSize <- shiny::renderUI({
legendFontSize <- get_legendFontSize()
shiny::isolate({
shiny::numericInput(ns("legendFontSize"), "Legend font", value = legendFontSize, min = 1)
})
})
shiny::outputOptions(output, "input_legendFontSize", suspendWhenHidden = FALSE)
output$input_colorEdges <- shiny::renderUI({
colorEdges <- get_colorEdges()
shiny::isolate({
colourpicker::colourInput(ns("colorEdges"), "Edges color", value = colorEdges)
})
})
shiny::outputOptions(output, "input_colorEdges", suspendWhenHidden = FALSE)
output$input_edgesFontSize <- shiny::renderUI({
edgesFontSize <- get_edgesFontSize()
shiny::isolate({
shiny::numericInput(ns("edgesFontSize"), "Edges font", value = edgesFontSize, min = 1)
})
})
shiny::outputOptions(output, "input_edgesFontSize", suspendWhenHidden = FALSE)
output$input_edgesFontAlign <- shiny::renderUI({
edgesFontAlign <- get_edgesFontAlign()
shiny::isolate({
shiny::selectInput(ns("edgesFontAlign"), "Edges font align",
choices = c("horizontal", "top", "middle", "bottom"),
selected = edgesFontAlign)
})
})
shiny::outputOptions(output, "input_edgesFontAlign", suspendWhenHidden = FALSE)
output$input_direction <- shiny::renderUI({
direction <- get_direction()
shiny::isolate({
shiny::selectInput(ns("direction"), "Direction :",
choices = c("up-down" = "UD", "down-up" = "DU",
"left-right" = "LR", "right-left" = "RL"),
selected = direction)
})
})
shiny::outputOptions(output, "input_direction", suspendWhenHidden = FALSE)
output$input_edgesFontAlign <- shiny::renderUI({
edgesFontAlign <- get_edgesFontAlign()
shiny::isolate({
shiny::selectInput(ns("edgesFontAlign"), "Edges font align",
choices = c("horizontal", "top", "middle", "bottom"),
selected = edgesFontAlign)
})
})
shiny::outputOptions(output, "input_edgesFontAlign", suspendWhenHidden = FALSE)
output$input_highlight <- shiny::renderUI({
highlightNearest <- get_highlightNearest()
shiny::isolate({
nearest <- TRUE
hover <- FALSE
if(is.logical(highlightNearest)){
nearest <- highlightNearest
hover <- FALSE
} else {
if(!is.null(highlightNearest$enabled)){
nearest <- highlightNearest$enabled
}
if(!is.null(highlightNearest$hover)){
hover <- highlightNearest$hover
}
}
shiny::fluidRow(
shiny::column(12,
shinyWidgets::materialSwitch(ns("highlightNearest"), "highlight nearest", status = "info", value = nearest),
shinyWidgets::materialSwitch(ns("highlightHover"), "highlight hover", status = "info", value = hover)
)
)
})
})
shiny::outputOptions(output, "input_highlight", suspendWhenHidden = FALSE)
output$input_collapse <- shiny::renderUI({
collapse <- get_collapse()
shiny::isolate({
value <- TRUE
if(is.logical(collapse)){
value <- collapse
} else {
if(!is.null(collapse$enabled)){
value <- collapse$enabled
}
}
shinyWidgets::materialSwitch(ns("collapse"), "Collapse", status = "info", value = value)
})
})
shiny::outputOptions(output, "input_collapse", suspendWhenHidden = FALSE)
# update main
output$input_main <- shiny::renderUI({
main <- get_main()
shiny::isolate({
text <- ""
color <- "black"
size <- 20
if(any(c("character", "factor") %in% class(main))){
text <- main
} else {
if(is.list(main)){
if(!is.null(main$text)){
text <- main$text
}
if(!is.null(main$style)){
find_size <- gregexpr("(font-size:)[[:digit:]]*", main$style)
tmp_size <- as.numeric(gsub("font-size:", "", unlist(regmatches(main$style, find_size))))[1]
if(!is.na(size)){
size <- tmp_size
}
find_color <- gregexpr("(color:#)[[:alnum:]]*", main$style)
tmp_color <- gsub("color:", "", unlist(regmatches(main$style, find_color)))[1]
if(!is.na(color)){
color <- tmp_color
}
}
}
}
shiny::fluidRow(
shiny::column(4,
shiny::textInput(ns("main"), "Main :", text)
),
shiny::column(4,
colourpicker::colourInput(ns("colourMain"),
"Main color :", value = color)
),
shiny::column(4,
shiny::numericInput(ns("mainsize"), "Main size :",
value = size, min = 1)
)
)
})
})
shiny::outputOptions(output, "input_main", suspendWhenHidden = FALSE)
# update submain
output$input_submain <- shiny::renderUI({
submain <- get_submain()
shiny::isolate({
text <- ""
color <- "black"
size <- 12
if(any(c("character", "factor") %in% class(submain))){
text <- submain
} else {
if(is.list(submain)){
if(!is.null(submain$text)){
text <- submain$text
}
if(!is.null(submain$style)){
find_size <- gregexpr("(font-size:)[[:digit:]]*", submain$style)
tmp_size <- as.numeric(gsub("font-size:", "", unlist(regmatches(submain$style, find_size))))[1]
if(!is.na(size)){
size <- tmp_size
}
find_color <- gregexpr("(color:#)[[:alnum:]]*", submain$style)
tmp_color <- gsub("color:", "", unlist(regmatches(submain$style, find_color)))[1]
if(!is.na(color)){
color <- tmp_color
}
}
}
}
shiny::fluidRow(
shiny::column(4,
shiny::textInput(ns("submain"), "Submain :", text)
),
shiny::column(4,
colourpicker::colourInput(ns("colourSubMain"),
"Submain color :", value = color)
),
shiny::column(4,
shiny::numericInput(ns("Submainsize"), "Submain size :",
value = size, min = 1)
)
)
})
})
shiny::outputOptions(output, "input_submain", suspendWhenHidden = FALSE)
# update footer
output$input_footer <- shiny::renderUI({
footer <- get_footer()
shiny::isolate({
text <- ""
color <- "black"
size <- 12
if(any(c("character", "factor") %in% class(footer))){
text <- footer
} else {
if(is.list(footer)){
if(!is.null(footer$text)){
text <- footer$text
}
if(!is.null(footer$style)){
find_size <- gregexpr("(font-size:)[[:digit:]]*", footer$style)
tmp_size <- as.numeric(gsub("font-size:", "", unlist(regmatches(footer$style, find_size))))[1]
if(!is.na(size)){
size <- tmp_size
}
find_color <- gregexpr("(color:#)[[:alnum:]]*", footer$style)
tmp_color <- gsub("color:", "", unlist(regmatches(footer$style, find_color)))[1]
if(!is.na(color)){
color <- tmp_color
}
}
}
}
shiny::fluidRow(
shiny::column(4,
shiny::textInput(ns("footer"), "Footer :", text)
),
shiny::column(4,
colourpicker::colourInput(ns("colourFooterMain"),
"Footer color :", value = color)
),
shiny::column(4,
shiny::numericInput(ns("Footermainsize"), "Footer size :",
value = size, min = 1)
)
)
})
})
shiny::outputOptions(output, "input_footer", suspendWhenHidden = FALSE)
shiny::observe({
if("data.frame" %in% class(data())){
shiny::updateSelectInput(session, inputId = "y", choices = names(data()))
}
})
shiny::observe({
if("data.frame" %in% class(data())){
shiny::updateSelectInput(session, inputId = "x", choices = names(data())[names(data())!=input$y],
selected = names(data())[names(data())!=input$y])
}
})
shiny::observe({
if("data.frame" %in% class(data())){
choices = 1:ncol(data())
names(choices) = names(data())
selected = get_tooltipColumns()
if(isTRUE(all.equal(selected, ""))){
selected <- choices
}else if(class(selected) %in% c("character", "factor")){
selected <- which(selected %in% names(data()))
}
shiny::isolate({
shiny::updateSelectInput(session, inputId = "tooltipColumns",
choices = choices,
selected = selected)
})
} else if(!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data())){
choices = 1:ncol(get_tooltip_data())
names(choices) = names(get_tooltip_data())
selected = get_tooltipColumns()
if(class(selected) %in% c("character", "factor")){
selected <- which(selected %in% names(get_tooltip_data()))
}
if(isTRUE(all.equal(selected, ""))){
selected <- choices
}
shiny::isolate({
shiny::updateSelectInput(session, inputId = "tooltipColumns", choices = choices, selected = selected)
})
}
})
output$is_data_frame <- shiny::reactive({
"data.frame" %in% class(data()) || (!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data()))
})
shiny::outputOptions(output, "is_data_frame", suspendWhenHidden = FALSE)
# Get rpart from reactive data
rpart_tree <- shiny::reactive({
input$runTree
if("rpart" %in% class(data())){
data()
} else {
if(input$runTree > 0){
shiny::isolate({
if(length(input$x) > 0){
x_frm <- paste0("`", paste0(input$x, collapse = "` + `"), "`")
} else {
x_frm <- " . "
}
formule <- paste0("`", input$y, "` ~ ", x_frm) %>% as.formula()
rpart::rpart(formule, data = data(),
control = rpart::rpart.control(cp = input$complexity, minsplit = input$minsplit))
})
} else {
NULL
}
}
})
shiny::observe({
input$y
input$x
input$complexity
input$minsplit
shiny::updateCheckboxInput(session,"usecolornodes", value = FALSE )
shiny::updateCheckboxInput(session,"usecolorY", value = FALSE )
})
# data.frame with variables colors
infoColors <- shiny::reactiveValues(colorVar = NULL, colorY = NULL)
current_tree_params <- shiny::reactiveValues()
# Build tree (visTree)
treeBuild <- shiny::reactive({
res <- rpart_tree()
if(!is.null(res)){
shiny::isolate({
main <- get_main()
submain <- get_submain()
footer <- get_footer()
direction <- get_direction()
fallenLeaves <- get_fallenLeaves()
rules <- get_rules()
simplifyRules <- get_simplifyRules()
shapeVar <- get_shapeVar()
shapeY <- get_shapeY()
colorVar <- get_colorVar()
colorY <- get_colorY()
colorEdges <- get_colorEdges()
nodesFontSize <- get_nodesFontSize()
edgesFontSize <- get_edgesFontSize()
edgesFontAlign <- get_edgesFontAlign()
legend <- get_legend()
legendNodesSize <- get_legendNodesSize()
legendFontSize <- get_legendFontSize()
legendWidth <- get_legendWidth()
legendNcol <- get_legendNcol()
legendPosition <- get_legendPosition()
nodesPopSize <- get_nodesPopSize()
minNodeSize <- get_minNodeSize()
maxNodeSize <- get_maxNodeSize()
highlightNearest <- get_highlightNearest()
collapse <- get_collapse()
updateShape <- get_updateShape()
tooltipDelay <- get_tooltipDelay()
digits <- get_digits()
height <- get_height()
width <- get_width()
export <- get_export()
if("data.frame" %in% class(data())){
data <- data()
tooltipColumns <- get_tooltipColumns()
if(isTRUE(all.equal(tooltipColumns, ""))){
tooltipColumns <- 1:ncol(data)
}
} else {
if(!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data())){
data <- get_tooltip_data()
tooltipColumns <- get_tooltipColumns()
if(isTRUE(all.equal(tooltipColumns, ""))){
tooltipColumns <- 1:ncol(data)
}
} else {
data <- NULL
tooltipColumns <- NULL
}
}
if("runTree" %in% names(input)){
if(input$runTree > 0){
legend <- input$legend
rules <- input$rules
tooltipDelay <- input$tooltipDelay
updateShape <- input$updateShape
fallenLeaves <- input$fallenLeaves
digits <- input$digits
height <- input$height
nodesPopSize <- input$nodesPopSize
export <- input$export
colorVar <- updateColorVar()
tmp_colorY <- updateColorY()
if("class" %in% res$method & is.data.frame(tmp_colorY)){
colorY <- tmp_colorY
} else if("anova" %in% res$method & "character" %in% class(tmp_colorY)){
colorY <- tmp_colorY
}
main = build_main()
submain = build_submain()
footer = build_footer()
simplifyRules <- ifelse(is.null(input$simpRules), simplifyRules, input$simpRules)
legendWidth <- ifelse(is.null(input$legendWidth), legendWidth, input$legendWidth)
legendNcol <- ifelse(is.null(input$legendNcol), legendNcol, input$legendNcol)
legendNodesSize <- ifelse(is.null(input$legendNodesSize), legendNodesSize, input$legendNodesSize)
legendFontSize <- ifelse(is.null(input$legendFontSize), legendFontSize, input$legendFontSize)
legendPosition <- ifelse(is.null(input$legendPosition), legendPosition, input$legendPosition)
minNodeSize <- ifelse(is.null(input$minNodeSize), minNodeSize, input$minNodeSize)
maxNodeSize <- ifelse(is.null(input$maxNodeSize), maxNodeSize, input$maxNodeSize)
direction <- ifelse(is.null(input$direction), direction, input$direction)
shapeY <- ifelse(is.null(input$shapeY), shapeY, input$shapeY)
shapeVar <- ifelse(is.null(input$shapeX), shapeVar, input$shapeX)
edgesFontSize <- ifelse(is.null(input$edgesFontSize), edgesFontSize, input$edgesFontSize)
edgesFontAlign <- ifelse(is.null(input$edgesFontAlign), edgesFontAlign, input$edgesFontAlign)
nodesFontSize <- ifelse(is.null(input$nodesFontSize), nodesFontSize, input$nodesFontSize)
colorEdges <- ifelse(is.null(input$colorEdges), colorEdges, input$colorEdges)
if("data.frame" %in% class(data())){
data <- data()
if(is.null(input$tooltipColumns)){
tooltipColumns <- NULL
} else if(length(input$tooltipColumns) == 0){
tooltipColumns <- NULL
} else {
tooltipColumns <- as.numeric(input$tooltipColumns)
}
} else {
if(!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data())){
data <- get_tooltip_data()
if(is.null(input$tooltipColumns)){
tooltipColumns <- NULL
} else if(length(input$tooltipColumns) == 0){
tooltipColumns <- NULL
} else {
tooltipColumns <- as.numeric(input$tooltipColumns)
}
} else {
data <- NULL
tooltipColumns <- NULL
}
}
}
}
current_tree_params$rules = rules
current_tree_params$simplifyRules = simplifyRules
current_tree_params$legend = legend
current_tree_params$legendWidth = legendWidth
current_tree_params$legendPosition = legendPosition
current_tree_params$legendNcol = legendNcol
current_tree_params$tooltipDelay = tooltipDelay
current_tree_params$digits = digits
current_tree_params$fallenLeaves = fallenLeaves
current_tree_params$updateShape = updateShape
current_tree_params$export = export
current_tree_params$data = data
current_tree_params$tooltipColumns = tooltipColumns
tree <- visTree(object = res,
data = data,
tooltipColumns = tooltipColumns,
main = main,
submain = submain,
footer = footer,
shapeY = shapeY,
shapeVar = shapeVar,
colorVar = colorVar,
colorY = colorY,
rules = rules,
simplifyRules = simplifyRules,
legend = legend,
legendWidth = legendWidth,
legendNodesSize = legendNodesSize,
legendFontSize = legendFontSize,
legendPosition = legendPosition,
legendNcol = legendNcol,
edgesFontSize = edgesFontSize,
edgesFontAlign = edgesFontAlign,
nodesFontSize = nodesFontSize,
nodesPopSize = nodesPopSize,
minNodeSize = minNodeSize,
maxNodeSize = maxNodeSize,
tooltipDelay = tooltipDelay,
digits = digits,
direction = direction,
fallenLeaves = fallenLeaves,
updateShape = updateShape,
colorEdges = colorEdges,
highlightNearest = highlightNearest,
collapse = collapse,
height = paste0(height, "px"),
export = export) %>%
visEvents(type = "on", doubleClick = "networkOpenCluster")
# save color information
infoColors$colorVar <- tree$x$tree$colorVar
infoColors$colorY <- tree$x$tree$colorY
tree
})
} else {
NULL
}
})
output$is_tree <- shiny::reactive({
!is.null(treeBuild())
})
shiny::outputOptions(output, "is_tree", suspendWhenHidden = FALSE)
# the tree
output$tree <- visNetwork::renderVisNetwork({
treeBuild()
})
# Give names of variables
infoRpartNodes <- shiny::reactive({
res <- rpart_tree()
if(!is.null(res)){
nodes_var <- as.character(res$frame$var)
nodes_var_x <- nodes_var[nodes_var != "<leaf>"]
sortLabels <- unique(nodes_var_x)
if(!is.null(attributes(res)$ylevels)){
infoClass <- attributes(res)$ylevels
nlevelsClass <- length(infoClass)
probaClass <- res$frame[,"yval2"]
effectif <- data.frame(probaClass[,2:(nlevelsClass+1), drop = F])
probs <- data.frame(probaClass[,(nlevelsClass+2):(ncol(probaClass)-1), drop = F])
} else {
infoClass <- NULL
probs <- NULL
}
list(nodes_var = nodes_var, nodes_var_x = nodes_var_x, sortLabels = sortLabels,
infoClass = infoClass, probs = probs)
}
})
# Get color
updateColorVar <- shiny::reactive({
newColorVar <- infoColors$colorVar
if(!is.null(newColorVar)){
input_name <- gsub(" ", "", paste0(newColorVar$variable, "var"))
newColorVar$color <- as.character(newColorVar$color)
if(!is.null(input[[input_name[1]]])){
colorVect <- sapply(input_name, function(X){
tmp <- input[[X]]
ifelse(is.null(tmp), "", tmp)
})
newColorVar$color[colorVect != ""] <- colorVect[colorVect != ""]
}
newColorVar
} else {
NULL
}
})
# Color for Y
updateColorY <- shiny::reactive({
colorY <- infoColors$colorY$colorY
if(is.data.frame(colorY)){
dest <- paste0(gsub(" ", "", paste0(colorY$modality, "Y")))
if(!is.null(input[[dest[1]]])){
colorVect <- sapply(dest, function(X)input[[X]])
colorY$color <- colorVect
}
}else{
if(!is.null(input$minY)){
colorY[1] <- input$minY
colorY[2] <- input$maxY
}
}
colorY
})
output$colornodes <- shiny::renderUI({
if(!input$usecolornodes){
return(NULL)
}else{
corNodes <- updateColorVar()
if(nrow(corNodes) > 0){
res <- apply(corNodes, 1, function(x){
as.character(shiny::column(6,colourpicker::colourInput(ns(gsub(" ", "", paste0(x[1],"var"))), paste0(x[1]," :"), x[2])))
}) %>% paste0(collapse = "") %>% htmltools::HTML()
}
}
})
# UI for color
output$colorY <- shiny::renderUI({
if(!input$usecolorY){
return(NULL)
}else{
corY <- updateColorY()
clas <- attributes(rpart_tree())$ylevels
if(!is.null(clas)){
res <- apply(corY, 1, function(x){
as.character(shiny::column(6,colourpicker::colourInput(ns(gsub(" ", "", paste0(x[1],"Y"))), paste0(x[1]," :"), x[2])))
})%>%
paste0(collapse = "") %>%
HTML()
}else{
res <- list()
res[[1]] <- as.character(shiny::column(6,
colourpicker::colourInput(ns("minY"), "Min y : ", corY[1])))
res[[2]] <- as.character(shiny::column(6,
colourpicker::colourInput(ns("maxY"), "Max y : ", corY[2])))
res <- paste0(res, collapse = "") %>%
HTML()
}
}
res
})
# Update color VarNodes
shiny::observe({
m <- treeBuild()
if(!is.null(m)){
oldId <- m$x$nodes$id
colorIn <- m$x$nodes$color
legOldId <- m$x$legend$nodes$id
legColorIn <- m$x$legend$nodes$color
outColor <- unlist(sapply(m$x$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1],"var"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1],"var"))]]
}
}))
legOutColor <- unlist(sapply(m$x$legend$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1], "var"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1], "var"))]]
}
}))
newColor <- data.frame(
id = oldId[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)],
color = outColor[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)]
)
legNewColor <- data.frame(
id = legOldId[legOutColor != "NoChange" & ifelse(legOutColor == legColorIn, FALSE, TRUE)],
color = legOutColor[legOutColor != "NoChange" & ifelse(legOutColor == legColorIn, FALSE, TRUE)]
)
clas <- attributes(shiny::isolate(rpart_tree()))$ylevels
if(!is.null(input$minY) & is.null(clas)){
coloramp <- .creatColorRampY(c(input$minY, input$maxY))
if(nrow(m$x$nodes) > 1){
meanV <- (m$x$nodes$labelClust-min(m$x$nodes$labelClust))/(max(m$x$nodes$labelClust-min(m$x$nodes$labelClust)))
} else {
meanV <- 1
}
colorTerm <- grDevices::rgb(coloramp(meanV), maxColorValue=255)
endf <- data.frame(id = m$x$nodes$id, colorClust = colorTerm, color = "")
endf$color <- as.character(endf$color)
endf$color[m$x$nodes$Leaf == 1] <- as.character(colorTerm[m$x$nodes$Leaf == 1])
endf$color[m$x$nodes$Leaf == 0] <- as.character(m$x$nodes$color[m$x$nodes$Leaf == 0])
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(endf)
}
# if(!is.null(input[[gsub(" ", "", paste0(m$x$nodes[1,]$label, "Y"))]])){
oldId <- m$x$nodes$id
legId <- m$x$legend$nodes$id
colorIn <- m$x$nodes$color
colorInLeg <- as.character(m$x$legend$nodes$color)
outColor <- unlist(sapply(m$x$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1],"Y"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1],"Y"))]]
}
}))
outColorLeg <- unlist(sapply(m$x$legend$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1],"Y"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1],"Y"))]]
}
}))
newColorGraph <- data.frame(
id = oldId[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)],
color = outColor[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)]
)
newColorLegend <- data.frame(
id = legId[outColorLeg != "NoChange" & ifelse(outColorLeg == colorInLeg, FALSE, TRUE)],
color = outColorLeg[outColorLeg != "NoChange" & ifelse(outColorLeg == colorInLeg, FALSE, TRUE)]
)
# }
if(exists("newColor") & exists("newColorGraph")){
Gcol <- rbind(newColorGraph, newColor)
}else{
if(exists("newColor")){
Gcol <- newColor
}else{
if(exists("newColorGraph")){
Gcol <- newColorGraph
}
}
}
if(exists("legNewColor") & exists("newColorLegend")){
Lcol <- rbind(newColorLegend, legNewColor)
}else{
if(exists("legNewColor")){
Lcol <- legNewColor
}else{
if(exists("newColorLegend")){
Lcol <- newColorLegend
}
}
}
if(exists("Gcol")){
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(Gcol) %>%
visUpdateNodes(Lcol, legend = TRUE)
}
}
})
# Update direction
shiny::observeEvent({!is.null(input$direction)}, {
# print("update direction")
visNetworkProxy(ns("tree")) %>%
visHierarchicalLayout(direction = input$direction)
}, ignoreNULL = TRUE, ignoreInit = TRUE)
# Update node size
shiny::observeEvent({
!is.null(input$minNodeSize) & !is.null(input$maxNodeSize) & input$nodesPopSize
}, {
# print("update nodes size")
minNodeSize <- input$minNodeSize
maxNodeSize <- input$maxNodeSize
m <- shiny::isolate(treeBuild())
if(input$nodesPopSize & !is.null(m)){
newNodes <- data.frame(id = m$x$nodes$id, scaling.min = minNodeSize, scaling.max = maxNodeSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(newNodes)
}
}, ignoreInit = TRUE)
# Update node size
shiny::observeEvent({!is.null(input$nodesSize) & input$nodesPopSize == FALSE}, {
nodesSize <- input$nodesSize
m <- shiny::isolate(treeBuild())
if(!input$nodesPopSize & !is.null(m)){
newNodes <- data.frame(id = m$x$nodes$id, scaling.min = nodesSize, scaling.max = nodesSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(newNodes)
}
}, ignoreInit = TRUE)
# Update legend node size
shiny::observeEvent(input$legendNodesSize, {
legendNodesSize <- input$legendNodesSize
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$legend)){
change_legend_nodes <- data.frame(id = m$x$legend$nodes$id, size = legendNodesSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_legend_nodes, legend = TRUE)
}
}, ignoreInit = TRUE)
# Update legend font size
shiny::observeEvent(input$legendFontSize, {
legendFontSize <- input$legendFontSize
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$legend)){
change_legend_nodes <- data.frame(id = m$x$legend$nodes$id, font.size = legendFontSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_legend_nodes, legend = TRUE)
}
}, ignoreInit = TRUE)
# Update edges color
shiny::observeEvent(input$colorEdges, {
colorEdges <- input$colorEdges
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$edges)){
idEdges <- m$x$edges$id
newEdges <- data.frame(id = m$x$edges$id, color = colorEdges)
visNetworkProxy(ns("tree")) %>%
visUpdateEdges(newEdges)
}
}, ignoreInit = TRUE)
# Update edges font size
shiny::observeEvent(input$edgesFontSize, {
edgesFontSize <- input$edgesFontSize
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$edges)){
idEdges <- m$x$edges$id
newEdges <- data.frame(id = m$x$edges$id, font.size = edgesFontSize)
visNetworkProxy(ns("tree")) %>%
visUpdateEdges(newEdges)
}
}, ignoreInit = TRUE)
# Update edges font align
shiny::observeEvent(input$edgesFontAlign, {
edgesFontAlign <- input$edgesFontAlign
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$edges)){
idEdges <- m$x$edges$id
newEdges <- data.frame(id = m$x$edges$id, font.align = edgesFontAlign)
visNetworkProxy(ns("tree")) %>%
visUpdateEdges(newEdges)
}
}, ignoreInit = TRUE)
# Update nodes font size
shiny::observeEvent(input$nodesFontSize, {
nodesFontSize <- input$nodesFontSize
m <- shiny::isolate(treeBuild())
if(!is.null(m)){
newNodes <- data.frame(id = m$x$nodes$id, font.size = nodesFontSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(newNodes)
}
}, ignoreInit = TRUE)
# reactive for title
build_main <- shiny::reactive({
text <- input$main
style <- paste0("font-family:Georgia, Times New Roman, Times, serif;font-weight:bold;font-size:",
input$mainsize,"px;text-align:center;color:", input$colourMain, ";")
list(text = text, style = style)
})
# Update title
shiny::observeEvent({!is.null(input$main) & !is.null(input$mainsize) & !is.null(input$colourMain)}, {
# print("update main")
visNetworkProxy(ns("tree")) %>%
visSetTitle(main = build_main())
}, ignoreInit = TRUE)
build_submain <- shiny::reactive({
text <- input$submain
style <- paste0("font-family:Georgia, Times New Roman, Times, serif;font-size:",
input$Submainsize,"px;text-align:center;color:", input$colourSubMain, ";")
list(text = text, style = style)
})
shiny::observe({
visNetworkProxy(ns("tree")) %>%
visSetTitle(submain = build_submain())
})
build_footer <- shiny::reactive({
text <- input$footer
style <- paste0("font-family:Georgia, Times New Roman, Times, serif;font-size:",
input$Footermainsize,"px;text-align:center;color:", input$colourFooterMain, ";")
list(text = text, style = style)
})
shiny::observe({
visNetworkProxy(ns("tree")) %>%
visSetTitle(footer = build_footer())
})
# Update shape Ynodes
shiny::observeEvent({!is.null(input$shapeX) & !is.null(input$shapeY)},{
shapeX <- input$shapeX
shapeY <- input$shapeY
m <- shiny::isolate(treeBuild())
if(!is.null(m)){
# nodes
change_nodes <- data.frame(id = m$x$nodes$id, shape = ifelse(m$x$nodes$Leaf == 0, shapeX, shapeY))
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_nodes) %>%
.visUpdateTree(shapeY = shapeY)
# legend
change_legend_nodes <- data.frame(id = m$x$legend$nodes$id, shape = ifelse(m$x$legend$nodes$Leaf == 0, shapeX, shapeY))
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_legend_nodes, legend = TRUE)
}
}, ignoreInit = TRUE)
# Update highlightNearest
update_highlightNearest <- shiny::reactive({
list(enabled = input$highlightNearest, degree = list(from = 50000, to = 0),
hover = input$highlightHover, algorithm = "hierarchical")
})
shiny::observeEvent({!is.null(input$highlightNearest) & !is.null(input$highlightHover)}, {
visNetworkProxy(ns("tree")) %>%
visOptions(highlightNearest = list(enabled = input$highlightNearest, degree = list(from = 50000, to = 0),
hover = input$highlightHover, algorithm = "hierarchical"))
}, ignoreInit = TRUE)
# Update collapse
update_collapse <- shiny::reactive({
list(enabled = input$collapse, fit = TRUE, resetHighlight = TRUE,
clusterOptions = list(fixed = TRUE, physics= FALSE))
})
shiny::observeEvent({!is.null(input$collapse)}, {
visNetworkProxy(ns("tree")) %>%
visOptions(collapse = list(enabled = input$collapse, fit = TRUE, resetHighlight = TRUE,
clusterOptions = list(fixed = TRUE, physics= FALSE)))
}, ignoreInit = TRUE)
# Update height
output$treeUI <- shiny::renderUI({
res <- rpart_tree()
shiny::isolate({
height <- get_height()
if("runTree" %in% names(input)){
if(input$runTree > 0){
height <- ifelse(is.null(input$height), height, input$height)
}
}
visNetworkOutput(ns("tree"), height = paste0(height, "px"))
})
})
build_export_tree <- shiny::reactive({
res <- rpart_tree()
# legend <- ifelse(is.null(input$legend), get_legend(), input$legend)
# rules <- ifelse(is.null(input$rules), get_rules(), input$rules)
# tooltipDelay <- ifelse(is.null(input$tooltipDelay), get_tooltipDelay(), input$tooltipDelay)
# updateShape <- ifelse(is.null(input$updateShape), get_updateShape(), input$updateShape)
# fallenLeaves <- ifelse(is.null(input$fallenLeaves), get_fallenLeaves(), input$fallenLeaves)
# digits <- ifelse(is.null(input$digits), get_digits(), input$digits)
nodesPopSize <- ifelse(is.null(input$nodesPopSize), get_nodesPopSize(), input$nodesPopSize)
# export <- ifelse(is.null(input$export), get_export(), input$export)
# simplifyRules <- ifelse(is.null(input$simpRules), get_simplifyRules(), input$simpRules)
# legendWidth <- ifelse(is.null(input$legendWidth), get_legendWidth(), input$legendWidth)
# legendNcol <- ifelse(is.null(input$legendNcol), get_legendNcol(), input$legendNcol)
legendNodesSize <- ifelse(is.null(input$legendNodesSize), get_legendNodesSize(), input$legendNodesSize)
legendFontSize <- ifelse(is.null(input$legendFontSize), get_legendFontSize(), input$legendFontSize)
# legendPosition <- ifelse(is.null(input$legendPosition), get_legendPosition(), input$legendPosition)
minNodeSize <- ifelse(is.null(input$minNodeSize), get_minNodeSize(), input$minNodeSize)
maxNodeSize <- ifelse(is.null(input$maxNodeSize), get_maxNodeSize(), input$maxNodeSize)
direction <- ifelse(is.null(input$direction), get_direction(), input$direction)
shapeY <- ifelse(is.null(input$shapeY), get_shapeY(), input$shapeY)
shapeVar <- ifelse(is.null(input$shapeX), get_shapeVar(), input$shapeX)
edgesFontSize <- ifelse(is.null(input$edgesFontSize), get_edgesFontSize(), input$edgesFontSize)
edgesFontAlign <- ifelse(is.null(input$edgesFontAlign), get_edgesFontAlign(), input$edgesFontAlign)
nodesFontSize <- ifelse(is.null(input$nodesFontSize), get_nodesFontSize(), input$nodesFontSize)
colorEdges <- ifelse(is.null(input$colorEdges), get_colorEdges(), input$colorEdges)
colorVar <- updateColorVar()
colorY <- updateColorY()
rules <- current_tree_params$rules
simplifyRules <- current_tree_params$simplifyRules
legend <- current_tree_params$legend
legendWidth <- current_tree_params$legendWidth
legendPosition <- current_tree_params$legendPosition
legendNcol <- current_tree_params$legendNcol
tooltipDelay <- current_tree_params$tooltipDelay
digits <- current_tree_params$digits
fallenLeaves <- current_tree_params$fallenLeaves
updateShape <- current_tree_params$updateShape
export <- current_tree_params$export
data <- current_tree_params$data
tooltipColumns <- current_tree_params$tooltipColumns
out <- visTree(object = res,
data = data,
tooltipColumns = tooltipColumns,
main = build_main(),
submain = build_submain(),
footer = build_footer(),
shapeY = shapeY,
shapeVar = shapeVar,
colorVar = colorVar,
colorY = colorY,
rules = rules,
simplifyRules = simplifyRules,
legend = legend,
legendWidth = legendWidth,
legendNodesSize = legendNodesSize,
legendFontSize = legendFontSize,
legendPosition = legendPosition,
legendNcol = legendNcol,
edgesFontSize = edgesFontSize,
edgesFontAlign = edgesFontAlign,
nodesFontSize = nodesFontSize,
nodesPopSize = nodesPopSize,
minNodeSize = minNodeSize,
maxNodeSize = maxNodeSize,
tooltipDelay = tooltipDelay,
digits = digits,
direction = direction,
fallenLeaves = fallenLeaves,
updateShape = updateShape,
colorEdges = colorEdges,
highlightNearest = update_highlightNearest(),
collapse = update_collapse(),
height = paste0(input$export_height, "px"),
export = export)
})
# complexity update
cp_parameters <- shiny::reactiveValues(min = 0, max = 0.2, step = 0.001)
shiny::observeEvent(input$set_cp, {
shiny::showModal(shiny::modalDialog(
title = "Complexity parameters",
shiny::numericInput(ns("cp_min"), "Slider minimum :", shiny::isolate(cp_parameters$min), step = 0.1),
shiny::numericInput(ns("cp_max"), "Slider maximum :", shiny::isolate(cp_parameters$max), step = 0.1),
shiny::numericInput(ns("cp_step"), "Slider step :", shiny::isolate(cp_parameters$step), step = 0.001),
shiny::div(shiny::actionButton(ns("update_cp"), "Update complexity slider"), align = "center"),
easyClose = TRUE,
footer = NULL
))
})
shiny::observeEvent(input$update_cp, {
cp_parameters$min <- input$cp_min
cp_parameters$max <- input$cp_max
cp_parameters$step <- input$cp_step
shiny::updateSliderInput(session, "complexity", min = input$cp_min, max = input$cp_max, step = input$cp_step)
shiny::removeModal()
})
# download tree
output$downloadNetwork <- shiny::downloadHandler(
filename = function() {
paste('tree-', Sys.Date(), '.html', sep='')
},
content = function(con) {
out <- build_export_tree()
background <- input$export_background
#Transform color
if (grepl("^#", background, perl = TRUE)) {
bgcol <- col2rgb(background, alpha = TRUE)
background <- sprintf("rgba(%d,%d,%d,%f)", bgcol[1,1], bgcol[2,1], bgcol[3,1], bgcol[4,1]/255)
}
out %>% visSave(con, TRUE, background)
}
)
# quit and get back network
shiny::observe({
if(!is.null(input$quit_btn)){
if(input$quit_btn > 0){
shiny::stopApp(build_export_tree())
}
}
})
}
#' @rdname visNetwork-treeModule
#'
#' @export
visTreeModuleUI <- function(id, rpartParams = TRUE, visTreeParams = TRUE, quitButton = FALSE) {
ns <- shiny::NS(id)
.ctrlPckTree()
if(rpartParams){
visTreeParams <- TRUE
}
selectedTabs <- ifelse(rpartParams, "rpart", "visTree options")
shiny::fluidPage(
if(visTreeParams | rpartParams){
shiny::tabsetPanel(
id = ns('boxparam'),
selected = selectedTabs ,
if(rpartParams){
shiny::tabPanel("rpart",
#Params for rparts
shiny::fluidRow(
shiny::div(align = "center",
shiny::column(2,
shiny::selectInput(ns("y"), "Y :",NULL)
),
shiny::column(5,
shiny::selectInput(ns("x"), "X :", NULL, multiple = TRUE, selected = NULL, width = "100%")
),
shiny::column(2,
shiny::numericInput(ns("minsplit"), "Minsplit : ", value = 20, min = 2)
),
shiny::column(2,
shiny::sliderInput(ns("complexity"), "Complexity (cp) :",
min = 0, max = 0.2, value = 0.005, step = 0.001)
),
shiny::column(1,
shiny::br(), shiny::br(), shiny::actionButton(ns("set_cp"), "Set cp slider")
)
)
)
)
}else{shiny::div(style = "visibility: hidden")},
if(visTreeParams){
shiny::tabPanel("visTree options",
#Params graph
shiny::fluidRow(
shiny::column(1,
shiny::uiOutput(ns("input_height"))
),
shiny::column(1,
shiny::uiOutput(ns("input_digits"))
),
shiny::column(1,
shiny::uiOutput(ns("input_tooltipDelay"))
),
shiny::column(2,
shiny::br(), shiny::uiOutput(ns("input_fallenLeaves"))
),
shiny::column(2,
shiny::br(),
shiny::uiOutput(ns("input_updateShape"))
),
shiny::column(2,
shiny::br(),
shiny::uiOutput(ns("input_rules"))
),
shiny::conditionalPanel(paste0("input['",ns("rules"),"'] == true"),
shiny::column(2,
shiny::br(),
shiny::checkboxInput(ns("simpRules"),"Simplify rules", value = TRUE))
),
shiny::column(1,
shiny::br(),
shiny::uiOutput(ns("input_export"))
)
),
shiny::conditionalPanel(paste0("output['",ns("is_data_frame"),"'] === true"),
shiny::fluidRow(
shiny::column(12,
shiny::selectInput(ns("tooltipColumns"), "tooltipColumns :", NULL, multiple = TRUE, selected = NULL, width = "100%")
)
)
)
)
}else{shiny::div(style = "visibility: hidden")},
if(visTreeParams){
shiny::tabPanel("Legend",
shiny::fluidRow(
shiny::column(2, offset = 1,
shiny::br(),
shiny::uiOutput(ns("input_legend"))
),
# shiny::conditionalPanel(paste0("input['",ns("legend"),"'] == true"),
shiny::column(2,
shiny::uiOutput(ns("input_legendWidth"))
),
shiny::column(2,
shiny::uiOutput(ns("input_legendNcol"))
),
shiny::column(2,
shiny::uiOutput(ns("input_legendPosition"))
)
)
)
}else{shiny::div(style = "visibility: hidden")}
)
},
if(visTreeParams | rpartParams){
if(quitButton){
shiny::fluidRow(
shiny::column(width = 3, offset = 3,
shiny::div(
shiny::actionButton(ns("runTree"), "Run / update tree", class = "btnruntree"), align = "center"
)
),
shiny::column(width = 3,
shiny::div(
shiny::actionButton(ns("quit_btn"), "Quit and get back network in R"), align = "center"
)
)
)
} else {
shiny::div(
shiny::actionButton(ns("runTree"), "Run / update tree", class = "btnruntree"), align = "center"
)
}
}else{shiny::div(style = "visibility: hidden")},
shiny::hr(),
shiny::conditionalPanel(condition = paste0("output['", ns("is_tree"), "'] === true"),
shiny::fluidRow(
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("share-alt"),status = "danger",width = 500, circle = T,
label = "Update nodes properties", tooltip = TRUE,
shiny::fluidRow(
shiny::column(4,
shiny::uiOutput(ns("input_shapeY")),
shiny::uiOutput(ns("input_shapeX"))
),
shiny::column(4,
shiny::uiOutput(ns("input_nodesSize")),
shiny::uiOutput(ns("input_legendNodesSize"))
),
shiny::column(4,
shiny::uiOutput(ns("input_nodesFontSize")),
shiny::uiOutput(ns("input_legendFontSize"))
)
),
shiny::column(12,
shiny::br(),
shinyWidgets::materialSwitch(ns("nodesPopSize"),
"Nodes size use population", status = "info"),
shiny::conditionalPanel(paste0("input['", ns("nodesPopSize"),"'] == true"),
shiny::column(6,
shiny::uiOutput(ns("input_minNodeSize"))
),
shiny::column(6,
shiny::uiOutput(ns("input_maxNodeSize"))
)
),
shiny::br(),
shinyWidgets::materialSwitch(ns("usecolornodes"),"Color nodes", status = "info"),
shiny::fluidRow(
shiny::uiOutput(ns("colornodes"))
),
shiny::br(),
shinyWidgets::materialSwitch(ns("usecolorY"),"Color Y", status = "info"),
shiny::uiOutput(ns("colorY"))
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("exchange"), status = "warning", width = 300, circle = T,
label = "Update edges properties", tooltip = TRUE,
shiny::fluidRow(
shiny::column(12,
shiny::uiOutput(ns("input_colorEdges")),
shiny::uiOutput(ns("input_edgesFontSize")),
shiny::uiOutput(ns("input_edgesFontAlign"))
)
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("header"), status = "info", width = 400, circle = T,
label = "Set title, subtitle and footer", tooltip = TRUE,
shiny::fluidRow(
shiny::column(12,
shiny::uiOutput(ns("input_main")),
shiny::uiOutput(ns("input_submain")),
shiny::uiOutput(ns("input_footer"))
)
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("gear"),status = "success",width = 300,circle = T,
label = "Interaction and layout", tooltip = TRUE,
shiny:: fluidRow(
shiny::column(12,
shiny::uiOutput(ns("input_highlight")),
shiny::uiOutput(ns("input_collapse")),
shiny::uiOutput(ns("input_direction"))
)
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("download"),status = "default", width = 300, circle = T,
label = "Download the network as html", tooltip = TRUE,
shiny:: fluidRow(
shiny::column(12,
shiny::sliderInput(ns("export_height"), "Height:",
min = 200, max = 1400, value = 900),
# shinyWidgets::materialSwitch(ns("export_self"),
# "selfcontained ?", status = "info", value = TRUE),
colourpicker::colourInput(ns("export_background"),
"Background color :", value = "white"),
shiny::downloadLink(ns('downloadNetwork'), 'Download Tree as html')
)
)
)
)
),
shiny::uiOutput(ns("treeUI"))
)
)
}
.ctrlPckTree <- function(){
miss_packages <- c()
if(!requireNamespace("shiny", quietly = TRUE)){
miss_packages <- c(miss_packages, "'shiny (>1.0.0)'")
}
if(!requireNamespace("colourpicker", quietly = TRUE)){
miss_packages <- c(miss_packages, "'colourpicker'")
}
if(!requireNamespace("shinyWidgets", quietly = TRUE)){
miss_packages <- c(miss_packages, "'shinyWidgets'")
}
if(!requireNamespace("rpart", quietly = TRUE)){
miss_packages <- c(miss_packages, "'rpart'")
}
if(!requireNamespace("sparkline", quietly = TRUE)){
miss_packages <- c(miss_packages, "'sparkline'")
}
if(length(miss_packages) == 1){
stop(miss_packages," package is needed for this visTreeModule / visTreeEditor", call. = FALSE)
} else if(length(miss_packages) > 1){
stop(paste(miss_packages, collapse = ", ")," packages are needed for visTreeModule / visTreeEditor", call. = FALSE)
}
invisible(NULL)
}
Try the visNetwork package in your browser
Any scripts or data that you put into this service are public.
visNetwork documentation built on Sept. 29, 2022, 5:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .ctrlPckTree visTreeModuleUI visTreeModuleServer
Documented in visTreeModuleServer visTreeModuleUI
#' Module shiny for visualize and customize a \code{rpart} tree
#'
#' Needed packages : shiny, rpart, colourpicker, shinyWidgets, sparkline
#'
#' @param id \code{character} id of module, linked to \link{visTreeModuleServer}
#' @param rpartParams \code{boolean}, add tabs for rpart parameters (in case of \code{data.frame} in input)
#' @param visTreeParams \code{boolean}, add tabs for visTree parameters. Default to TRUE. Force to TRUE if \code{rpartParams}
#' @param quitButton \code{boolean}, add a button to quit module and get back network in R ?
#'
#' @param input \code{list} shiny input
#' @param output \code{list}, shiny output
#' @param session \code{list}, shiny session
#' @param data \code{reactive}, a \code{data.frame} or a \code{rpart} result. Must be a reactive object
#' @param tooltip_data \code{reactive}, a \code{data.frame}. if \code{data} is a \code{rpart},
#' data.frame used to build tree in order to plot \code{sparkline}
#'
#' @inheritParams visTree
#'
#'
#' @examples
#' \dontrun{
#'
#' require(rpart)
#' # simple module editor on rpart
#' data <- iris
#' shiny::shinyApp(ui = shiny::fluidPage(
#' visTreeModuleUI(id = "id1", rpartParams = FALSE, visTreeParams = FALSE)),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(rpart(data)))
#' })
#'
#' # full module editor on rpart + data.frame for sparkline
#' data <- iris
#' shiny::shinyApp(ui = shiny::fluidPage(
#' visTreeModuleUI(id = "id1", rpartParams = FALSE, visTreeParams = TRUE)),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(rpart(data)),
#' tooltip_data = data)
#' })
#'
#' # module on data.frame
#' shiny::shinyApp(ui = shiny::fluidPage(visTreeModuleUI(id = "id1",
#' rpartParams = TRUE)),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(data))
#' })
#'
#' # multiple modules
#' shiny::shinyApp(ui =
#' navbarPage("Menu",shiny::tabPanel(
#' "tt1",shiny::fluidPage(visTreeModuleUI(id = "id1",
#' rpartParams = TRUE,
#' visTreeParams = TRUE))
#' ),
#' shiny::tabPanel(
#' "tt2",shiny::fluidPage(visTreeModuleUI(id = "id2",
#' rpartParams = FALSE,
#' visTreeParams = FALSE)))
#' ),
#' server = function(input, output, session) {
#' shiny::callModule(visTreeModuleServer, "id1", data = shiny::reactive(iris))
#' shiny::callModule(visTreeModuleServer, "id2", data = shiny::reactive(rpart(iris)))
#' })
#' }
#'
#' @name visNetwork-treeModule
#'
#' @export
#'
#' @importFrom stats as.formula
#' @importFrom grDevices col2rgb
#'
#' @references See online documentation \url{https://datastorm-open.github.io/visNetwork/}
#'
visTreeModuleServer <- function(input, output, session, data,
tooltip_data = NULL,
tooltipColumns = "",
main = "",
submain = "",
footer = "",
direction = "UD",
fallenLeaves = FALSE,
rules = TRUE,
simplifyRules = TRUE,
shapeVar = "dot",
shapeY = "square",
colorVar = NULL,
colorY = NULL,
colorEdges = "#8181F7",
nodesFontSize = 16,
edgesFontSize = 14,
edgesFontAlign = "horizontal",
legend = TRUE,
legendNodesSize = 22,
legendFontSize = 16,
legendWidth = 0.1,
legendNcol = 1,
legendPosition = "left",
nodesPopSize = FALSE,
minNodeSize = 15,
maxNodeSize = 30,
highlightNearest = list(enabled = TRUE,
degree = list(from = 50000, to = 0), hover = FALSE,
algorithm = "hierarchical"),
collapse = list(enabled = TRUE, fit = TRUE, resetHighlight = TRUE,
clusterOptions = list(fixed = TRUE, physics = FALSE)),
updateShape = TRUE,
tooltipDelay = 500,
digits = 3,
height = 650,
width = "100%",
export = TRUE) {
ns <- session$ns
# reactive controls
if (!shiny::is.reactive(tooltip_data)){
get_tooltip_data <- shiny::reactive({tooltip_data})
} else {
get_tooltip_data <- tooltip_data
}
if (!shiny::is.reactive(tooltipColumns)){
get_tooltipColumns <- shiny::reactive({tooltipColumns})
} else {
get_tooltipColumns <- tooltipColumns
}
if (!shiny::is.reactive(main)){
get_main <- shiny::reactive({main})
} else {
get_main <- main
}
if (!shiny::is.reactive(submain)){
get_submain <- shiny::reactive({submain})
} else {
get_submain <- submain
}
if (!shiny::is.reactive(footer)){
get_footer <- shiny::reactive({footer})
} else {
get_footer <- footer
}
if (!shiny::is.reactive(direction)){
get_direction <- shiny::reactive({direction})
} else {
get_direction <- direction
}
if (!shiny::is.reactive(fallenLeaves)){
get_fallenLeaves <- shiny::reactive({fallenLeaves})
} else {
get_fallenLeaves <- fallenLeaves
}
if (!shiny::is.reactive(rules)){
get_rules <- shiny::reactive({rules})
} else {
get_rules <- rules
}
if (!shiny::is.reactive(simplifyRules)){
get_simplifyRules <- shiny::reactive({simplifyRules})
} else {
get_simplifyRules <- simplifyRules
}
if (!shiny::is.reactive(shapeVar)){
get_shapeVar <- shiny::reactive({shapeVar})
} else {
get_shapeVar <- shapeVar
}
if (!shiny::is.reactive(shapeY)){
get_shapeY <- shiny::reactive({shapeY})
} else {
get_shapeY <- shapeY
}
if (!shiny::is.reactive(colorVar)){
get_colorVar <- shiny::reactive({colorVar})
} else {
get_colorVar <- colorVar
}
if (!shiny::is.reactive(colorY)){
get_colorY <- shiny::reactive({colorY})
} else {
get_colorY <- colorY
}
if (!shiny::is.reactive(colorEdges)){
get_colorEdges <- shiny::reactive({colorEdges})
} else {
get_colorEdges <- colorEdges
}
if (!shiny::is.reactive(nodesFontSize)){
get_nodesFontSize <- shiny::reactive({nodesFontSize})
} else {
get_nodesFontSize <- nodesFontSize
}
if (!shiny::is.reactive(edgesFontSize)){
get_edgesFontSize <- shiny::reactive({edgesFontSize})
} else {
get_edgesFontSize <- edgesFontSize
}
if (!shiny::is.reactive(edgesFontAlign)){
get_edgesFontAlign <- shiny::reactive({edgesFontAlign})
} else {
get_edgesFontAlign <- edgesFontAlign
}
if (!shiny::is.reactive(legend)){
get_legend <- shiny::reactive({legend})
} else {
get_legend <- legend
}
if (!shiny::is.reactive(legendNodesSize)){
get_legendNodesSize <- shiny::reactive({legendNodesSize})
} else {
get_legendNodesSize <- legendNodesSize
}
if (!shiny::is.reactive(legendFontSize)){
get_legendFontSize <- shiny::reactive({legendFontSize})
} else {
get_legendFontSize <- legendFontSize
}
if (!shiny::is.reactive(legendWidth)){
get_legendWidth <- shiny::reactive({legendWidth})
} else {
get_legendWidth <- legendWidth
}
if (!shiny::is.reactive(legendNcol)){
get_legendNcol <- shiny::reactive({legendNcol})
} else {
get_legendNcol <- legendNcol
}
if (!shiny::is.reactive(legendPosition)){
get_legendPosition <- shiny::reactive({legendPosition})
} else {
get_legendPosition <- legendPosition
}
if (!shiny::is.reactive(nodesPopSize)){
get_nodesPopSize <- shiny::reactive({nodesPopSize})
} else {
get_nodesPopSize <- nodesPopSize
}
if (!shiny::is.reactive(minNodeSize)){
get_minNodeSize <- shiny::reactive({minNodeSize})
} else {
get_minNodeSize <- minNodeSize
}
if (!shiny::is.reactive(maxNodeSize)){
get_maxNodeSize <- shiny::reactive({maxNodeSize})
} else {
get_maxNodeSize <- maxNodeSize
}
if (!shiny::is.reactive(highlightNearest)){
get_highlightNearest <- shiny::reactive({highlightNearest})
} else {
get_highlightNearest <- highlightNearest
}
if (!shiny::is.reactive(collapse)){
get_collapse <- shiny::reactive({collapse})
} else {
get_collapse <- collapse
}
if (!shiny::is.reactive(updateShape)){
get_updateShape <- shiny::reactive({updateShape})
} else {
get_updateShape <- updateShape
}
if (!shiny::is.reactive(tooltipDelay)){
get_tooltipDelay <- shiny::reactive({tooltipDelay})
} else {
get_tooltipDelay <- tooltipDelay
}
if (!shiny::is.reactive(digits)){
get_digits <- shiny::reactive({digits})
} else {
get_digits <- digits
}
if (!shiny::is.reactive(height)){
get_height <- shiny::reactive({height})
} else {
get_height <- height
}
if (!shiny::is.reactive(width)){
get_width <- shiny::reactive({width})
} else {
get_width <- width
}
if (!shiny::is.reactive(export)){
get_export <- shiny::reactive({export})
} else {
get_export <- export
}
# create input
output$input_legend <- shiny::renderUI({
legend <- get_legend()
shiny::isolate({
shiny::checkboxInput(ns("legend"), "Display legend", value = legend)
})
})
shiny::outputOptions(output, "input_legend", suspendWhenHidden = FALSE)
output$input_fallenLeaves <- shiny::renderUI({
fallenLeaves <- get_fallenLeaves()
shiny::isolate({
shiny::checkboxInput(ns("fallenLeaves"), "Fallen leaves", fallenLeaves)
})
})
shiny::outputOptions(output, "input_fallenLeaves", suspendWhenHidden = FALSE)
output$input_rules <- shiny::renderUI({
rules <- get_rules()
shiny::isolate({
shiny::checkboxInput(ns("rules"),"Display rules", value = rules)
})
})
shiny::outputOptions(output, "input_rules", suspendWhenHidden = FALSE)
output$input_updateShape <- shiny::renderUI({
updateShape <- get_updateShape()
shiny::isolate({
shiny::checkboxInput(ns("updateShape"), "Update shape", value = updateShape)
})
})
shiny::outputOptions(output, "input_updateShape", suspendWhenHidden = FALSE)
output$input_export <- shiny::renderUI({
export <- get_export()
shiny::isolate({
shiny::checkboxInput(ns("export"), "Export", value = export)
})
})
shiny::outputOptions(output, "input_export", suspendWhenHidden = FALSE)
output$input_height <- shiny::renderUI({
height <- get_height()
shiny::isolate({
shiny::numericInput(ns("height"), "Height :", value = height)
})
})
shiny::outputOptions(output, "input_height", suspendWhenHidden = FALSE)
output$input_digits <- shiny::renderUI({
digits <- get_digits()
shiny::isolate({
shiny::numericInput(ns("digits"), "Digits : ", value = digits, min = 0)
})
})
shiny::outputOptions(output, "input_digits", suspendWhenHidden = FALSE)
output$input_tooltipDelay <- shiny::renderUI({
tooltipDelay <- get_tooltipDelay()
shiny::isolate({
shiny::numericInput(ns("tooltipDelay"), "Tooltip delay :", value = tooltipDelay, min = 0, step = 100)
})
})
shiny::outputOptions(output, "input_tooltipDelay", suspendWhenHidden = FALSE)
output$input_legendWidth <- shiny::renderUI({
legendWidth <- get_legendWidth()
shiny::isolate({
shiny::numericInput(ns("legendWidth"), "Width :", value = legendWidth, min = 0, max = 0.5, step = 0.05)
})
})
shiny::outputOptions(output, "input_legendWidth", suspendWhenHidden = FALSE)
output$input_legendNcol <- shiny::renderUI({
legendNcol <- get_legendNcol()
shiny::isolate({
shiny::numericInput(ns("legendNcol"), "Number of columns :", value = legendNcol, min = 1, max = 50, step = 1)
})
})
shiny::outputOptions(output, "input_legendNcol", suspendWhenHidden = FALSE)
output$input_legendPosition <- shiny::renderUI({
legendPosition <- get_legendPosition()
shiny::isolate({
shiny::selectInput(ns("legendPosition"), "Position", choices = c("left", "right"), selected = legendPosition)
})
})
shiny::outputOptions(output, "input_legendPosition", suspendWhenHidden = FALSE)
output$input_shapeY <- shiny::renderUI({
shapeY <- get_shapeY()
shiny::isolate({
shiny::selectInput(ns("shapeY"), "shape Y", choices = c("diamond",
"dot",
"star",
"triangle",
"triangleDown",
"square",
"ellipse",
"circle",
"database",
"box",
"text"), selected = shapeY)
})
})
shiny::outputOptions(output, "input_shapeY", suspendWhenHidden = FALSE)
output$input_shapeX <- shiny::renderUI({
shapeVar <- get_shapeVar()
shiny::isolate({
shiny::selectInput(ns("shapeX"), "shape X", choices = c("diamond",
"dot",
"star",
"triangle",
"triangleDown",
"square",
"ellipse",
"circle",
"database",
"box",
"text"), selected = shapeVar)
})
})
shiny::outputOptions(output, "input_shapeX", suspendWhenHidden = FALSE)
output$input_nodesSize <- shiny::renderUI({
nodesSize <- (get_maxNodeSize() + get_minNodeSize()) / 2
shiny::isolate({
shiny::numericInput(ns("nodesSize"), "Nodes size", value = nodesSize, min = 1)
})
})
shiny::outputOptions(output, "input_nodesSize", suspendWhenHidden = FALSE)
output$input_maxNodeSize <- shiny::renderUI({
value = get_maxNodeSize()
shiny::isolate({
shiny::numericInput(ns("maxNodeSize"), "Max nodes size", value = value, min = 1)
})
})
shiny::outputOptions(output, "input_maxNodeSize", suspendWhenHidden = FALSE)
output$input_minNodeSize <- shiny::renderUI({
value = get_minNodeSize()
shiny::isolate({
shiny::numericInput(ns("minNodeSize"), "Min nodes size", value = value, min = 1)
})
})
shiny::outputOptions(output, "input_minNodeSize", suspendWhenHidden = FALSE)
output$input_legendNodesSize <- shiny::renderUI({
legendNodesSize <- get_legendNodesSize()
shiny::isolate({
shiny::numericInput(ns("legendNodesSize"), "Legend size", value = legendNodesSize, min = 1)
})
})
shiny::outputOptions(output, "input_legendNodesSize", suspendWhenHidden = FALSE)
output$input_nodesFontSize <- shiny::renderUI({
nodesFontSize <- get_nodesFontSize()
shiny::isolate({
shiny::numericInput(ns("nodesFontSize"), "Nodes font", value = nodesFontSize, min = 1)
})
})
shiny::outputOptions(output, "input_nodesFontSize", suspendWhenHidden = FALSE)
output$input_legendFontSize <- shiny::renderUI({
legendFontSize <- get_legendFontSize()
shiny::isolate({
shiny::numericInput(ns("legendFontSize"), "Legend font", value = legendFontSize, min = 1)
})
})
shiny::outputOptions(output, "input_legendFontSize", suspendWhenHidden = FALSE)
output$input_colorEdges <- shiny::renderUI({
colorEdges <- get_colorEdges()
shiny::isolate({
colourpicker::colourInput(ns("colorEdges"), "Edges color", value = colorEdges)
})
})
shiny::outputOptions(output, "input_colorEdges", suspendWhenHidden = FALSE)
output$input_edgesFontSize <- shiny::renderUI({
edgesFontSize <- get_edgesFontSize()
shiny::isolate({
shiny::numericInput(ns("edgesFontSize"), "Edges font", value = edgesFontSize, min = 1)
})
})
shiny::outputOptions(output, "input_edgesFontSize", suspendWhenHidden = FALSE)
output$input_edgesFontAlign <- shiny::renderUI({
edgesFontAlign <- get_edgesFontAlign()
shiny::isolate({
shiny::selectInput(ns("edgesFontAlign"), "Edges font align",
choices = c("horizontal", "top", "middle", "bottom"),
selected = edgesFontAlign)
})
})
shiny::outputOptions(output, "input_edgesFontAlign", suspendWhenHidden = FALSE)
output$input_direction <- shiny::renderUI({
direction <- get_direction()
shiny::isolate({
shiny::selectInput(ns("direction"), "Direction :",
choices = c("up-down" = "UD", "down-up" = "DU",
"left-right" = "LR", "right-left" = "RL"),
selected = direction)
})
})
shiny::outputOptions(output, "input_direction", suspendWhenHidden = FALSE)
output$input_edgesFontAlign <- shiny::renderUI({
edgesFontAlign <- get_edgesFontAlign()
shiny::isolate({
shiny::selectInput(ns("edgesFontAlign"), "Edges font align",
choices = c("horizontal", "top", "middle", "bottom"),
selected = edgesFontAlign)
})
})
shiny::outputOptions(output, "input_edgesFontAlign", suspendWhenHidden = FALSE)
output$input_highlight <- shiny::renderUI({
highlightNearest <- get_highlightNearest()
shiny::isolate({
nearest <- TRUE
hover <- FALSE
if(is.logical(highlightNearest)){
nearest <- highlightNearest
hover <- FALSE
} else {
if(!is.null(highlightNearest$enabled)){
nearest <- highlightNearest$enabled
}
if(!is.null(highlightNearest$hover)){
hover <- highlightNearest$hover
}
}
shiny::fluidRow(
shiny::column(12,
shinyWidgets::materialSwitch(ns("highlightNearest"), "highlight nearest", status = "info", value = nearest),
shinyWidgets::materialSwitch(ns("highlightHover"), "highlight hover", status = "info", value = hover)
)
)
})
})
shiny::outputOptions(output, "input_highlight", suspendWhenHidden = FALSE)
output$input_collapse <- shiny::renderUI({
collapse <- get_collapse()
shiny::isolate({
value <- TRUE
if(is.logical(collapse)){
value <- collapse
} else {
if(!is.null(collapse$enabled)){
value <- collapse$enabled
}
}
shinyWidgets::materialSwitch(ns("collapse"), "Collapse", status = "info", value = value)
})
})
shiny::outputOptions(output, "input_collapse", suspendWhenHidden = FALSE)
# update main
output$input_main <- shiny::renderUI({
main <- get_main()
shiny::isolate({
text <- ""
color <- "black"
size <- 20
if(any(c("character", "factor") %in% class(main))){
text <- main
} else {
if(is.list(main)){
if(!is.null(main$text)){
text <- main$text
}
if(!is.null(main$style)){
find_size <- gregexpr("(font-size:)[[:digit:]]*", main$style)
tmp_size <- as.numeric(gsub("font-size:", "", unlist(regmatches(main$style, find_size))))[1]
if(!is.na(size)){
size <- tmp_size
}
find_color <- gregexpr("(color:#)[[:alnum:]]*", main$style)
tmp_color <- gsub("color:", "", unlist(regmatches(main$style, find_color)))[1]
if(!is.na(color)){
color <- tmp_color
}
}
}
}
shiny::fluidRow(
shiny::column(4,
shiny::textInput(ns("main"), "Main :", text)
),
shiny::column(4,
colourpicker::colourInput(ns("colourMain"),
"Main color :", value = color)
),
shiny::column(4,
shiny::numericInput(ns("mainsize"), "Main size :",
value = size, min = 1)
)
)
})
})
shiny::outputOptions(output, "input_main", suspendWhenHidden = FALSE)
# update submain
output$input_submain <- shiny::renderUI({
submain <- get_submain()
shiny::isolate({
text <- ""
color <- "black"
size <- 12
if(any(c("character", "factor") %in% class(submain))){
text <- submain
} else {
if(is.list(submain)){
if(!is.null(submain$text)){
text <- submain$text
}
if(!is.null(submain$style)){
find_size <- gregexpr("(font-size:)[[:digit:]]*", submain$style)
tmp_size <- as.numeric(gsub("font-size:", "", unlist(regmatches(submain$style, find_size))))[1]
if(!is.na(size)){
size <- tmp_size
}
find_color <- gregexpr("(color:#)[[:alnum:]]*", submain$style)
tmp_color <- gsub("color:", "", unlist(regmatches(submain$style, find_color)))[1]
if(!is.na(color)){
color <- tmp_color
}
}
}
}
shiny::fluidRow(
shiny::column(4,
shiny::textInput(ns("submain"), "Submain :", text)
),
shiny::column(4,
colourpicker::colourInput(ns("colourSubMain"),
"Submain color :", value = color)
),
shiny::column(4,
shiny::numericInput(ns("Submainsize"), "Submain size :",
value = size, min = 1)
)
)
})
})
shiny::outputOptions(output, "input_submain", suspendWhenHidden = FALSE)
# update footer
output$input_footer <- shiny::renderUI({
footer <- get_footer()
shiny::isolate({
text <- ""
color <- "black"
size <- 12
if(any(c("character", "factor") %in% class(footer))){
text <- footer
} else {
if(is.list(footer)){
if(!is.null(footer$text)){
text <- footer$text
}
if(!is.null(footer$style)){
find_size <- gregexpr("(font-size:)[[:digit:]]*", footer$style)
tmp_size <- as.numeric(gsub("font-size:", "", unlist(regmatches(footer$style, find_size))))[1]
if(!is.na(size)){
size <- tmp_size
}
find_color <- gregexpr("(color:#)[[:alnum:]]*", footer$style)
tmp_color <- gsub("color:", "", unlist(regmatches(footer$style, find_color)))[1]
if(!is.na(color)){
color <- tmp_color
}
}
}
}
shiny::fluidRow(
shiny::column(4,
shiny::textInput(ns("footer"), "Footer :", text)
),
shiny::column(4,
colourpicker::colourInput(ns("colourFooterMain"),
"Footer color :", value = color)
),
shiny::column(4,
shiny::numericInput(ns("Footermainsize"), "Footer size :",
value = size, min = 1)
)
)
})
})
shiny::outputOptions(output, "input_footer", suspendWhenHidden = FALSE)
shiny::observe({
if("data.frame" %in% class(data())){
shiny::updateSelectInput(session, inputId = "y", choices = names(data()))
}
})
shiny::observe({
if("data.frame" %in% class(data())){
shiny::updateSelectInput(session, inputId = "x", choices = names(data())[names(data())!=input$y],
selected = names(data())[names(data())!=input$y])
}
})
shiny::observe({
if("data.frame" %in% class(data())){
choices = 1:ncol(data())
names(choices) = names(data())
selected = get_tooltipColumns()
if(isTRUE(all.equal(selected, ""))){
selected <- choices
}else if(class(selected) %in% c("character", "factor")){
selected <- which(selected %in% names(data()))
}
shiny::isolate({
shiny::updateSelectInput(session, inputId = "tooltipColumns",
choices = choices,
selected = selected)
})
} else if(!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data())){
choices = 1:ncol(get_tooltip_data())
names(choices) = names(get_tooltip_data())
selected = get_tooltipColumns()
if(class(selected) %in% c("character", "factor")){
selected <- which(selected %in% names(get_tooltip_data()))
}
if(isTRUE(all.equal(selected, ""))){
selected <- choices
}
shiny::isolate({
shiny::updateSelectInput(session, inputId = "tooltipColumns", choices = choices, selected = selected)
})
}
})
output$is_data_frame <- shiny::reactive({
"data.frame" %in% class(data()) || (!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data()))
})
shiny::outputOptions(output, "is_data_frame", suspendWhenHidden = FALSE)
# Get rpart from reactive data
rpart_tree <- shiny::reactive({
input$runTree
if("rpart" %in% class(data())){
data()
} else {
if(input$runTree > 0){
shiny::isolate({
if(length(input$x) > 0){
x_frm <- paste0("`", paste0(input$x, collapse = "` + `"), "`")
} else {
x_frm <- " . "
}
formule <- paste0("`", input$y, "` ~ ", x_frm) %>% as.formula()
rpart::rpart(formule, data = data(),
control = rpart::rpart.control(cp = input$complexity, minsplit = input$minsplit))
})
} else {
NULL
}
}
})
shiny::observe({
input$y
input$x
input$complexity
input$minsplit
shiny::updateCheckboxInput(session,"usecolornodes", value = FALSE )
shiny::updateCheckboxInput(session,"usecolorY", value = FALSE )
})
# data.frame with variables colors
infoColors <- shiny::reactiveValues(colorVar = NULL, colorY = NULL)
current_tree_params <- shiny::reactiveValues()
# Build tree (visTree)
treeBuild <- shiny::reactive({
res <- rpart_tree()
if(!is.null(res)){
shiny::isolate({
main <- get_main()
submain <- get_submain()
footer <- get_footer()
direction <- get_direction()
fallenLeaves <- get_fallenLeaves()
rules <- get_rules()
simplifyRules <- get_simplifyRules()
shapeVar <- get_shapeVar()
shapeY <- get_shapeY()
colorVar <- get_colorVar()
colorY <- get_colorY()
colorEdges <- get_colorEdges()
nodesFontSize <- get_nodesFontSize()
edgesFontSize <- get_edgesFontSize()
edgesFontAlign <- get_edgesFontAlign()
legend <- get_legend()
legendNodesSize <- get_legendNodesSize()
legendFontSize <- get_legendFontSize()
legendWidth <- get_legendWidth()
legendNcol <- get_legendNcol()
legendPosition <- get_legendPosition()
nodesPopSize <- get_nodesPopSize()
minNodeSize <- get_minNodeSize()
maxNodeSize <- get_maxNodeSize()
highlightNearest <- get_highlightNearest()
collapse <- get_collapse()
updateShape <- get_updateShape()
tooltipDelay <- get_tooltipDelay()
digits <- get_digits()
height <- get_height()
width <- get_width()
export <- get_export()
if("data.frame" %in% class(data())){
data <- data()
tooltipColumns <- get_tooltipColumns()
if(isTRUE(all.equal(tooltipColumns, ""))){
tooltipColumns <- 1:ncol(data)
}
} else {
if(!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data())){
data <- get_tooltip_data()
tooltipColumns <- get_tooltipColumns()
if(isTRUE(all.equal(tooltipColumns, ""))){
tooltipColumns <- 1:ncol(data)
}
} else {
data <- NULL
tooltipColumns <- NULL
}
}
if("runTree" %in% names(input)){
if(input$runTree > 0){
legend <- input$legend
rules <- input$rules
tooltipDelay <- input$tooltipDelay
updateShape <- input$updateShape
fallenLeaves <- input$fallenLeaves
digits <- input$digits
height <- input$height
nodesPopSize <- input$nodesPopSize
export <- input$export
colorVar <- updateColorVar()
tmp_colorY <- updateColorY()
if("class" %in% res$method & is.data.frame(tmp_colorY)){
colorY <- tmp_colorY
} else if("anova" %in% res$method & "character" %in% class(tmp_colorY)){
colorY <- tmp_colorY
}
main = build_main()
submain = build_submain()
footer = build_footer()
simplifyRules <- ifelse(is.null(input$simpRules), simplifyRules, input$simpRules)
legendWidth <- ifelse(is.null(input$legendWidth), legendWidth, input$legendWidth)
legendNcol <- ifelse(is.null(input$legendNcol), legendNcol, input$legendNcol)
legendNodesSize <- ifelse(is.null(input$legendNodesSize), legendNodesSize, input$legendNodesSize)
legendFontSize <- ifelse(is.null(input$legendFontSize), legendFontSize, input$legendFontSize)
legendPosition <- ifelse(is.null(input$legendPosition), legendPosition, input$legendPosition)
minNodeSize <- ifelse(is.null(input$minNodeSize), minNodeSize, input$minNodeSize)
maxNodeSize <- ifelse(is.null(input$maxNodeSize), maxNodeSize, input$maxNodeSize)
direction <- ifelse(is.null(input$direction), direction, input$direction)
shapeY <- ifelse(is.null(input$shapeY), shapeY, input$shapeY)
shapeVar <- ifelse(is.null(input$shapeX), shapeVar, input$shapeX)
edgesFontSize <- ifelse(is.null(input$edgesFontSize), edgesFontSize, input$edgesFontSize)
edgesFontAlign <- ifelse(is.null(input$edgesFontAlign), edgesFontAlign, input$edgesFontAlign)
nodesFontSize <- ifelse(is.null(input$nodesFontSize), nodesFontSize, input$nodesFontSize)
colorEdges <- ifelse(is.null(input$colorEdges), colorEdges, input$colorEdges)
if("data.frame" %in% class(data())){
data <- data()
if(is.null(input$tooltipColumns)){
tooltipColumns <- NULL
} else if(length(input$tooltipColumns) == 0){
tooltipColumns <- NULL
} else {
tooltipColumns <- as.numeric(input$tooltipColumns)
}
} else {
if(!is.null(get_tooltip_data()) && "data.frame" %in% class(get_tooltip_data())){
data <- get_tooltip_data()
if(is.null(input$tooltipColumns)){
tooltipColumns <- NULL
} else if(length(input$tooltipColumns) == 0){
tooltipColumns <- NULL
} else {
tooltipColumns <- as.numeric(input$tooltipColumns)
}
} else {
data <- NULL
tooltipColumns <- NULL
}
}
}
}
current_tree_params$rules = rules
current_tree_params$simplifyRules = simplifyRules
current_tree_params$legend = legend
current_tree_params$legendWidth = legendWidth
current_tree_params$legendPosition = legendPosition
current_tree_params$legendNcol = legendNcol
current_tree_params$tooltipDelay = tooltipDelay
current_tree_params$digits = digits
current_tree_params$fallenLeaves = fallenLeaves
current_tree_params$updateShape = updateShape
current_tree_params$export = export
current_tree_params$data = data
current_tree_params$tooltipColumns = tooltipColumns
tree <- visTree(object = res,
data = data,
tooltipColumns = tooltipColumns,
main = main,
submain = submain,
footer = footer,
shapeY = shapeY,
shapeVar = shapeVar,
colorVar = colorVar,
colorY = colorY,
rules = rules,
simplifyRules = simplifyRules,
legend = legend,
legendWidth = legendWidth,
legendNodesSize = legendNodesSize,
legendFontSize = legendFontSize,
legendPosition = legendPosition,
legendNcol = legendNcol,
edgesFontSize = edgesFontSize,
edgesFontAlign = edgesFontAlign,
nodesFontSize = nodesFontSize,
nodesPopSize = nodesPopSize,
minNodeSize = minNodeSize,
maxNodeSize = maxNodeSize,
tooltipDelay = tooltipDelay,
digits = digits,
direction = direction,
fallenLeaves = fallenLeaves,
updateShape = updateShape,
colorEdges = colorEdges,
highlightNearest = highlightNearest,
collapse = collapse,
height = paste0(height, "px"),
export = export) %>%
visEvents(type = "on", doubleClick = "networkOpenCluster")
# save color information
infoColors$colorVar <- tree$x$tree$colorVar
infoColors$colorY <- tree$x$tree$colorY
tree
})
} else {
NULL
}
})
output$is_tree <- shiny::reactive({
!is.null(treeBuild())
})
shiny::outputOptions(output, "is_tree", suspendWhenHidden = FALSE)
# the tree
output$tree <- visNetwork::renderVisNetwork({
treeBuild()
})
# Give names of variables
infoRpartNodes <- shiny::reactive({
res <- rpart_tree()
if(!is.null(res)){
nodes_var <- as.character(res$frame$var)
nodes_var_x <- nodes_var[nodes_var != "<leaf>"]
sortLabels <- unique(nodes_var_x)
if(!is.null(attributes(res)$ylevels)){
infoClass <- attributes(res)$ylevels
nlevelsClass <- length(infoClass)
probaClass <- res$frame[,"yval2"]
effectif <- data.frame(probaClass[,2:(nlevelsClass+1), drop = F])
probs <- data.frame(probaClass[,(nlevelsClass+2):(ncol(probaClass)-1), drop = F])
} else {
infoClass <- NULL
probs <- NULL
}
list(nodes_var = nodes_var, nodes_var_x = nodes_var_x, sortLabels = sortLabels,
infoClass = infoClass, probs = probs)
}
})
# Get color
updateColorVar <- shiny::reactive({
newColorVar <- infoColors$colorVar
if(!is.null(newColorVar)){
input_name <- gsub(" ", "", paste0(newColorVar$variable, "var"))
newColorVar$color <- as.character(newColorVar$color)
if(!is.null(input[[input_name[1]]])){
colorVect <- sapply(input_name, function(X){
tmp <- input[[X]]
ifelse(is.null(tmp), "", tmp)
})
newColorVar$color[colorVect != ""] <- colorVect[colorVect != ""]
}
newColorVar
} else {
NULL
}
})
# Color for Y
updateColorY <- shiny::reactive({
colorY <- infoColors$colorY$colorY
if(is.data.frame(colorY)){
dest <- paste0(gsub(" ", "", paste0(colorY$modality, "Y")))
if(!is.null(input[[dest[1]]])){
colorVect <- sapply(dest, function(X)input[[X]])
colorY$color <- colorVect
}
}else{
if(!is.null(input$minY)){
colorY[1] <- input$minY
colorY[2] <- input$maxY
}
}
colorY
})
output$colornodes <- shiny::renderUI({
if(!input$usecolornodes){
return(NULL)
}else{
corNodes <- updateColorVar()
if(nrow(corNodes) > 0){
res <- apply(corNodes, 1, function(x){
as.character(shiny::column(6,colourpicker::colourInput(ns(gsub(" ", "", paste0(x[1],"var"))), paste0(x[1]," :"), x[2])))
}) %>% paste0(collapse = "") %>% htmltools::HTML()
}
}
})
# UI for color
output$colorY <- shiny::renderUI({
if(!input$usecolorY){
return(NULL)
}else{
corY <- updateColorY()
clas <- attributes(rpart_tree())$ylevels
if(!is.null(clas)){
res <- apply(corY, 1, function(x){
as.character(shiny::column(6,colourpicker::colourInput(ns(gsub(" ", "", paste0(x[1],"Y"))), paste0(x[1]," :"), x[2])))
})%>%
paste0(collapse = "") %>%
HTML()
}else{
res <- list()
res[[1]] <- as.character(shiny::column(6,
colourpicker::colourInput(ns("minY"), "Min y : ", corY[1])))
res[[2]] <- as.character(shiny::column(6,
colourpicker::colourInput(ns("maxY"), "Max y : ", corY[2])))
res <- paste0(res, collapse = "") %>%
HTML()
}
}
res
})
# Update color VarNodes
shiny::observe({
m <- treeBuild()
if(!is.null(m)){
oldId <- m$x$nodes$id
colorIn <- m$x$nodes$color
legOldId <- m$x$legend$nodes$id
legColorIn <- m$x$legend$nodes$color
outColor <- unlist(sapply(m$x$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1],"var"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1],"var"))]]
}
}))
legOutColor <- unlist(sapply(m$x$legend$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1], "var"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1], "var"))]]
}
}))
newColor <- data.frame(
id = oldId[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)],
color = outColor[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)]
)
legNewColor <- data.frame(
id = legOldId[legOutColor != "NoChange" & ifelse(legOutColor == legColorIn, FALSE, TRUE)],
color = legOutColor[legOutColor != "NoChange" & ifelse(legOutColor == legColorIn, FALSE, TRUE)]
)
clas <- attributes(shiny::isolate(rpart_tree()))$ylevels
if(!is.null(input$minY) & is.null(clas)){
coloramp <- .creatColorRampY(c(input$minY, input$maxY))
if(nrow(m$x$nodes) > 1){
meanV <- (m$x$nodes$labelClust-min(m$x$nodes$labelClust))/(max(m$x$nodes$labelClust-min(m$x$nodes$labelClust)))
} else {
meanV <- 1
}
colorTerm <- grDevices::rgb(coloramp(meanV), maxColorValue=255)
endf <- data.frame(id = m$x$nodes$id, colorClust = colorTerm, color = "")
endf$color <- as.character(endf$color)
endf$color[m$x$nodes$Leaf == 1] <- as.character(colorTerm[m$x$nodes$Leaf == 1])
endf$color[m$x$nodes$Leaf == 0] <- as.character(m$x$nodes$color[m$x$nodes$Leaf == 0])
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(endf)
}
# if(!is.null(input[[gsub(" ", "", paste0(m$x$nodes[1,]$label, "Y"))]])){
oldId <- m$x$nodes$id
legId <- m$x$legend$nodes$id
colorIn <- m$x$nodes$color
colorInLeg <- as.character(m$x$legend$nodes$color)
outColor <- unlist(sapply(m$x$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1],"Y"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1],"Y"))]]
}
}))
outColorLeg <- unlist(sapply(m$x$legend$nodes$label, function(x){
if(is.null(input[[gsub(" ", "", paste0(x[1],"Y"))]])){
"NoChange"
}else{
input[[gsub(" ", "", paste0(x[1],"Y"))]]
}
}))
newColorGraph <- data.frame(
id = oldId[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)],
color = outColor[outColor != "NoChange" & ifelse(outColor == colorIn, FALSE, TRUE)]
)
newColorLegend <- data.frame(
id = legId[outColorLeg != "NoChange" & ifelse(outColorLeg == colorInLeg, FALSE, TRUE)],
color = outColorLeg[outColorLeg != "NoChange" & ifelse(outColorLeg == colorInLeg, FALSE, TRUE)]
)
# }
if(exists("newColor") & exists("newColorGraph")){
Gcol <- rbind(newColorGraph, newColor)
}else{
if(exists("newColor")){
Gcol <- newColor
}else{
if(exists("newColorGraph")){
Gcol <- newColorGraph
}
}
}
if(exists("legNewColor") & exists("newColorLegend")){
Lcol <- rbind(newColorLegend, legNewColor)
}else{
if(exists("legNewColor")){
Lcol <- legNewColor
}else{
if(exists("newColorLegend")){
Lcol <- newColorLegend
}
}
}
if(exists("Gcol")){
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(Gcol) %>%
visUpdateNodes(Lcol, legend = TRUE)
}
}
})
# Update direction
shiny::observeEvent({!is.null(input$direction)}, {
# print("update direction")
visNetworkProxy(ns("tree")) %>%
visHierarchicalLayout(direction = input$direction)
}, ignoreNULL = TRUE, ignoreInit = TRUE)
# Update node size
shiny::observeEvent({
!is.null(input$minNodeSize) & !is.null(input$maxNodeSize) & input$nodesPopSize
}, {
# print("update nodes size")
minNodeSize <- input$minNodeSize
maxNodeSize <- input$maxNodeSize
m <- shiny::isolate(treeBuild())
if(input$nodesPopSize & !is.null(m)){
newNodes <- data.frame(id = m$x$nodes$id, scaling.min = minNodeSize, scaling.max = maxNodeSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(newNodes)
}
}, ignoreInit = TRUE)
# Update node size
shiny::observeEvent({!is.null(input$nodesSize) & input$nodesPopSize == FALSE}, {
nodesSize <- input$nodesSize
m <- shiny::isolate(treeBuild())
if(!input$nodesPopSize & !is.null(m)){
newNodes <- data.frame(id = m$x$nodes$id, scaling.min = nodesSize, scaling.max = nodesSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(newNodes)
}
}, ignoreInit = TRUE)
# Update legend node size
shiny::observeEvent(input$legendNodesSize, {
legendNodesSize <- input$legendNodesSize
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$legend)){
change_legend_nodes <- data.frame(id = m$x$legend$nodes$id, size = legendNodesSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_legend_nodes, legend = TRUE)
}
}, ignoreInit = TRUE)
# Update legend font size
shiny::observeEvent(input$legendFontSize, {
legendFontSize <- input$legendFontSize
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$legend)){
change_legend_nodes <- data.frame(id = m$x$legend$nodes$id, font.size = legendFontSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_legend_nodes, legend = TRUE)
}
}, ignoreInit = TRUE)
# Update edges color
shiny::observeEvent(input$colorEdges, {
colorEdges <- input$colorEdges
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$edges)){
idEdges <- m$x$edges$id
newEdges <- data.frame(id = m$x$edges$id, color = colorEdges)
visNetworkProxy(ns("tree")) %>%
visUpdateEdges(newEdges)
}
}, ignoreInit = TRUE)
# Update edges font size
shiny::observeEvent(input$edgesFontSize, {
edgesFontSize <- input$edgesFontSize
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$edges)){
idEdges <- m$x$edges$id
newEdges <- data.frame(id = m$x$edges$id, font.size = edgesFontSize)
visNetworkProxy(ns("tree")) %>%
visUpdateEdges(newEdges)
}
}, ignoreInit = TRUE)
# Update edges font align
shiny::observeEvent(input$edgesFontAlign, {
edgesFontAlign <- input$edgesFontAlign
m <- shiny::isolate(treeBuild())
if(!is.null(m$x$edges)){
idEdges <- m$x$edges$id
newEdges <- data.frame(id = m$x$edges$id, font.align = edgesFontAlign)
visNetworkProxy(ns("tree")) %>%
visUpdateEdges(newEdges)
}
}, ignoreInit = TRUE)
# Update nodes font size
shiny::observeEvent(input$nodesFontSize, {
nodesFontSize <- input$nodesFontSize
m <- shiny::isolate(treeBuild())
if(!is.null(m)){
newNodes <- data.frame(id = m$x$nodes$id, font.size = nodesFontSize)
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(newNodes)
}
}, ignoreInit = TRUE)
# reactive for title
build_main <- shiny::reactive({
text <- input$main
style <- paste0("font-family:Georgia, Times New Roman, Times, serif;font-weight:bold;font-size:",
input$mainsize,"px;text-align:center;color:", input$colourMain, ";")
list(text = text, style = style)
})
# Update title
shiny::observeEvent({!is.null(input$main) & !is.null(input$mainsize) & !is.null(input$colourMain)}, {
# print("update main")
visNetworkProxy(ns("tree")) %>%
visSetTitle(main = build_main())
}, ignoreInit = TRUE)
build_submain <- shiny::reactive({
text <- input$submain
style <- paste0("font-family:Georgia, Times New Roman, Times, serif;font-size:",
input$Submainsize,"px;text-align:center;color:", input$colourSubMain, ";")
list(text = text, style = style)
})
shiny::observe({
visNetworkProxy(ns("tree")) %>%
visSetTitle(submain = build_submain())
})
build_footer <- shiny::reactive({
text <- input$footer
style <- paste0("font-family:Georgia, Times New Roman, Times, serif;font-size:",
input$Footermainsize,"px;text-align:center;color:", input$colourFooterMain, ";")
list(text = text, style = style)
})
shiny::observe({
visNetworkProxy(ns("tree")) %>%
visSetTitle(footer = build_footer())
})
# Update shape Ynodes
shiny::observeEvent({!is.null(input$shapeX) & !is.null(input$shapeY)},{
shapeX <- input$shapeX
shapeY <- input$shapeY
m <- shiny::isolate(treeBuild())
if(!is.null(m)){
# nodes
change_nodes <- data.frame(id = m$x$nodes$id, shape = ifelse(m$x$nodes$Leaf == 0, shapeX, shapeY))
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_nodes) %>%
.visUpdateTree(shapeY = shapeY)
# legend
change_legend_nodes <- data.frame(id = m$x$legend$nodes$id, shape = ifelse(m$x$legend$nodes$Leaf == 0, shapeX, shapeY))
visNetworkProxy(ns("tree")) %>%
visUpdateNodes(change_legend_nodes, legend = TRUE)
}
}, ignoreInit = TRUE)
# Update highlightNearest
update_highlightNearest <- shiny::reactive({
list(enabled = input$highlightNearest, degree = list(from = 50000, to = 0),
hover = input$highlightHover, algorithm = "hierarchical")
})
shiny::observeEvent({!is.null(input$highlightNearest) & !is.null(input$highlightHover)}, {
visNetworkProxy(ns("tree")) %>%
visOptions(highlightNearest = list(enabled = input$highlightNearest, degree = list(from = 50000, to = 0),
hover = input$highlightHover, algorithm = "hierarchical"))
}, ignoreInit = TRUE)
# Update collapse
update_collapse <- shiny::reactive({
list(enabled = input$collapse, fit = TRUE, resetHighlight = TRUE,
clusterOptions = list(fixed = TRUE, physics= FALSE))
})
shiny::observeEvent({!is.null(input$collapse)}, {
visNetworkProxy(ns("tree")) %>%
visOptions(collapse = list(enabled = input$collapse, fit = TRUE, resetHighlight = TRUE,
clusterOptions = list(fixed = TRUE, physics= FALSE)))
}, ignoreInit = TRUE)
# Update height
output$treeUI <- shiny::renderUI({
res <- rpart_tree()
shiny::isolate({
height <- get_height()
if("runTree" %in% names(input)){
if(input$runTree > 0){
height <- ifelse(is.null(input$height), height, input$height)
}
}
visNetworkOutput(ns("tree"), height = paste0(height, "px"))
})
})
build_export_tree <- shiny::reactive({
res <- rpart_tree()
# legend <- ifelse(is.null(input$legend), get_legend(), input$legend)
# rules <- ifelse(is.null(input$rules), get_rules(), input$rules)
# tooltipDelay <- ifelse(is.null(input$tooltipDelay), get_tooltipDelay(), input$tooltipDelay)
# updateShape <- ifelse(is.null(input$updateShape), get_updateShape(), input$updateShape)
# fallenLeaves <- ifelse(is.null(input$fallenLeaves), get_fallenLeaves(), input$fallenLeaves)
# digits <- ifelse(is.null(input$digits), get_digits(), input$digits)
nodesPopSize <- ifelse(is.null(input$nodesPopSize), get_nodesPopSize(), input$nodesPopSize)
# export <- ifelse(is.null(input$export), get_export(), input$export)
# simplifyRules <- ifelse(is.null(input$simpRules), get_simplifyRules(), input$simpRules)
# legendWidth <- ifelse(is.null(input$legendWidth), get_legendWidth(), input$legendWidth)
# legendNcol <- ifelse(is.null(input$legendNcol), get_legendNcol(), input$legendNcol)
legendNodesSize <- ifelse(is.null(input$legendNodesSize), get_legendNodesSize(), input$legendNodesSize)
legendFontSize <- ifelse(is.null(input$legendFontSize), get_legendFontSize(), input$legendFontSize)
# legendPosition <- ifelse(is.null(input$legendPosition), get_legendPosition(), input$legendPosition)
minNodeSize <- ifelse(is.null(input$minNodeSize), get_minNodeSize(), input$minNodeSize)
maxNodeSize <- ifelse(is.null(input$maxNodeSize), get_maxNodeSize(), input$maxNodeSize)
direction <- ifelse(is.null(input$direction), get_direction(), input$direction)
shapeY <- ifelse(is.null(input$shapeY), get_shapeY(), input$shapeY)
shapeVar <- ifelse(is.null(input$shapeX), get_shapeVar(), input$shapeX)
edgesFontSize <- ifelse(is.null(input$edgesFontSize), get_edgesFontSize(), input$edgesFontSize)
edgesFontAlign <- ifelse(is.null(input$edgesFontAlign), get_edgesFontAlign(), input$edgesFontAlign)
nodesFontSize <- ifelse(is.null(input$nodesFontSize), get_nodesFontSize(), input$nodesFontSize)
colorEdges <- ifelse(is.null(input$colorEdges), get_colorEdges(), input$colorEdges)
colorVar <- updateColorVar()
colorY <- updateColorY()
rules <- current_tree_params$rules
simplifyRules <- current_tree_params$simplifyRules
legend <- current_tree_params$legend
legendWidth <- current_tree_params$legendWidth
legendPosition <- current_tree_params$legendPosition
legendNcol <- current_tree_params$legendNcol
tooltipDelay <- current_tree_params$tooltipDelay
digits <- current_tree_params$digits
fallenLeaves <- current_tree_params$fallenLeaves
updateShape <- current_tree_params$updateShape
export <- current_tree_params$export
data <- current_tree_params$data
tooltipColumns <- current_tree_params$tooltipColumns
out <- visTree(object = res,
data = data,
tooltipColumns = tooltipColumns,
main = build_main(),
submain = build_submain(),
footer = build_footer(),
shapeY = shapeY,
shapeVar = shapeVar,
colorVar = colorVar,
colorY = colorY,
rules = rules,
simplifyRules = simplifyRules,
legend = legend,
legendWidth = legendWidth,
legendNodesSize = legendNodesSize,
legendFontSize = legendFontSize,
legendPosition = legendPosition,
legendNcol = legendNcol,
edgesFontSize = edgesFontSize,
edgesFontAlign = edgesFontAlign,
nodesFontSize = nodesFontSize,
nodesPopSize = nodesPopSize,
minNodeSize = minNodeSize,
maxNodeSize = maxNodeSize,
tooltipDelay = tooltipDelay,
digits = digits,
direction = direction,
fallenLeaves = fallenLeaves,
updateShape = updateShape,
colorEdges = colorEdges,
highlightNearest = update_highlightNearest(),
collapse = update_collapse(),
height = paste0(input$export_height, "px"),
export = export)
})
# complexity update
cp_parameters <- shiny::reactiveValues(min = 0, max = 0.2, step = 0.001)
shiny::observeEvent(input$set_cp, {
shiny::showModal(shiny::modalDialog(
title = "Complexity parameters",
shiny::numericInput(ns("cp_min"), "Slider minimum :", shiny::isolate(cp_parameters$min), step = 0.1),
shiny::numericInput(ns("cp_max"), "Slider maximum :", shiny::isolate(cp_parameters$max), step = 0.1),
shiny::numericInput(ns("cp_step"), "Slider step :", shiny::isolate(cp_parameters$step), step = 0.001),
shiny::div(shiny::actionButton(ns("update_cp"), "Update complexity slider"), align = "center"),
easyClose = TRUE,
footer = NULL
))
})
shiny::observeEvent(input$update_cp, {
cp_parameters$min <- input$cp_min
cp_parameters$max <- input$cp_max
cp_parameters$step <- input$cp_step
shiny::updateSliderInput(session, "complexity", min = input$cp_min, max = input$cp_max, step = input$cp_step)
shiny::removeModal()
})
# download tree
output$downloadNetwork <- shiny::downloadHandler(
filename = function() {
paste('tree-', Sys.Date(), '.html', sep='')
},
content = function(con) {
out <- build_export_tree()
background <- input$export_background
#Transform color
if (grepl("^#", background, perl = TRUE)) {
bgcol <- col2rgb(background, alpha = TRUE)
background <- sprintf("rgba(%d,%d,%d,%f)", bgcol[1,1], bgcol[2,1], bgcol[3,1], bgcol[4,1]/255)
}
out %>% visSave(con, TRUE, background)
}
)
# quit and get back network
shiny::observe({
if(!is.null(input$quit_btn)){
if(input$quit_btn > 0){
shiny::stopApp(build_export_tree())
}
}
})
}
#' @rdname visNetwork-treeModule
#'
#' @export
visTreeModuleUI <- function(id, rpartParams = TRUE, visTreeParams = TRUE, quitButton = FALSE) {
ns <- shiny::NS(id)
.ctrlPckTree()
if(rpartParams){
visTreeParams <- TRUE
}
selectedTabs <- ifelse(rpartParams, "rpart", "visTree options")
shiny::fluidPage(
if(visTreeParams | rpartParams){
shiny::tabsetPanel(
id = ns('boxparam'),
selected = selectedTabs ,
if(rpartParams){
shiny::tabPanel("rpart",
#Params for rparts
shiny::fluidRow(
shiny::div(align = "center",
shiny::column(2,
shiny::selectInput(ns("y"), "Y :",NULL)
),
shiny::column(5,
shiny::selectInput(ns("x"), "X :", NULL, multiple = TRUE, selected = NULL, width = "100%")
),
shiny::column(2,
shiny::numericInput(ns("minsplit"), "Minsplit : ", value = 20, min = 2)
),
shiny::column(2,
shiny::sliderInput(ns("complexity"), "Complexity (cp) :",
min = 0, max = 0.2, value = 0.005, step = 0.001)
),
shiny::column(1,
shiny::br(), shiny::br(), shiny::actionButton(ns("set_cp"), "Set cp slider")
)
)
)
)
}else{shiny::div(style = "visibility: hidden")},
if(visTreeParams){
shiny::tabPanel("visTree options",
#Params graph
shiny::fluidRow(
shiny::column(1,
shiny::uiOutput(ns("input_height"))
),
shiny::column(1,
shiny::uiOutput(ns("input_digits"))
),
shiny::column(1,
shiny::uiOutput(ns("input_tooltipDelay"))
),
shiny::column(2,
shiny::br(), shiny::uiOutput(ns("input_fallenLeaves"))
),
shiny::column(2,
shiny::br(),
shiny::uiOutput(ns("input_updateShape"))
),
shiny::column(2,
shiny::br(),
shiny::uiOutput(ns("input_rules"))
),
shiny::conditionalPanel(paste0("input['",ns("rules"),"'] == true"),
shiny::column(2,
shiny::br(),
shiny::checkboxInput(ns("simpRules"),"Simplify rules", value = TRUE))
),
shiny::column(1,
shiny::br(),
shiny::uiOutput(ns("input_export"))
)
),
shiny::conditionalPanel(paste0("output['",ns("is_data_frame"),"'] === true"),
shiny::fluidRow(
shiny::column(12,
shiny::selectInput(ns("tooltipColumns"), "tooltipColumns :", NULL, multiple = TRUE, selected = NULL, width = "100%")
)
)
)
)
}else{shiny::div(style = "visibility: hidden")},
if(visTreeParams){
shiny::tabPanel("Legend",
shiny::fluidRow(
shiny::column(2, offset = 1,
shiny::br(),
shiny::uiOutput(ns("input_legend"))
),
# shiny::conditionalPanel(paste0("input['",ns("legend"),"'] == true"),
shiny::column(2,
shiny::uiOutput(ns("input_legendWidth"))
),
shiny::column(2,
shiny::uiOutput(ns("input_legendNcol"))
),
shiny::column(2,
shiny::uiOutput(ns("input_legendPosition"))
)
)
)
}else{shiny::div(style = "visibility: hidden")}
)
},
if(visTreeParams | rpartParams){
if(quitButton){
shiny::fluidRow(
shiny::column(width = 3, offset = 3,
shiny::div(
shiny::actionButton(ns("runTree"), "Run / update tree", class = "btnruntree"), align = "center"
)
),
shiny::column(width = 3,
shiny::div(
shiny::actionButton(ns("quit_btn"), "Quit and get back network in R"), align = "center"
)
)
)
} else {
shiny::div(
shiny::actionButton(ns("runTree"), "Run / update tree", class = "btnruntree"), align = "center"
)
}
}else{shiny::div(style = "visibility: hidden")},
shiny::hr(),
shiny::conditionalPanel(condition = paste0("output['", ns("is_tree"), "'] === true"),
shiny::fluidRow(
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("share-alt"),status = "danger",width = 500, circle = T,
label = "Update nodes properties", tooltip = TRUE,
shiny::fluidRow(
shiny::column(4,
shiny::uiOutput(ns("input_shapeY")),
shiny::uiOutput(ns("input_shapeX"))
),
shiny::column(4,
shiny::uiOutput(ns("input_nodesSize")),
shiny::uiOutput(ns("input_legendNodesSize"))
),
shiny::column(4,
shiny::uiOutput(ns("input_nodesFontSize")),
shiny::uiOutput(ns("input_legendFontSize"))
)
),
shiny::column(12,
shiny::br(),
shinyWidgets::materialSwitch(ns("nodesPopSize"),
"Nodes size use population", status = "info"),
shiny::conditionalPanel(paste0("input['", ns("nodesPopSize"),"'] == true"),
shiny::column(6,
shiny::uiOutput(ns("input_minNodeSize"))
),
shiny::column(6,
shiny::uiOutput(ns("input_maxNodeSize"))
)
),
shiny::br(),
shinyWidgets::materialSwitch(ns("usecolornodes"),"Color nodes", status = "info"),
shiny::fluidRow(
shiny::uiOutput(ns("colornodes"))
),
shiny::br(),
shinyWidgets::materialSwitch(ns("usecolorY"),"Color Y", status = "info"),
shiny::uiOutput(ns("colorY"))
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("exchange"), status = "warning", width = 300, circle = T,
label = "Update edges properties", tooltip = TRUE,
shiny::fluidRow(
shiny::column(12,
shiny::uiOutput(ns("input_colorEdges")),
shiny::uiOutput(ns("input_edgesFontSize")),
shiny::uiOutput(ns("input_edgesFontAlign"))
)
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("header"), status = "info", width = 400, circle = T,
label = "Set title, subtitle and footer", tooltip = TRUE,
shiny::fluidRow(
shiny::column(12,
shiny::uiOutput(ns("input_main")),
shiny::uiOutput(ns("input_submain")),
shiny::uiOutput(ns("input_footer"))
)
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("gear"),status = "success",width = 300,circle = T,
label = "Interaction and layout", tooltip = TRUE,
shiny:: fluidRow(
shiny::column(12,
shiny::uiOutput(ns("input_highlight")),
shiny::uiOutput(ns("input_collapse")),
shiny::uiOutput(ns("input_direction"))
)
)
)
),
shiny::column(1,
shinyWidgets::dropdownButton(icon = shiny::icon("download"),status = "default", width = 300, circle = T,
label = "Download the network as html", tooltip = TRUE,
shiny:: fluidRow(
shiny::column(12,
shiny::sliderInput(ns("export_height"), "Height:",
min = 200, max = 1400, value = 900),
# shinyWidgets::materialSwitch(ns("export_self"),
# "selfcontained ?", status = "info", value = TRUE),
colourpicker::colourInput(ns("export_background"),
"Background color :", value = "white"),
shiny::downloadLink(ns('downloadNetwork'), 'Download Tree as html')
)
)
)
)
),
shiny::uiOutput(ns("treeUI"))
)
)
}
.ctrlPckTree <- function(){
miss_packages <- c()
if(!requireNamespace("shiny", quietly = TRUE)){
miss_packages <- c(miss_packages, "'shiny (>1.0.0)'")
}
if(!requireNamespace("colourpicker", quietly = TRUE)){
miss_packages <- c(miss_packages, "'colourpicker'")
}
if(!requireNamespace("shinyWidgets", quietly = TRUE)){
miss_packages <- c(miss_packages, "'shinyWidgets'")
}
if(!requireNamespace("rpart", quietly = TRUE)){
miss_packages <- c(miss_packages, "'rpart'")
}
if(!requireNamespace("sparkline", quietly = TRUE)){
miss_packages <- c(miss_packages, "'sparkline'")
}
if(length(miss_packages) == 1){
stop(miss_packages," package is needed for this visTreeModule / visTreeEditor", call. = FALSE)
} else if(length(miss_packages) > 1){
stop(paste(miss_packages, collapse = ", ")," packages are needed for visTreeModule / visTreeEditor", call. = FALSE)
}
invisible(NULL)
}
Try the visNetwork package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.