Nothing
#' Componentlayouter
#'
#' \code{Componentlayouter} is an RStudio-Addin that facilitates layouting networks with several components.
#'
#' @details To run the addin, highlight an igraph-object in your current script and select \code{Componentlayouter} from the Addins-menu within RStudio.
#' @return \code{Componentlayouter} returns the layout as xy coordinates.
#' @import miniUI
#' @import shiny
#' @import ggplot2
#' @import ggraph
#' @import rstudioapi
#' @import igraph
#' @name Componentlayouter
NULL
Componentlayouter <- 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"))
}
xy <- graphlayouts::layout_with_stress(g)
# xy[,1] <- xy[,1] - min(xy[,1])#normalise(xy[,1],to = c(2,3))
# xy[,2] <- xy[,2] - min(xy[,2])#normalise(xy[,2],to = c(2,3))
} else {
stop(paste0("Couldn't find the graph ", text, "."))
}
comps <- igraph::components(g)
V(g)$grp <- comps$membership
rv <- reactiveValues(xy = xy, grp = comps$membership, placed = rep(FALSE, nrow(xy)), g1 = igraph::graph.empty(), xy1 = xy)
# 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%;}"),
tags$style(type = "text/css", "#nextC{margin-top:24px;}"),
gadgetTitleBar("Component Layouter"),
fillRow(
height = line.height, width = "85%", flex = c(2, 1, 3),
selectizeInput("compId",
label = "Component", choices = order(comps$csize, decreasing = TRUE),
selected = 0, width = input.width
),
actionButton(inputId = "nextC", label = "next"),
checkboxInput("ggforce", "component labels", value = FALSE)
),
fillRow(
flex = c(4, 1), height = "80%",
plotOutput("Graph1", width = "100%", height = "100%", click = "move"),
plotOutput("Graph2", width = "100%", height = "50%")
),
fillRow(
width = "50%", height = line.height,
actionButton(inputId = "rotateL", label = "rotate left"),
actionButton(inputId = "rotateR", label = "rotate right"),
actionButton(inputId = "shrink", label = "shrink"),
actionButton(inputId = "grow", label = "grow")
)
)
# server ----
server <- function(input, output, session) {
#--------------------#
# observe next ----
#--------------------#
shiny::observeEvent(input$nextC, {
ord <- order(comps$csize, decreasing = TRUE)
id <- which(ord == as.numeric(input$compId))
if (id == length(ord)) {
sel <- ord[1]
} else {
sel <- ord[id + 1]
}
updateSelectizeInput(
session = session, inputId = "compId", label = "Component",
choices = order(comps$csize, decreasing = TRUE), selected = sel
)
})
#--------------------#
# observe click ----
#--------------------#
shiny::observeEvent(input$move, {
mxy <- c(input$move$x, input$move$y)
ids <- which(rv$grp == input$compId)
xy_grp <- rv$xy[ids, ]
meanx <- mean(xy_grp[, 1])
meany <- mean(xy_grp[, 2])
xy_grp[, 1] <- xy_grp[, 1] - meanx + mxy[1]
xy_grp[, 2] <- xy_grp[, 2] - meany + mxy[2]
xy_grp <- boundary_check(xy_grp, 10, 10)
rv$xy[ids, ] <- xy_grp
rv$placed[ids] <- TRUE
gg_reactive()
})
#--------------------#
# observe rotators ----
#--------------------#
shiny::observeEvent(input$rotateL, {
ids <- which(rv$grp == input$compId)
xy_grp <- rv$xy[ids, ]
meanx1 <- mean(xy_grp[, 1])
meany1 <- mean(xy_grp[, 2])
xy_grp <- graphlayouts::layout_rotate(xy_grp, 10)
meanx2 <- mean(xy_grp[, 1])
meany2 <- mean(xy_grp[, 2])
xy_grp[, 1] <- xy_grp[, 1] - meanx2 + meanx1
xy_grp[, 2] <- xy_grp[, 2] - meany2 + meany1
xy_grp <- boundary_check(xy_grp, 10, 10)
rv$xy[ids, ] <- xy_grp
})
shiny::observeEvent(input$rotateR, {
ids <- which(rv$grp == input$compId)
xy_grp <- rv$xy[ids, ]
meanx1 <- mean(xy_grp[, 1])
meany1 <- mean(xy_grp[, 2])
xy_grp <- graphlayouts::layout_rotate(xy_grp, -10)
meanx2 <- mean(xy_grp[, 1])
meany2 <- mean(xy_grp[, 2])
xy_grp[, 1] <- xy_grp[, 1] - meanx2 + meanx1
xy_grp[, 2] <- xy_grp[, 2] - meany2 + meany1
xy_grp <- boundary_check(xy_grp, 10, 10)
rv$xy[ids, ] <- xy_grp
})
#--------------------#
# observe shrink ----
#--------------------#
shiny::observeEvent(input$shrink, {
ids <- which(rv$grp == input$compId)
xy_grp <- rv$xy[ids, ]
xy_grp <- shrink(xy_grp, 0.1)
xy_grp <- boundary_check(xy_grp, 10, 10)
rv$xy[ids, ] <- xy_grp
})
#--------------------#
# observe grow ----
#--------------------#
shiny::observeEvent(input$grow, {
ids <- which(rv$grp == input$compId)
xy_grp <- rv$xy[ids, ]
xy_grp <- shrink(xy_grp, -0.1)
xy_grp <- boundary_check(xy_grp, 10, 10)
rv$xy[ids, ] <- xy_grp
})
#-------------------#
# plot ----
#-------------------#
gg_reactive <- reactive({
if (all(!rv$placed)) {
xscale <- 10
yscale <- 10
code_scale <- paste0("scale_x_continuous(limits=c(0,", xscale, ")) + scale_y_continuous(limits=c(0,", yscale, "))")
empty <- "ggraph(igraph::graph.empty(),layout = \"circle\")+theme_graph(foreground=\"black\",border=TRUE)"
p <- paste(empty, code_scale, sep = " + ")
} else {
idx <- which(rv$placed)
rv$g1 <- induced_subgraph(g, idx)
rv$xy1 <- rv$xy[idx, ]
# print(rv$xy1)
xscale <- 10
yscale <- 10
code_layout <- "ggraph(rv$g1,layout = \"manual\", x = rv$xy1[,1], y = rv$xy1[,2])"
code_nodes <- "geom_node_point(shape = 21,fill = \"grey25\",size=2)"
code_edges <- "geom_edge_link0(edge_width=0.2,edge_colour=\"grey66\")"
code_theme <- "theme_graph(foreground=\"black\",border=TRUE)"
code_scale <- paste0("scale_x_continuous(limits=c(0,", xscale, ")) + scale_y_continuous(limits=c(0,", yscale, "))")
if (input$ggforce) {
if (!requireNamespace("ggforce", quietly = TRUE)) {
stop("ggforce required. Install it with install.packages('ggforce')", call. = FALSE)
}
code_grp <- "ggforce::geom_mark_hull(aes(x, y, group = grp, label=grp),concavity = 4, expand = unit(2, \"mm\"))"
code <- paste(code_layout, code_edges, code_nodes, code_grp, code_scale, code_theme, sep = " + ")
} else {
code <- paste(code_layout, code_edges, code_nodes, code_scale, code_theme, sep = " + ")
}
p <- code
}
return(p)
})
# render plot ----
ggnet <- renderPlot({
eval(parse(text = gg_reactive()))
})
output$Graph1 <- ggnet
previewPlot <- reactive({
idx <- which(rv$grp == as.numeric(input$compId))
preview <- igraph::induced_subgraph(g, idx)
xy_prev <- rv$xy[idx, ]
ggraph(preview, "manual", x = xy_prev[, 1], y = xy_prev[, 2]) +
geom_edge_link0(edge_width = 0.2, edge_colour = "grey66") +
geom_node_point(shape = 21, fill = "grey25", size = 2) +
theme_graph(foreground = "black", title_size = 12, title_face = "plain", border = TRUE) +
labs(title = paste0("Preview of Component ", input$compId))
})
output$Graph2 <- renderPlot({
previewPlot()
})
# DONE -----
observeEvent(input$done, {
# rv$xy <- round(rv$xy,2)
# result <- paste0("xy <- ",paste0(deparse(rv$xy),collapse="\n"))
# result <- formatR::tidy_source(text=result,output = FALSE)$text.tidy
# rstudioapi::insertText(result)
V(g)$x <- rv$xy[, 1]
V(g)$y <- rv$xy[, 2]
eval(parse(text = paste0("assign(\"", text, "\",g", ",envir = .GlobalEnv)")))
invisible(stopApp())
})
# cancel ----
observeEvent(input$cancel, {
invisible(stopApp())
})
}
viewer <- dialogViewer(dialogName = "Componentlayouter", width = 1200, height = 1000)
runGadget(ui, server, stopOnCancel = FALSE, viewer = viewer)
}
#' @export
#' @rdname Componentlayouter
ComponentlayouterAddin <- 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.")
}
Componentlayouter(text)
}
normalise <- function(x, from = range(x), to = c(0, 1)) {
x <- (x - from[1]) / (from[2] - from[1])
if (!identical(to, c(0, 1))) {
x <- x * (to[2] - to[1]) + to[1]
}
x
}
boundary_check <- function(xy, xmax, ymax) {
if (any(xy[, 1] < 0)) {
xy[, 1] <- xy[, 1] + abs(min(xy[, 1]) * 1.05)
}
if (any(xy[, 2] < 0)) {
xy[, 2] <- xy[, 2] + abs(min(xy[, 2]) * 1.05)
}
if (any(xy[, 1] > xmax)) {
xy[, 1] <- xy[, 1] - abs(max(xy[, 1] - xmax) * 1.05)
}
if (any(xy[, 2] > ymax)) {
xy[, 2] <- xy[, 2] - abs(max(xy[, 2] - ymax) * 1.05)
}
xy
}
shrink <- function(xy, fac) {
mx <- mean(xy[, 1])
my <- mean(xy[, 2])
xy[, 1] <- (1 - fac) * xy[, 1] + fac * mx
xy[, 2] <- (1 - fac) * xy[, 2] + fac * my
xy
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.