R/SNAhelper.R
In schochastics/snahelper: 'RStudio' Addin for Network Analysis and Visualization
Defines functions
SNAhelperAddin
SNAhelperGadget
SNAhelper
Documented in
SNAhelper
SNAhelperAddin
SNAhelperGadget
#' SNAhelper
#'
#' \code{SNAhelper} is a RStudio-Addin that provides a graphical interface for network analysis and visualization.
#'
#' @details To run the addin, highlight an igraph-object in your current script and select \code{SNAhelper} from the Addins-menu within RStudio. After terminating the addin, a character string containing the code for visualization is inserted in your current script. Alternatively you can run it with SNAhelperGadget(graph) from the console.
#' @param graph An igraph object to visualize
#' @return \code{SNAhelper} returns a character vector with code.
#' @import miniUI
#' @import shiny
#' @import ggplot2
#' @import ggraph
#' @import rstudioapi
#' @import igraph
#' @importFrom colourpicker colourInput
#' @importFrom grDevices col2rgb
#' @importFrom grDevices colors
#' @name SNAhelper
NULL
SNAhelper <- function(text) {
if (!requireNamespace("graphlayouts", quietly = TRUE)) {
stop("graphlayouts package not found. Install it with install.packages('graphlayouts')", call. = FALSE)
}
if (any(ls(envir = .GlobalEnv) == text)) {
g <- get(text, envir = .GlobalEnv)
if (!igraph::is.igraph(g)) {
stop(paste0(text, " is not an igraph object"))
}
if (any(igraph::vertex_attr_names(g) == "x") & any(igraph::vertex_attr_names(g) == "y")) {
xy <- cbind(igraph::V(g)$x, igraph::V(g)$y)
} else {
xy <- graphlayouts::layout_with_stress(g)
}
rv <- reactiveValues(g = g, xy = xy)
} else {
stop(paste0("Couldn't find the graph ", text, "."))
}
if (any(igraph::is.multiple(g))) {
edge_geom <- "geom_edge_parallel0("
} else {
edge_geom <- "geom_edge_link0("
}
# ui ----
ui <- miniPage(
tags$script(jscodeWidth),
tags$script(jscodeHeight),
tags$style(type = "text/css", ".selectize-dropdown{ width: 200px !important; }"),
tags$style(type = "text/css", ".form-group.shiny-input-container{width:50%;}"),
gadgetTitleBar("SNA helper"),
miniTabstripPanel(
selected = "layout",
miniTabPanel("layout",
icon = icon("sliders-h"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Choose Layout")
),
fillRow(
height = line.height, width = "100%",
selectizeInput("graphLayout",
label = "Layout Algorithm",
choices = layouts.available,
selected = "graphlayouts::layout_with_stress", width = input.width
),
shiny::conditionalPanel(
"input.graphLayout=='graphlayouts::layout_with_focus'",
selectizeInput("focalNode",
label = "Choose Focal Node ID",
choices = 1:igraph::vcount(g),
width = input.width
)
),
shiny::conditionalPanel(
"input.graphLayout=='graphlayouts::layout_with_centrality'",
selectizeInput("centralLay",
label = "Choose Centrality",
choices = NULL,
width = input.width
)
)
),
fillRow(
height = line.height, width = "50%",
actionButton("do.layout", "Calculate Layout"),
actionButton("del.isolate", "Delete Isolates")
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Tweak Layout"),
checkboxInput("showLabs", label = "Show NodeIDs", value = FALSE)
),
fillRow(
height = line.height, width = "100%",
selectizeInput("nodeId",
label = "NodeID", choices = 1:vcount(g),
width = input.width
),
p("tweak node position by clicking on the desired location.")
)
),
plotOutput("Graph1", width = "80%", height = "55%", click = "tweakxy")
),
miniTabPanel("node attributes",
icon = icon("list-ol"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = line.height, width = "100%",
selectizeInput("centindex",
label = "Index",
choices = NULL,
width = input.width
),
selectizeInput("clusteralg",
label = "Clustering",
choices = c("Louvain" = "cluster_louvain(rv$g)"),
width = input.width
)
),
fillRow(
height = line.height, width = "100%",
actionButton("calcIndex", "Calculate Index"),
actionButton("calcClust", "Calculate Clustering")
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Node Attributes")
),
DT::dataTableOutput("attrManageN")
)
),
miniTabPanel("nodes",
icon = icon("circle"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Manual")
),
fillRow(
height = line.height, width = "100%",
colourInput("nodeColMan", label = "Colour", value = "gray32"),
numericInput("nodeSizeMan",
label = "Size",
min = 0, max = 20, step = 0.5, value = 5, width = input.width
),
colourInput("nodeBorderColMan", label = "Border Colour", value = "black"),
numericInput("nodeBorderSizeMan",
label = "Border Size",
min = 0, max = 2, step = 0.1, value = 0.3, width = input.width
)
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Attribute")
),
fillRow(
height = line.height, width = "100%",
selectizeInput("nodeColAttr",
label = "Colour (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("nodeColAttrD",
label = "Colour (Discrete)",
choices = NULL,
width = input.width
),
selectizeInput("nodeSizeAttr",
label = "Size (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("nodeLabelAttr",
label = "Node Label",
choices = NULL,
width = input.width
)
),
fillRow(
height = line.height, width = "100%",
shiny::conditionalPanel(
"input.nodeColAttr!='None'",
colourInput("nodeColAttrL", label = "Min Colour", value = "skyblue1"),
colourInput("nodeColAttrH", label = "Max Colour", value = "royalblue4")
),
shiny::conditionalPanel(
"input.nodeColAttrD!='None'",
selectizeInput("nodeColAttrP",
label = "Palette",
choices = c(
"Set1", "Set2", "Set3", "Pastel2", "Pastel1",
"Paired", "Dark2", "Accent"
),
width = input.width
)
),
shiny::conditionalPanel(
"input.nodeSizeAttr!='None'",
numericInput("nodeSizeAttrL",
label = "Min Size",
min = 0, max = 20, step = 0.5, value = 3, width = input.width
),
numericInput("nodeSizeAttrH",
label = "Max Size",
min = 0, max = 20, step = 0.5, value = 8, width = input.width
)
),
shiny::conditionalPanel(
"input.nodeLabelAttr!='None'",
colourInput("nodeLabelCol", label = "Colour", value = "black"),
# selectizeInput('nodeLabelCol',label = 'Colour',
# choices = NULL, width = input.width),
numericInput("nodeLabelSize",
label = "Size",
min = 0, max = 20, step = 0.5, value = 6, width = input.width
),
selectizeInput("nodeLabelFont",
label = "Font",
choices = fonts.available, width = input.width
),
shiny::checkboxInput("nodeLabelRepel", label = "Repel Labels?", value = FALSE)
)
)
),
plotOutput("Graph2", width = "80%", height = "55%")
),
miniTabPanel("edge attributes",
icon = icon("list-ol"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Edge Attributes")
),
DT::dataTableOutput("attrManageE")
)
),
miniTabPanel("edges",
icon = icon("minus"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Manual")
),
fillRow(
height = line.height, width = "75%",
colourInput("edgeColMan", label = "Colour", value = "gray66"),
numericInput("edgeSizeMan",
label = "Width",
min = 0, max = 10, step = 0.1, value = 0.8, width = input.width
),
numericInput("edgeAlphaMan",
label = "Alpha",
min = 0, max = 1, step = 0.01, value = 1.0, width = input.width
)
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Attribute")
),
fillRow(
height = line.height, width = "100%",
selectizeInput("edgeColAttr",
label = "Colour (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("edgeColAttrD",
label = "Colour (Discrete)",
choices = NULL,
width = input.width
),
selectizeInput("edgeSizeAttr",
label = "Width (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("edgeAlphaAttr",
label = "Alpha (Cont.)",
choices = NULL,
width = input.width
)
),
fillRow(
height = line.height, width = "100%",
shiny::conditionalPanel(
"input.edgeColAttr!='None'",
colourInput("edgeColAttrL", label = "Min Colour", value = "skyblue1"),
colourInput("edgeColAttrH", label = "Max Colour", value = "royalblue4")
),
shiny::conditionalPanel(
"input.edgeColAttrD!='None'",
selectizeInput("edgeColAttrP",
label = "Palette",
choices = c(
"Set1", "Set2", "Set3", "Pastel2", "Pastel1",
"Paired", "Dark2", "Accent"
),
width = input.width
)
),
shiny::conditionalPanel(
"input.edgeSizeAttr!='None'",
numericInput("edgeSizeAttrL",
label = "Min Width",
min = 0, max = 10, step = 0.1, value = 0.3, width = input.width
),
numericInput("edgeSizeAttrH",
label = "Max Width",
min = 0, max = 10, step = 0.1, value = 1.2, width = input.width
)
),
shiny::conditionalPanel(
"input.edgeAlphaAttr!='None'",
numericInput("edgeAlphaAttrL",
label = "Min Alpha",
min = 0, max = 1, step = 0.01, value = 0.1, width = input.width
),
numericInput("edgeAlphaAttrH",
label = "Max Alpha",
min = 0, max = 1, step = 0.01, value = 1, width = input.width
)
)
)
),
plotOutput("Graph3", width = "80%", height = "55%")
),
miniTabPanel("result",
icon = icon("bezier-curve"),
plotOutput("Graph4", width = "90%", height = "80%"),
miniContentPanel(
scrollable = TRUE,
fillRow(
height = line.height, width = "50%",
selectInput("legendPos",
label = "Show Legend:",
choices = c("none", "top", "bottom", "left", "right"),
width = input.width
)
),
downloadButton("downloadData", "Save PNG")
)
)
)
)
server <- function(input, output, session) {
#--------------------#
# constants ----
#--------------------#
vattr.to.aes <- igraph::vertex_attr_names(g)[!grepl("name", igraph::vertex_attr_names(g))]
if (length(vattr.to.aes) > 0) {
idC <- which(sapply(vattr.to.aes, function(x) is.numeric(igraph::get.vertex.attribute(g, x))))
vattrC.to.aes <- c("None", vattr.to.aes[idC])
idC <- which(sapply(vattr.to.aes, function(x) !is.numeric(igraph::get.vertex.attribute(g, x))))
vattrD.to.aes <- c("None", vattr.to.aes[idC])
} else {
vattrC.to.aes <- c("None")
vattrD.to.aes <- c("None")
}
eattr.to.aes <- igraph::edge_attr_names(g)
if (length(eattr.to.aes) > 0) {
idC <- which(sapply(eattr.to.aes, function(x) is.numeric(igraph::get.edge.attribute(g, x))))
eattrC.to.aes <- c("None", eattr.to.aes[idC])
idC <- which(sapply(eattr.to.aes, function(x) !is.numeric(igraph::get.edge.attribute(g, x))))
eattrD.to.aes <- c("None", eattr.to.aes[idC])
} else {
eattrC.to.aes <- c("None")
eattrD.to.aes <- c("None")
}
#--------------------#
# check graph properties
#--------------------#
if (is.directed(g) & !is.weighted(g)) {
cent_choice <- c(
"In-Degree" = "degree(rv$g,mode='in')",
"Out-Degree" = "degree(rv$g,mode='out')",
"Degree" = "degree(rv$g,mode='all')",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"PageRank" = "page_rank(rv$g)$vector"
)
} else if (!is.directed(g) & is.weighted(g)) {
cent_choice <- c(
"Degree" = "degree(rv$g)",
"Weighted Degree" = "graph.strength(rv$g)",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"Eigenvector" = "eigen_centrality(rv$g)$vector"
)
} else if (!is.directed(g) & !is.weighted(g)) {
cent_choice <- c(
"Degree" = "degree(rv$g)",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"Eigenvector" = "eigen_centrality(rv$g)$vector"
)
} else {
cent_choice <- c(
"In-Degree" = "degree(rv$g,mode='in')",
"Out-Degree" = "degree(rv$g,mode='out')",
"Degree" = "degree(rv$g,mode='all')",
"Weighted In-Degree" = "graph.strength(rv$g,mode='in')",
"Weighted Out-Degree" = "graph.strength(rv$g,mode='out')",
"Weighted Degree" = "graph.strength(rv$g,mode='all')",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"PageRank" = "page_rank(rv$g)$vector"
)
}
#--------------------#
# initialize selectors ----
#--------------------#
updateSelectizeInput(
session = session, inputId = "centralLay",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeColAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeLabelAttr",
choices = c("None", igraph::vertex_attr_names(g)),
selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeColAttrD",
choices = vattrD.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeSizeAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeColAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeColAttrD",
choices = eattrD.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeSizeAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeAlphaAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "centindex",
choices = cent_choice, selected = cent_choice[1], server = TRUE,
options = list(create = TRUE)
)
#--------------------#
# be sure either discrete or continuos is selected ----
#--------------------#
shiny::observe({
if (input$nodeColAttr != "None") {
shiny::updateSelectInput(session, "nodeColAttrD", selected = "None")
}
})
shiny::observe({
if (input$nodeColAttrD != "None") {
shiny::updateSelectInput(session, "nodeColAttr", selected = "None")
}
})
shiny::observe({
if (input$edgeColAttr != "None") {
shiny::updateSelectInput(session, "edgeColAttrD", selected = "None")
}
})
shiny::observe({
if (input$edgeColAttrD != "None") {
shiny::updateSelectInput(session, "edgeColAttr", selected = "None")
}
})
#--------------------#
# calculate initial layout ----
#--------------------#
shiny::observeEvent(input$del.isolate, {
idx <- which(degree(rv$g) == 0)
if (length(idx) >= 1) {
g <- igraph::delete.vertices(rv$g, idx)
xy <- rv$xy[-idx, ]
rv$g <- g
rv$xy <- xy
gg_reactive()
}
})
shiny::observeEvent(input$do.layout, {
if (input$graphLayout == "graphlayouts::layout_as_backbone") {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g)")))
rv$xy <- xy$xy
bb <- rep(0, ecount(rv$g))
bb[xy$backbone] <- 1
g <- igraph::set.edge.attribute(graph = rv$g, name = "backbone", value = bb)
rv$g <- g
eattr.to.aes <- igraph::edge_attr_names(g)
if (length(eattr.to.aes) > 0) {
idC <- which(sapply(eattr.to.aes, function(x) is.numeric(igraph::get.edge.attribute(g, x))))
eattrC.to.aes <- c("None", eattr.to.aes[idC])
} else {
eattrC.to.aes <- c("None")
}
updateSelectizeInput(
session = session, inputId = "edgeColAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeSizeAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeAlphaAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
} else if (input$graphLayout == "graphlayouts::layout_with_focus") {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g, v = ", input$focalNode, ")$xy")))
rv$xy <- xy
} else if (input$graphLayout == "graphlayouts::layout_with_centrality") {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g, cent = get.vertex.attribute(rv$g,\"", input$centralLay, "\"))")))
rv$xy <- xy
} else {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g)")))
rv$xy <- xy
}
gg_reactive()
})
#--------------------#
# tweak layout ----
#--------------------#
shiny::observeEvent(input$tweakxy, {
indX <- as.numeric(input$nodeId)
rv$xy[indX, 1] <- input$tweakxy$x
rv$xy[indX, 2] <- input$tweakxy$y
gg_reactive()
})
#--------------------#
# calculate centrality/clustering ----
#--------------------#
shiny::observeEvent(input$calcIndex, {
attr_name <- gsub("\\(rv.*", "", input$centindex)
if (igraph::is_directed(g) & attr_name == "degree") {
opt <- gsub("')", "", gsub(".*mode='", "", input$centindex))
attr_name <- paste0(opt, "_", attr_name)
}
if (igraph::is_directed(g) & attr_name == "graph.strength") {
opt <- gsub("')", "", gsub(".*mode='", "", input$centindex))
attr_name <- paste0(opt, "_", attr_name)
}
if (!attr_name %in% igraph::vertex_attr_names(rv$g)) {
ind <- eval(parse(text = input$centindex))
g <- igraph::set.vertex.attribute(graph = rv$g, name = attr_name, value = ind)
rv$g <- g
vattr.to.aes <- igraph::vertex_attr_names(rv$g)[!grepl("name", igraph::vertex_attr_names(rv$g))]
idC <- which(sapply(vattr.to.aes, function(x) is.numeric(igraph::get.vertex.attribute(rv$g, x))))
vattrC.to.aes <- c("None", vattr.to.aes[idC])
updateSelectizeInput(
session = session, inputId = "centralLay",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeColAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeSizeAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeLabelAttr",
choices = c("None", igraph::vertex_attr_names(g)),
selected = "None", server = TRUE,
options = list(create = TRUE)
)
}
})
shiny::observeEvent(input$calcClust, {
attr_name <- gsub("\\(rv.*", "", input$clusteralg)
if (!attr_name %in% igraph::vertex_attr_names(rv$g)) {
ind <- eval(parse(text = input$clusteralg))
ind <- as.character((igraph::membership(ind)))
g <- igraph::set.vertex.attribute(graph = rv$g, name = attr_name, value = ind)
rv$g <- g
vattr.to.aes <- igraph::vertex_attr_names(rv$g)[!grepl("name", igraph::vertex_attr_names(rv$g))]
idC <- which(sapply(vattr.to.aes, function(x) !is.numeric(igraph::get.vertex.attribute(rv$g, x))))
vattrD.to.aes <- c("None", vattr.to.aes[idC])
updateSelectizeInput(
session = session, inputId = "nodeColAttrD",
choices = vattrD.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeLabelAttr",
choices = c("None", igraph::vertex_attr_names(g)),
selected = "None", server = TRUE,
options = list(create = TRUE)
)
}
})
#------------------------------------------------------------#
#--------------------#
# main plotting function ----
#--------------------#
gg_reactive <- reactive({
validate(
need(is.validColour(input$nodeColMan), ""),
need(is.validColour(input$edgeColMan), ""),
need(is.validColour(input$nodeBorderColMan), ""),
# need(is.validColour(input$nodeColAttr), ''),
# need(is.validColour(input$nodeColAttrL), ''),
# need(is.validColour(input$nodeColAttrH), ''),
# need(is.validColour(input$edgeColAttr), ''),
# need(is.validColour(input$edgeColAttrL), ''),
# need(is.validColour(input$edgeColAttrH), ''),
need(is.validColour(input$edgeColMan), "")
)
#--------------------#
# layout ----
#--------------------#
# xy <- get_layout()
code_layout <- "ggraph(rv$g,layout = \"manual\", x = rv$xy[,1], y = rv$xy[,2])"
#--------------------#
# nodes ----
#--------------------#
if (input$nodeColAttr == "None" & input$nodeColAttrD == "None" & input$nodeSizeAttr == "None") {
code_nodes <- paste0(
"geom_node_point(",
"fill = \"", input$nodeColMan, "\"",
",colour = \"", input$nodeBorderColMan, "\"",
",size = ", input$nodeSizeMan,
",stroke = ", input$nodeBorderSizeMan,
",shape = 21",
")"
)
} else if (input$nodeColAttr != "None" & input$nodeSizeAttr == "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttr, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nsize = ", input$nodeSizeMan,
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0(
"scale_fill_gradient(low = \"", input$nodeColAttrL, "\",",
"high = \"", input$nodeColAttrH, "\")"
)
code_nodes <- paste(code_nodes, nodes_scale_col, sep = " + ")
} else if (input$nodeColAttrD != "None" & input$nodeSizeAttr == "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttrD, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nsize = ", input$nodeSizeMan,
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0("scale_fill_brewer(palette = \"", input$nodeColAttrP, "\", na.value = \"gray53\")")
code_nodes <- paste(code_nodes, nodes_scale_col, sep = " + ")
} else if (input$nodeColAttr == "None" & input$nodeColAttrD == "None" & input$nodeSizeAttr != "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(size = ", input$nodeSizeAttr, ")",
",\nfill = \"", input$nodeColMan, "\"",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_size <- paste0("scale_size(range = c(", input$nodeSizeAttrL, ",", input$nodeSizeAttrH, "))")
code_nodes <- paste(code_nodes, nodes_scale_size, sep = " + ")
} else if (input$nodeColAttr != "None" & input$nodeSizeAttr != "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttr,
",size = ", input$nodeSizeAttr, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0(
"scale_fill_gradient(low = \"", input$nodeColAttrL, "\",",
"high = \"", input$nodeColAttrH, "\")"
)
nodes_scale_size <- paste0("scale_size(range = c(", input$nodeSizeAttrL, ",", input$nodeSizeAttrH, "))")
code_nodes <- paste(code_nodes, nodes_scale_col, nodes_scale_size, sep = " + ")
} else if (input$nodeColAttrD != "None" & input$nodeSizeAttr != "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttrD,
", size = ", input$nodeSizeAttr, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0("scale_fill_brewer(palette = \"", input$nodeColAttrP, "\", na.value = \"gray53\")")
nodes_scale_size <- paste0("scale_size(range = c(", input$nodeSizeAttrL, ",", input$nodeSizeAttrH, "))")
code_nodes <- paste(code_nodes, nodes_scale_col, nodes_scale_size, sep = " + ")
}
#--------------------#
# nodes labels ----
#--------------------#
if (input$nodeLabelAttr != "None" & input$nodeLabelAttr != "") {
code_labels <- paste0(
"geom_node_text(",
"aes(label = ", input$nodeLabelAttr, ")",
", colour = \"", input$nodeLabelCol, "\"",
", size = ", input$nodeLabelSize,
", family = \"", input$nodeLabelFont, "\"",
")"
)
if (input$nodeLabelRepel) {
insert <- paste0(", repel = ", input$nodeLabelRepel, ",segment.alpha=0)")
code_labels <- gsub("\\)$", insert, code_labels)
}
code_nodes <- paste(code_nodes, code_labels, sep = " + ")
}
#--------------------#
# edges ----
#--------------------#
if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"edge_colour = \"", input$edgeColMan, "\"",
",edge_width = ", input$edgeSizeMan,
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(colour = ", input$edgeColAttr, ")",
",edge_width = ", input$edgeSizeMan,
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(colour = ", input$edgeColAttrD, ")",
",edge_width = ", input$edgeSizeMan,
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, sep = " + ")
} else if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(width = ", input$edgeSizeAttr, ")",
",\nedge_colour = \"", input$edgeColMan, "\"",
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
code_edges <- paste(code_edges, edge_scale_size, sep = " + ")
} else if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr, ")",
",\nedge_colour = \"", input$edgeColMan, "\"",
",\nedge_width = ", input$edgeSizeMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
code_edges <- paste(code_edges, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttr, ")",
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttrD, ")",
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, sep = " + ")
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",colour = ", input$edgeColAttr, ")",
",\nedge_width = ", input$edgeSizeMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",colour = ", input$edgeColAttrD, ")",
",\nedge_width = ", input$edgeSizeMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",width = ", input$edgeSizeAttr, ")",
",\nedge_colour = \"", input$edgeColMan, "\"", ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
code_edges <- paste(code_edges, edge_scale_size, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttr, ")", ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttrD, ")", ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, edge_scale_alpha, sep = " + ")
}
#----------------#
# theme ----
#----------------#
code_theme <- paste0("theme_graph() + theme(legend.position = \"", input$legendPos, "\")")
#----------------#
# glue ----
#----------------#
code <- paste(code_layout, code_edges, code_nodes, code_theme, sep = " + ")
if (input$showLabs) {
code <- paste0(code, "+ geom_node_text(label = 1:vcount(rv$g),colour=\"white\")")
}
# p <- eval(parse(text = code))
p <- code
return(p)
})
#----------------#
DT_reactiveN <- reactive({
create_attribute_df(rv$g, which = "nodes")
})
DT_reactiveE <- reactive({
create_attribute_df(rv$g, which = "edges")
})
#----------------#
# render plot
ggnet <- renderPlot({
eval(parse(text = gg_reactive()))
})
# render for save
plotInput <- function() {
eval(parse(text = gg_reactive()))
}
# save plot as png
output$downloadData <- downloadHandler(
filename = "graph.png",
content = function(file) {
ggsave(file, plot = plotInput())
}
)
# render Attribute Manager
dfattrN <- DT::renderDataTable(
{
DT_reactiveN()
},
options = list(
lengthMenu = list(c(10, 20, -1), c("10", "20", "All")),
pageLength = 10,
searching = FALSE
)
)
dfattrE <- DT::renderDataTable(
{
DT_reactiveE()
},
options = list(
lengthMenu = list(c(10, 20, -1), c("10", "20", "All")),
pageLength = 10,
searching = FALSE
)
)
output$Graph1 <- ggnet
output$Graph2 <- ggnet
output$Graph3 <- ggnet
output$Graph4 <- ggnet
output$attrManageN <- dfattrN
output$attrManageE <- dfattrE
# DONE -----
observeEvent(input$done, {
result <- gg_reactive()
result <- gsub("ggraph\\(rv\\$g,", paste0("ggraph\\(", text, ","), result)
V(rv$g)$x <- rv$xy[, 1]
V(rv$g)$y <- rv$xy[, 2]
result <- gsub("rv\\$xy\\[,1\\]", "x", result)
result <- gsub("rv\\$xy\\[,2\\]", "y", result)
# result <- gsub("rv\\$xy\\[,1\\]",paste0("V(",text,")$x"),result)
# result <- gsub("rv\\$xy\\[,2\\]",paste0("V(",text,")$y"),result)
#
result <- paste0("y <- ", "c(", paste0(round(rv$xy[, 2], 4), collapse = ", "), ")", "\n\n", result)
result <- paste0("x <- ", "c(", paste0(round(rv$xy[, 1], 4), collapse = ", "), ")", "\n", result)
result <- formatR::tidy_source(text = result, output = FALSE)$text.tidy
result <- gsub("\\+", "\\+ \n\t", result)
result <- gsub("\n\\s*\n", "\n", result)
eval(parse(text = paste0("assign(\"", text, "\",rv$g", ",envir = .GlobalEnv)")))
rstudioapi::insertText(result)
invisible(stopApp())
})
observeEvent(input$cancel, {
invisible(stopApp())
})
}
viewer <- dialogViewer(dialogName = "SNAhelper", width = 990, height = 900)
# viewer <- browserViewer(browser = getOption("browser"))
runGadget(ui, server, stopOnCancel = FALSE, viewer = viewer)
}
#' @export
#' @examples
#' if (interactive()) {
#' graph <- igraph::sample_gnp(100, 0.2)
#' SNAhelperGadget(graph)
#' }
#' @rdname SNAhelper
SNAhelperGadget <- function(graph) {
if (missing(graph)) {
stop("You must provide an igraph object.", call. = FALSE)
}
graph <- deparse(substitute(graph))
if (grepl("^\\s*[[:alpha:]]+[[:alnum:]\\.]*\\s*$", paste0(graph, collapse = ""))) {
SNAhelper(graph)
} else {
stop("You must provide an igraph object.", call. = FALSE)
}
}
#' @export
#' @rdname SNAhelper
SNAhelperAddin <- function() {
context <- rstudioapi::getActiveDocumentContext()
text <- context$selection[[1]]$text
# text <- "gr"
if (nchar(text) == 0) {
stop("Please highlight an igraph object before using this addin.")
}
SNAhelper(text)
}
schochastics/snahelper documentation built on Nov. 19, 2023, 7:12 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 SNAhelperAddin SNAhelperGadget SNAhelper
Documented in SNAhelper SNAhelperAddin SNAhelperGadget
#' SNAhelper
#'
#' \code{SNAhelper} is a RStudio-Addin that provides a graphical interface for network analysis and visualization.
#'
#' @details To run the addin, highlight an igraph-object in your current script and select \code{SNAhelper} from the Addins-menu within RStudio. After terminating the addin, a character string containing the code for visualization is inserted in your current script. Alternatively you can run it with SNAhelperGadget(graph) from the console.
#' @param graph An igraph object to visualize
#' @return \code{SNAhelper} returns a character vector with code.
#' @import miniUI
#' @import shiny
#' @import ggplot2
#' @import ggraph
#' @import rstudioapi
#' @import igraph
#' @importFrom colourpicker colourInput
#' @importFrom grDevices col2rgb
#' @importFrom grDevices colors
#' @name SNAhelper
NULL
SNAhelper <- function(text) {
if (!requireNamespace("graphlayouts", quietly = TRUE)) {
stop("graphlayouts package not found. Install it with install.packages('graphlayouts')", call. = FALSE)
}
if (any(ls(envir = .GlobalEnv) == text)) {
g <- get(text, envir = .GlobalEnv)
if (!igraph::is.igraph(g)) {
stop(paste0(text, " is not an igraph object"))
}
if (any(igraph::vertex_attr_names(g) == "x") & any(igraph::vertex_attr_names(g) == "y")) {
xy <- cbind(igraph::V(g)$x, igraph::V(g)$y)
} else {
xy <- graphlayouts::layout_with_stress(g)
}
rv <- reactiveValues(g = g, xy = xy)
} else {
stop(paste0("Couldn't find the graph ", text, "."))
}
if (any(igraph::is.multiple(g))) {
edge_geom <- "geom_edge_parallel0("
} else {
edge_geom <- "geom_edge_link0("
}
# ui ----
ui <- miniPage(
tags$script(jscodeWidth),
tags$script(jscodeHeight),
tags$style(type = "text/css", ".selectize-dropdown{ width: 200px !important; }"),
tags$style(type = "text/css", ".form-group.shiny-input-container{width:50%;}"),
gadgetTitleBar("SNA helper"),
miniTabstripPanel(
selected = "layout",
miniTabPanel("layout",
icon = icon("sliders-h"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Choose Layout")
),
fillRow(
height = line.height, width = "100%",
selectizeInput("graphLayout",
label = "Layout Algorithm",
choices = layouts.available,
selected = "graphlayouts::layout_with_stress", width = input.width
),
shiny::conditionalPanel(
"input.graphLayout=='graphlayouts::layout_with_focus'",
selectizeInput("focalNode",
label = "Choose Focal Node ID",
choices = 1:igraph::vcount(g),
width = input.width
)
),
shiny::conditionalPanel(
"input.graphLayout=='graphlayouts::layout_with_centrality'",
selectizeInput("centralLay",
label = "Choose Centrality",
choices = NULL,
width = input.width
)
)
),
fillRow(
height = line.height, width = "50%",
actionButton("do.layout", "Calculate Layout"),
actionButton("del.isolate", "Delete Isolates")
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Tweak Layout"),
checkboxInput("showLabs", label = "Show NodeIDs", value = FALSE)
),
fillRow(
height = line.height, width = "100%",
selectizeInput("nodeId",
label = "NodeID", choices = 1:vcount(g),
width = input.width
),
p("tweak node position by clicking on the desired location.")
)
),
plotOutput("Graph1", width = "80%", height = "55%", click = "tweakxy")
),
miniTabPanel("node attributes",
icon = icon("list-ol"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = line.height, width = "100%",
selectizeInput("centindex",
label = "Index",
choices = NULL,
width = input.width
),
selectizeInput("clusteralg",
label = "Clustering",
choices = c("Louvain" = "cluster_louvain(rv$g)"),
width = input.width
)
),
fillRow(
height = line.height, width = "100%",
actionButton("calcIndex", "Calculate Index"),
actionButton("calcClust", "Calculate Clustering")
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Node Attributes")
),
DT::dataTableOutput("attrManageN")
)
),
miniTabPanel("nodes",
icon = icon("circle"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Manual")
),
fillRow(
height = line.height, width = "100%",
colourInput("nodeColMan", label = "Colour", value = "gray32"),
numericInput("nodeSizeMan",
label = "Size",
min = 0, max = 20, step = 0.5, value = 5, width = input.width
),
colourInput("nodeBorderColMan", label = "Border Colour", value = "black"),
numericInput("nodeBorderSizeMan",
label = "Border Size",
min = 0, max = 2, step = 0.1, value = 0.3, width = input.width
)
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Attribute")
),
fillRow(
height = line.height, width = "100%",
selectizeInput("nodeColAttr",
label = "Colour (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("nodeColAttrD",
label = "Colour (Discrete)",
choices = NULL,
width = input.width
),
selectizeInput("nodeSizeAttr",
label = "Size (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("nodeLabelAttr",
label = "Node Label",
choices = NULL,
width = input.width
)
),
fillRow(
height = line.height, width = "100%",
shiny::conditionalPanel(
"input.nodeColAttr!='None'",
colourInput("nodeColAttrL", label = "Min Colour", value = "skyblue1"),
colourInput("nodeColAttrH", label = "Max Colour", value = "royalblue4")
),
shiny::conditionalPanel(
"input.nodeColAttrD!='None'",
selectizeInput("nodeColAttrP",
label = "Palette",
choices = c(
"Set1", "Set2", "Set3", "Pastel2", "Pastel1",
"Paired", "Dark2", "Accent"
),
width = input.width
)
),
shiny::conditionalPanel(
"input.nodeSizeAttr!='None'",
numericInput("nodeSizeAttrL",
label = "Min Size",
min = 0, max = 20, step = 0.5, value = 3, width = input.width
),
numericInput("nodeSizeAttrH",
label = "Max Size",
min = 0, max = 20, step = 0.5, value = 8, width = input.width
)
),
shiny::conditionalPanel(
"input.nodeLabelAttr!='None'",
colourInput("nodeLabelCol", label = "Colour", value = "black"),
# selectizeInput('nodeLabelCol',label = 'Colour',
# choices = NULL, width = input.width),
numericInput("nodeLabelSize",
label = "Size",
min = 0, max = 20, step = 0.5, value = 6, width = input.width
),
selectizeInput("nodeLabelFont",
label = "Font",
choices = fonts.available, width = input.width
),
shiny::checkboxInput("nodeLabelRepel", label = "Repel Labels?", value = FALSE)
)
)
),
plotOutput("Graph2", width = "80%", height = "55%")
),
miniTabPanel("edge attributes",
icon = icon("list-ol"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Edge Attributes")
),
DT::dataTableOutput("attrManageE")
)
),
miniTabPanel("edges",
icon = icon("minus"),
miniContentPanel(
scrollable = FALSE,
fillRow(
height = heading.height, width = "100%",
headingOutput("Manual")
),
fillRow(
height = line.height, width = "75%",
colourInput("edgeColMan", label = "Colour", value = "gray66"),
numericInput("edgeSizeMan",
label = "Width",
min = 0, max = 10, step = 0.1, value = 0.8, width = input.width
),
numericInput("edgeAlphaMan",
label = "Alpha",
min = 0, max = 1, step = 0.01, value = 1.0, width = input.width
)
),
fillRow(
height = heading.height, width = "100%",
headingOutput("Attribute")
),
fillRow(
height = line.height, width = "100%",
selectizeInput("edgeColAttr",
label = "Colour (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("edgeColAttrD",
label = "Colour (Discrete)",
choices = NULL,
width = input.width
),
selectizeInput("edgeSizeAttr",
label = "Width (Cont.)",
choices = NULL,
width = input.width
),
selectizeInput("edgeAlphaAttr",
label = "Alpha (Cont.)",
choices = NULL,
width = input.width
)
),
fillRow(
height = line.height, width = "100%",
shiny::conditionalPanel(
"input.edgeColAttr!='None'",
colourInput("edgeColAttrL", label = "Min Colour", value = "skyblue1"),
colourInput("edgeColAttrH", label = "Max Colour", value = "royalblue4")
),
shiny::conditionalPanel(
"input.edgeColAttrD!='None'",
selectizeInput("edgeColAttrP",
label = "Palette",
choices = c(
"Set1", "Set2", "Set3", "Pastel2", "Pastel1",
"Paired", "Dark2", "Accent"
),
width = input.width
)
),
shiny::conditionalPanel(
"input.edgeSizeAttr!='None'",
numericInput("edgeSizeAttrL",
label = "Min Width",
min = 0, max = 10, step = 0.1, value = 0.3, width = input.width
),
numericInput("edgeSizeAttrH",
label = "Max Width",
min = 0, max = 10, step = 0.1, value = 1.2, width = input.width
)
),
shiny::conditionalPanel(
"input.edgeAlphaAttr!='None'",
numericInput("edgeAlphaAttrL",
label = "Min Alpha",
min = 0, max = 1, step = 0.01, value = 0.1, width = input.width
),
numericInput("edgeAlphaAttrH",
label = "Max Alpha",
min = 0, max = 1, step = 0.01, value = 1, width = input.width
)
)
)
),
plotOutput("Graph3", width = "80%", height = "55%")
),
miniTabPanel("result",
icon = icon("bezier-curve"),
plotOutput("Graph4", width = "90%", height = "80%"),
miniContentPanel(
scrollable = TRUE,
fillRow(
height = line.height, width = "50%",
selectInput("legendPos",
label = "Show Legend:",
choices = c("none", "top", "bottom", "left", "right"),
width = input.width
)
),
downloadButton("downloadData", "Save PNG")
)
)
)
)
server <- function(input, output, session) {
#--------------------#
# constants ----
#--------------------#
vattr.to.aes <- igraph::vertex_attr_names(g)[!grepl("name", igraph::vertex_attr_names(g))]
if (length(vattr.to.aes) > 0) {
idC <- which(sapply(vattr.to.aes, function(x) is.numeric(igraph::get.vertex.attribute(g, x))))
vattrC.to.aes <- c("None", vattr.to.aes[idC])
idC <- which(sapply(vattr.to.aes, function(x) !is.numeric(igraph::get.vertex.attribute(g, x))))
vattrD.to.aes <- c("None", vattr.to.aes[idC])
} else {
vattrC.to.aes <- c("None")
vattrD.to.aes <- c("None")
}
eattr.to.aes <- igraph::edge_attr_names(g)
if (length(eattr.to.aes) > 0) {
idC <- which(sapply(eattr.to.aes, function(x) is.numeric(igraph::get.edge.attribute(g, x))))
eattrC.to.aes <- c("None", eattr.to.aes[idC])
idC <- which(sapply(eattr.to.aes, function(x) !is.numeric(igraph::get.edge.attribute(g, x))))
eattrD.to.aes <- c("None", eattr.to.aes[idC])
} else {
eattrC.to.aes <- c("None")
eattrD.to.aes <- c("None")
}
#--------------------#
# check graph properties
#--------------------#
if (is.directed(g) & !is.weighted(g)) {
cent_choice <- c(
"In-Degree" = "degree(rv$g,mode='in')",
"Out-Degree" = "degree(rv$g,mode='out')",
"Degree" = "degree(rv$g,mode='all')",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"PageRank" = "page_rank(rv$g)$vector"
)
} else if (!is.directed(g) & is.weighted(g)) {
cent_choice <- c(
"Degree" = "degree(rv$g)",
"Weighted Degree" = "graph.strength(rv$g)",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"Eigenvector" = "eigen_centrality(rv$g)$vector"
)
} else if (!is.directed(g) & !is.weighted(g)) {
cent_choice <- c(
"Degree" = "degree(rv$g)",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"Eigenvector" = "eigen_centrality(rv$g)$vector"
)
} else {
cent_choice <- c(
"In-Degree" = "degree(rv$g,mode='in')",
"Out-Degree" = "degree(rv$g,mode='out')",
"Degree" = "degree(rv$g,mode='all')",
"Weighted In-Degree" = "graph.strength(rv$g,mode='in')",
"Weighted Out-Degree" = "graph.strength(rv$g,mode='out')",
"Weighted Degree" = "graph.strength(rv$g,mode='all')",
"Betwenness" = "betweenness(rv$g)",
"Closeness" = "closeness(rv$g)",
"PageRank" = "page_rank(rv$g)$vector"
)
}
#--------------------#
# initialize selectors ----
#--------------------#
updateSelectizeInput(
session = session, inputId = "centralLay",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeColAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeLabelAttr",
choices = c("None", igraph::vertex_attr_names(g)),
selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeColAttrD",
choices = vattrD.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeSizeAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeColAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeColAttrD",
choices = eattrD.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeSizeAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeAlphaAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "centindex",
choices = cent_choice, selected = cent_choice[1], server = TRUE,
options = list(create = TRUE)
)
#--------------------#
# be sure either discrete or continuos is selected ----
#--------------------#
shiny::observe({
if (input$nodeColAttr != "None") {
shiny::updateSelectInput(session, "nodeColAttrD", selected = "None")
}
})
shiny::observe({
if (input$nodeColAttrD != "None") {
shiny::updateSelectInput(session, "nodeColAttr", selected = "None")
}
})
shiny::observe({
if (input$edgeColAttr != "None") {
shiny::updateSelectInput(session, "edgeColAttrD", selected = "None")
}
})
shiny::observe({
if (input$edgeColAttrD != "None") {
shiny::updateSelectInput(session, "edgeColAttr", selected = "None")
}
})
#--------------------#
# calculate initial layout ----
#--------------------#
shiny::observeEvent(input$del.isolate, {
idx <- which(degree(rv$g) == 0)
if (length(idx) >= 1) {
g <- igraph::delete.vertices(rv$g, idx)
xy <- rv$xy[-idx, ]
rv$g <- g
rv$xy <- xy
gg_reactive()
}
})
shiny::observeEvent(input$do.layout, {
if (input$graphLayout == "graphlayouts::layout_as_backbone") {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g)")))
rv$xy <- xy$xy
bb <- rep(0, ecount(rv$g))
bb[xy$backbone] <- 1
g <- igraph::set.edge.attribute(graph = rv$g, name = "backbone", value = bb)
rv$g <- g
eattr.to.aes <- igraph::edge_attr_names(g)
if (length(eattr.to.aes) > 0) {
idC <- which(sapply(eattr.to.aes, function(x) is.numeric(igraph::get.edge.attribute(g, x))))
eattrC.to.aes <- c("None", eattr.to.aes[idC])
} else {
eattrC.to.aes <- c("None")
}
updateSelectizeInput(
session = session, inputId = "edgeColAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeSizeAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "edgeAlphaAttr",
choices = eattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
} else if (input$graphLayout == "graphlayouts::layout_with_focus") {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g, v = ", input$focalNode, ")$xy")))
rv$xy <- xy
} else if (input$graphLayout == "graphlayouts::layout_with_centrality") {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g, cent = get.vertex.attribute(rv$g,\"", input$centralLay, "\"))")))
rv$xy <- xy
} else {
xy <- eval(parse(text = paste0(input$graphLayout, "(rv$g)")))
rv$xy <- xy
}
gg_reactive()
})
#--------------------#
# tweak layout ----
#--------------------#
shiny::observeEvent(input$tweakxy, {
indX <- as.numeric(input$nodeId)
rv$xy[indX, 1] <- input$tweakxy$x
rv$xy[indX, 2] <- input$tweakxy$y
gg_reactive()
})
#--------------------#
# calculate centrality/clustering ----
#--------------------#
shiny::observeEvent(input$calcIndex, {
attr_name <- gsub("\\(rv.*", "", input$centindex)
if (igraph::is_directed(g) & attr_name == "degree") {
opt <- gsub("')", "", gsub(".*mode='", "", input$centindex))
attr_name <- paste0(opt, "_", attr_name)
}
if (igraph::is_directed(g) & attr_name == "graph.strength") {
opt <- gsub("')", "", gsub(".*mode='", "", input$centindex))
attr_name <- paste0(opt, "_", attr_name)
}
if (!attr_name %in% igraph::vertex_attr_names(rv$g)) {
ind <- eval(parse(text = input$centindex))
g <- igraph::set.vertex.attribute(graph = rv$g, name = attr_name, value = ind)
rv$g <- g
vattr.to.aes <- igraph::vertex_attr_names(rv$g)[!grepl("name", igraph::vertex_attr_names(rv$g))]
idC <- which(sapply(vattr.to.aes, function(x) is.numeric(igraph::get.vertex.attribute(rv$g, x))))
vattrC.to.aes <- c("None", vattr.to.aes[idC])
updateSelectizeInput(
session = session, inputId = "centralLay",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeColAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeSizeAttr",
choices = vattrC.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeLabelAttr",
choices = c("None", igraph::vertex_attr_names(g)),
selected = "None", server = TRUE,
options = list(create = TRUE)
)
}
})
shiny::observeEvent(input$calcClust, {
attr_name <- gsub("\\(rv.*", "", input$clusteralg)
if (!attr_name %in% igraph::vertex_attr_names(rv$g)) {
ind <- eval(parse(text = input$clusteralg))
ind <- as.character((igraph::membership(ind)))
g <- igraph::set.vertex.attribute(graph = rv$g, name = attr_name, value = ind)
rv$g <- g
vattr.to.aes <- igraph::vertex_attr_names(rv$g)[!grepl("name", igraph::vertex_attr_names(rv$g))]
idC <- which(sapply(vattr.to.aes, function(x) !is.numeric(igraph::get.vertex.attribute(rv$g, x))))
vattrD.to.aes <- c("None", vattr.to.aes[idC])
updateSelectizeInput(
session = session, inputId = "nodeColAttrD",
choices = vattrD.to.aes, selected = "None", server = TRUE,
options = list(create = TRUE)
)
updateSelectizeInput(
session = session, inputId = "nodeLabelAttr",
choices = c("None", igraph::vertex_attr_names(g)),
selected = "None", server = TRUE,
options = list(create = TRUE)
)
}
})
#------------------------------------------------------------#
#--------------------#
# main plotting function ----
#--------------------#
gg_reactive <- reactive({
validate(
need(is.validColour(input$nodeColMan), ""),
need(is.validColour(input$edgeColMan), ""),
need(is.validColour(input$nodeBorderColMan), ""),
# need(is.validColour(input$nodeColAttr), ''),
# need(is.validColour(input$nodeColAttrL), ''),
# need(is.validColour(input$nodeColAttrH), ''),
# need(is.validColour(input$edgeColAttr), ''),
# need(is.validColour(input$edgeColAttrL), ''),
# need(is.validColour(input$edgeColAttrH), ''),
need(is.validColour(input$edgeColMan), "")
)
#--------------------#
# layout ----
#--------------------#
# xy <- get_layout()
code_layout <- "ggraph(rv$g,layout = \"manual\", x = rv$xy[,1], y = rv$xy[,2])"
#--------------------#
# nodes ----
#--------------------#
if (input$nodeColAttr == "None" & input$nodeColAttrD == "None" & input$nodeSizeAttr == "None") {
code_nodes <- paste0(
"geom_node_point(",
"fill = \"", input$nodeColMan, "\"",
",colour = \"", input$nodeBorderColMan, "\"",
",size = ", input$nodeSizeMan,
",stroke = ", input$nodeBorderSizeMan,
",shape = 21",
")"
)
} else if (input$nodeColAttr != "None" & input$nodeSizeAttr == "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttr, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nsize = ", input$nodeSizeMan,
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0(
"scale_fill_gradient(low = \"", input$nodeColAttrL, "\",",
"high = \"", input$nodeColAttrH, "\")"
)
code_nodes <- paste(code_nodes, nodes_scale_col, sep = " + ")
} else if (input$nodeColAttrD != "None" & input$nodeSizeAttr == "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttrD, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nsize = ", input$nodeSizeMan,
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0("scale_fill_brewer(palette = \"", input$nodeColAttrP, "\", na.value = \"gray53\")")
code_nodes <- paste(code_nodes, nodes_scale_col, sep = " + ")
} else if (input$nodeColAttr == "None" & input$nodeColAttrD == "None" & input$nodeSizeAttr != "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(size = ", input$nodeSizeAttr, ")",
",\nfill = \"", input$nodeColMan, "\"",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_size <- paste0("scale_size(range = c(", input$nodeSizeAttrL, ",", input$nodeSizeAttrH, "))")
code_nodes <- paste(code_nodes, nodes_scale_size, sep = " + ")
} else if (input$nodeColAttr != "None" & input$nodeSizeAttr != "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttr,
",size = ", input$nodeSizeAttr, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0(
"scale_fill_gradient(low = \"", input$nodeColAttrL, "\",",
"high = \"", input$nodeColAttrH, "\")"
)
nodes_scale_size <- paste0("scale_size(range = c(", input$nodeSizeAttrL, ",", input$nodeSizeAttrH, "))")
code_nodes <- paste(code_nodes, nodes_scale_col, nodes_scale_size, sep = " + ")
} else if (input$nodeColAttrD != "None" & input$nodeSizeAttr != "None") {
code_nodes <- paste0(
"geom_node_point(",
"aes(fill = ", input$nodeColAttrD,
", size = ", input$nodeSizeAttr, ")",
",\ncolour = \"", input$nodeBorderColMan, "\"",
",\nshape = 21",
", stroke = ", input$nodeBorderSizeMan,
")"
)
nodes_scale_col <- paste0("scale_fill_brewer(palette = \"", input$nodeColAttrP, "\", na.value = \"gray53\")")
nodes_scale_size <- paste0("scale_size(range = c(", input$nodeSizeAttrL, ",", input$nodeSizeAttrH, "))")
code_nodes <- paste(code_nodes, nodes_scale_col, nodes_scale_size, sep = " + ")
}
#--------------------#
# nodes labels ----
#--------------------#
if (input$nodeLabelAttr != "None" & input$nodeLabelAttr != "") {
code_labels <- paste0(
"geom_node_text(",
"aes(label = ", input$nodeLabelAttr, ")",
", colour = \"", input$nodeLabelCol, "\"",
", size = ", input$nodeLabelSize,
", family = \"", input$nodeLabelFont, "\"",
")"
)
if (input$nodeLabelRepel) {
insert <- paste0(", repel = ", input$nodeLabelRepel, ",segment.alpha=0)")
code_labels <- gsub("\\)$", insert, code_labels)
}
code_nodes <- paste(code_nodes, code_labels, sep = " + ")
}
#--------------------#
# edges ----
#--------------------#
if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"edge_colour = \"", input$edgeColMan, "\"",
",edge_width = ", input$edgeSizeMan,
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(colour = ", input$edgeColAttr, ")",
",edge_width = ", input$edgeSizeMan,
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(colour = ", input$edgeColAttrD, ")",
",edge_width = ", input$edgeSizeMan,
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, sep = " + ")
} else if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(width = ", input$edgeSizeAttr, ")",
",\nedge_colour = \"", input$edgeColMan, "\"",
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
code_edges <- paste(code_edges, edge_scale_size, sep = " + ")
} else if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr, ")",
",\nedge_colour = \"", input$edgeColMan, "\"",
",\nedge_width = ", input$edgeSizeMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
code_edges <- paste(code_edges, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttr, ")",
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr == "None") {
code_edges <- paste0(
edge_geom,
"aes(width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttrD, ")",
",edge_alpha = ", input$edgeAlphaMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, sep = " + ")
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",colour = ", input$edgeColAttr, ")",
",\nedge_width = ", input$edgeSizeMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr == "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",colour = ", input$edgeColAttrD, ")",
",\nedge_width = ", input$edgeSizeMan, ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttr == "None" & input$edgeColAttrD == "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",width = ", input$edgeSizeAttr, ")",
",\nedge_colour = \"", input$edgeColMan, "\"", ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
code_edges <- paste(code_edges, edge_scale_size, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttr != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttr, ")", ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_gradient(low = \"", input$edgeColAttrL, "\",",
"high = \"", input$edgeColAttrH, "\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, edge_scale_alpha, sep = " + ")
} else if (input$edgeColAttrD != "None" & input$edgeSizeAttr != "None" & input$edgeAlphaAttr != "None") {
code_edges <- paste0(
edge_geom,
"aes(alpha = ", input$edgeAlphaAttr,
",width = ", input$edgeSizeAttr,
",\ncolour = ", input$edgeColAttrD, ")", ")"
)
if (is.directed(g)) {
arrow_code <- paste0(
",\narrow = arrow(angle = 30, length = unit(0.15, \"inches\")",
",\nends = \"last\", type = \"closed\"))"
)
code_edges <- gsub(")$", arrow_code, code_edges)
}
edge_scale_alpha <- paste0(
"scale_edge_alpha(",
"range = c(", input$edgeAlphaAttrL, ",", input$edgeAlphaAttrH, "))"
)
edge_scale_size <- paste0(
"scale_edge_width(",
"range = c(", input$edgeSizeAttrL, ",", input$edgeSizeAttrH, "))"
)
edge_scale_col <- paste0(
"scale_edge_colour_brewer(palette = \"",
input$edgeColAttrP, "\", na.value = \"gray53\")"
)
code_edges <- paste(code_edges, edge_scale_col, edge_scale_size, edge_scale_alpha, sep = " + ")
}
#----------------#
# theme ----
#----------------#
code_theme <- paste0("theme_graph() + theme(legend.position = \"", input$legendPos, "\")")
#----------------#
# glue ----
#----------------#
code <- paste(code_layout, code_edges, code_nodes, code_theme, sep = " + ")
if (input$showLabs) {
code <- paste0(code, "+ geom_node_text(label = 1:vcount(rv$g),colour=\"white\")")
}
# p <- eval(parse(text = code))
p <- code
return(p)
})
#----------------#
DT_reactiveN <- reactive({
create_attribute_df(rv$g, which = "nodes")
})
DT_reactiveE <- reactive({
create_attribute_df(rv$g, which = "edges")
})
#----------------#
# render plot
ggnet <- renderPlot({
eval(parse(text = gg_reactive()))
})
# render for save
plotInput <- function() {
eval(parse(text = gg_reactive()))
}
# save plot as png
output$downloadData <- downloadHandler(
filename = "graph.png",
content = function(file) {
ggsave(file, plot = plotInput())
}
)
# render Attribute Manager
dfattrN <- DT::renderDataTable(
{
DT_reactiveN()
},
options = list(
lengthMenu = list(c(10, 20, -1), c("10", "20", "All")),
pageLength = 10,
searching = FALSE
)
)
dfattrE <- DT::renderDataTable(
{
DT_reactiveE()
},
options = list(
lengthMenu = list(c(10, 20, -1), c("10", "20", "All")),
pageLength = 10,
searching = FALSE
)
)
output$Graph1 <- ggnet
output$Graph2 <- ggnet
output$Graph3 <- ggnet
output$Graph4 <- ggnet
output$attrManageN <- dfattrN
output$attrManageE <- dfattrE
# DONE -----
observeEvent(input$done, {
result <- gg_reactive()
result <- gsub("ggraph\\(rv\\$g,", paste0("ggraph\\(", text, ","), result)
V(rv$g)$x <- rv$xy[, 1]
V(rv$g)$y <- rv$xy[, 2]
result <- gsub("rv\\$xy\\[,1\\]", "x", result)
result <- gsub("rv\\$xy\\[,2\\]", "y", result)
# result <- gsub("rv\\$xy\\[,1\\]",paste0("V(",text,")$x"),result)
# result <- gsub("rv\\$xy\\[,2\\]",paste0("V(",text,")$y"),result)
#
result <- paste0("y <- ", "c(", paste0(round(rv$xy[, 2], 4), collapse = ", "), ")", "\n\n", result)
result <- paste0("x <- ", "c(", paste0(round(rv$xy[, 1], 4), collapse = ", "), ")", "\n", result)
result <- formatR::tidy_source(text = result, output = FALSE)$text.tidy
result <- gsub("\\+", "\\+ \n\t", result)
result <- gsub("\n\\s*\n", "\n", result)
eval(parse(text = paste0("assign(\"", text, "\",rv$g", ",envir = .GlobalEnv)")))
rstudioapi::insertText(result)
invisible(stopApp())
})
observeEvent(input$cancel, {
invisible(stopApp())
})
}
viewer <- dialogViewer(dialogName = "SNAhelper", width = 990, height = 900)
# viewer <- browserViewer(browser = getOption("browser"))
runGadget(ui, server, stopOnCancel = FALSE, viewer = viewer)
}
#' @export
#' @examples
#' if (interactive()) {
#' graph <- igraph::sample_gnp(100, 0.2)
#' SNAhelperGadget(graph)
#' }
#' @rdname SNAhelper
SNAhelperGadget <- function(graph) {
if (missing(graph)) {
stop("You must provide an igraph object.", call. = FALSE)
}
graph <- deparse(substitute(graph))
if (grepl("^\\s*[[:alpha:]]+[[:alnum:]\\.]*\\s*$", paste0(graph, collapse = ""))) {
SNAhelper(graph)
} else {
stop("You must provide an igraph object.", call. = FALSE)
}
}
#' @export
#' @rdname SNAhelper
SNAhelperAddin <- function() {
context <- rstudioapi::getActiveDocumentContext()
text <- context$selection[[1]]$text
# text <- "gr"
if (nchar(text) == 0) {
stop("Please highlight an igraph object before using this addin.")
}
SNAhelper(text)
}
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.