NetworkVisual = R6Class(
"NetworkVisual",
inherit = ShinyModule,
public = list(
# attributes
id = "network",
# initializer
initialize = function(){
ns = NS(self$id)
},
# UI
ui = function(){
ns = NS(self$id)
tagList(
tags$div(
class = "col",
column(
width = 12,
box(
width = NULL,
status = "primary",
solidHeader = TRUE,
title = tags$span(icon("wrench"), "Partial Correlation Settings"),
collapsible = TRUE,
tags$div(
class = "col",
tags$h5(
class = "font-weight-bold",
"Partial correlation parameters"
)
),
tags$div(
class = "col-xs-6 col-md-3",
numericInput(
ns("lambda"), "lambda",
min = 0, max = 1, value = 0.625, step = 0.1
)
),
tags$div(
class = "col-xs-6 col-md-3",
numericInput(
ns("iter"), "iter",
min = 1, max = 100, value = 2, step = 1
)
),
tags$div(
class = "col-xs-6 col-md-3",
numericInput(
ns("coef"), "Coefficient cutoff",
min = 0, max = 1, step = 0.01, value = 0.3
)
),
tags$div(
class = "col-xs-6 col-md-3",
numericInput(
ns("occur"), "Minimal occurance",
min = 0, max = 100, step = 1, value = 1
)
),
tags$div(
class = "col",
actionButton(ns("submit"), "Submit", class="btn-primary")
),
tags$hr(),
tags$div(
class = "col",
tags$h5(
class = "font-weight-bold",
"Aesthetic parameters"
)
),
tags$div(
class = "col-xs-6 col-md-3",
uiOutput(ns("node-color-ui"))
),
tags$div(
class = "col-xs-6 col-md-3",
selectInput(
ns("layout"), "Layout",
choices = c(
"cose",
"cola",
"cola-edge-weighted",
"cose-bilkent"
)
)
),
tags$div(
class = "col-xs-6 col-md-3",
numericInput(
ns("edge-length-scale"), "Edge length scale",
min = 30, max = 1000, value = 60, step = 1
)
),
tags$div(
class = "col-xs-6 col-md-3 ",
numericInput(
ns("edge-width-scale"), "Edge width scale",
min = 1, max = 100, value = 20
)
),
tags$div(
class = "col-xs-6 col-md-3",
numericInput(
ns("node-size"), "Node size",
min = 1, max = 100, value = 20, step = 1
)
)
)
),
column(
width = 12,
box(
width = NULL,
title = tags$span(icon("wifi"), "Network"),
status = "primary",
solidHeader = TRUE,
tags$span(id="cy-tooltip", class="tooltip"),
shinyjqui::jqui_resizable(
tags$div(
class = "cy-container",
tags$div( id = "cy" )
)
)
)
)
)
)
},
# server
#' @props data, reactive that returns the data
server = function(input, output, session, props){
states = reactiveValues(
id = NULL
)
observe({
output$`node-color-ui` = renderUI({
choices = list("-- please select --" = "null")
for (item in colnames(feature_data(props$data()))){
choices[[item]] = item
}
selectInput(
session$ns("node-color"), "Node color",
choices = choices
)
})
})
observeEvent(input$submit, {
# Partical correlation
Data = apply(t(props$data()$conc_table), 2, scale)
spn = space.joint(Data, input$lambda, iter = input$iter)
spn_cor = spn$ParCor
colnames(spn_cor) = colnames(Data)
rownames(spn_cor) = colnames(Data)
for(i in seq_len(nrow(spn_cor))){
spn_cor[i,i] = 0
}
id = apply(spn_cor, 2, function(x) {sum(!between(x, -input$coef, input$coef)) > input$occur * 2})
if(sum(id) > 0){
states$id = id
mat = spn_cor[id, id]
mat[between(mat, -input$coef, input$coef)] = 0
# Node list
nodes = list(id = colnames(mat))
if(input$`node-color` != "null") {
color = props$data()$feature_data[id, input$`node-color`]
if(length(unique(color)) > 65 ){
showNotification("The node color variable has too many levels")
} else {
nodes$color = color
}
}
# edge list
edges = melt(mat) %>% filter(value != 0)
colnames(edges)[1:2] = c("source", "target")
edges$sign = ifelse(
edges$value > 0, "positive",
ifelse(edges$value < 0, "negative", "")
)
edges$value = abs(edges$value)
#edges$value = (edges$value - min(edges$value)) / (max(edges$value) - min(edges$value))
#edges$value = edges$value * input$`edge-width` + 1
edges$id = with(edges, glue("{source}-{target}"))
# params
params = list(
layout = input$layout,
"node-size" = input$`node-size`,
"edge-width-scale" = input$`edge-width-scale`,
"edge-length-scale" = input$`edge-length-scale`
)
session$sendCustomMessage("cyDataSubmited", list(
nodes = nodes,
edges = edges,
params = params
))
}
})
observeEvent(input$`node-color`, {
if(input$`node-color` != "null" & !is.null(states$id)){
session$sendCustomMessage("cyNodeColorUpdate", list(
color = props$data()$feature_data[states$id, input$`node-color`]
))
}
})
observeEvent(input$`edge-width-scale`, {
if(!is.null(states$id)){
session$sendCustomMessage("cyEdgeWidthUpdate",list(
"edge-width-scale" = input$`edge-width-scale`
))
}
})
observeEvent(input$`node-size`, {
if(!is.null(states$id)){
session$sendCustomMessage("cyNodeSizeUpdate", list(
"node-size" = input$`node-size`
))
}
})
observeEvent({
input$layout
input$`edge-length-scale`
}, {
if(!is.null(states$id)){
messageData = list(
"layout" = input$layout
)
if(input$layout == "cola-edge-weighted"){
messageData$`edge-length-scale` = input$`edge-length-scale`
}
session$sendCustomMessage("cyLayoutTypeUpdate", messageData)
}
})
},
call = function(input, output, sessiont, props){
callModule(self$server, self$id, props)
}
)
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.