R/Module_NetworkModule.R
In mjhelf/Mosaic: Metaboseek platform
Defines functions
NetworkModuleUI
NetworkModule
Documented in
NetworkModule
NetworkModuleUI
#' NetworkModule
#'
#' Visualize and interact with molecular networks
#'
#' TODO: standardize and split/simplify this module
#'
#' @describeIn NetworkModule server logic
#'
#' @inherit MseekModules
#' @param keys \code{reactive({})} that reports the current key press
#'
#' @return Returns its internalValues
#'
#' @export
NetworkModule <- function(input,output, session,
values = reactiveValues(Networks = NULL,
MSData = NULL),
reactives = reactive({list(active = T,
highlights = integer(0) # fixed__id values of nodes to be highlighted
)
}),
static = list(noSelection = T),
keys = reactive({"NO"})
){
ns <- NS(session$ns(NULL))
internalValues <- reactiveValues(graph = NULL,tables = NULL,
xrange = NULL, #the x axis range
yrange = NULL, #the y axis range
maxxrange = NULL, #maximum x axis range
maxyrange = NULL, #maximum y axis range
layouts = NULL,
activelayout = list(graph = NULL,
layout = NULL,
subg = NULL),
marker = NULL, #selected peak with $mz and $intensity
hover = NULL, #peak hovered over with $mz and $intensity
elabels = NULL,
elabelcheck = F,
vlabels = NULL,
vlabelcheck = F,
vlabelcol = NULL,
vlabccheck = F,
vlabcolfactors = NULL,
overview = F,
markgroups = NULL,
activeTab = "",
active = NULL, #which network is currently selected,
colscale = {crange <- colorRampPalette(c("blue", "gray", "red"))
crange(200) },
sliderValues = c(0,1),
highlights = integer(0),
hoverActive = T,
recordedPlot = NULL,
logscale = T,
regChange = "nothing"
)
callModule(MseekHistoryWidget, "nethistory", FT = reactive({
if(length(values$Networks)
&& length(internalValues$active)
&& internalValues$active %in% names(values$Networks)){
values$Networks[[internalValues$active]]
}else{NULL}
}),
buttonLabel = ""
)
callModule(MatchReferenceModule, "matchref", values = values)
output$activenetwork <- renderUI({
if(!static$noSelection){
selectizeInput(ns('activeNetwork'), 'Show Network',
selected = input$activeNetwork,
choices = names(values$Networks)[names(values$Networks) != "numNetworks"],
multiple = FALSE)
}
})
observeEvent(input$activeNetwork, {
if(!static$noSelection){
internalValues$active <- input$activeNetwork
}
})
observe({if(length(values$Networks)
&& length(internalValues$active)){
internalValues$regChange <- MseekHash(values$Networks[[internalValues$active]])
}else{
internalValues$regChange <- "nothing"}})
observeEvent(internalValues$regChange,{
#values$Networks[[internalValues$active]],{#c(internalValues$active),{
if(!is.null(values$Networks)
&& length(names(values$Networks)[names(values$Networks) != "numNetworks"]) > 0
# && !is.null(internalValues$active)
# && internalValues$active != ""
# && !is.null(values$Networks[[internalValues$active]]$graph)
){
if(is.null(internalValues$active)
|| is.na(internalValues$active)
|| internalValues$active == ""
|| is.null(values$Networks[[internalValues$active]]$graph)){
internalValues$active <- names(values$Networks)[names(values$Networks) != "numNetworks"][1]
}
internalValues$marker = NULL #selected peak with $mz and $intensity
internalValues$hover = NULL #peak hovered over with $mz and $intensity
internalValues$elabels = NULL
internalValues$elabelcheck = F
internalValues$vlabels = NULL
internalValues$vlabelcheck = F
internalValues$vlabelcol = NULL
internalValues$vlabccheck = F
internalValues$vlabcolfactors = NULL
internalValues$markgroups = NULL
internalValues$tables <- values$Networks[[internalValues$active]]$tables
internalValues$graph <- values$Networks[[internalValues$active]]$graph
# if(!is.null(V(internalValues$activelayout$graph)$x__coord)
# && !is.null(V(internalValues$activelayout$graph)$y__coord)){
#
# internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# V(internalValues$activelayout$graph)$y__coord),
# ncol = 2))
#
#
#
# }else{
#generate the initial layout if needed
# res <- layout_components_qgraph(internalValues$graph, eval(parse(text = values$GlobalOpts$graph.layouts.selected)))# qgraph::qgraph.layout.fruchtermanreingold)
internalValues$layouts <- values$Networks[[internalValues$active]]$graphLayouts
internalValues$activelayout$graph <- internalValues$graph
internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
# }
colnames(internalValues$activelayout$layout) <- c("x", "y")
#if there are subgraphs, start in overview mode
if(length(internalValues$layouts$subgraphs) > 1){internalValues$overview <- T}
#set the maximum x axis range to cover the spectrum data
internalValues$maxxrange <- c(-1,1)#range(internalValues$activelayout$layout[,1])
internalValues$maxyrange <- c(-1,1)#range(internalValues$activelayout$layout[,2])
internalValues$xrange <- c(-1,1)#range(internalValues$activelayout$layout[,1])
internalValues$yrange <- c(-1,1)#range(internalValues$activelayout$layout[,2])
}
})
output$netinfo <- renderUI({
if(!is.null(reactives()$active) && reactives()$active && !is.null(internalValues$graph)){
if(internalValues$overview && length(internalValues$hover$subgraph)){
p("Subgraph #", internalValues$hover$subgraph, "with ",
strong(vcount(internalValues$layouts$subgraphs[[internalValues$hover$subgraph]])),
"nodes and",
strong(ecount(internalValues$layouts$subgraphs[[internalValues$hover$subgraph]])),
"edges.")
}
else{
p(paste0(if(!is.null(internalValues$marker$vertex)){
paste0("Marker on ", input$vlabelsel," ", vertex_attr(internalValues$activelayout$graph,input$vlabelsel, internalValues$marker$vertex))
}
else{""},
if(!is.null(internalValues$hover$vertex)){
paste0(" Cursor on ",input$vlabelsel," ", vertex_attr(internalValues$activelayout$graph,input$vlabelsel, internalValues$hover$vertex))
}else{""}
))
}
}
})
output$controls <- renderUI({
if(!is.null(reactives()$active) && reactives()$active && !is.null(internalValues$activelayout$graph)){
tagList(
fluidRow(
if(!static$noSelection){column(4,
htmlOutput(ns("activenetwork")))}else{tagList()},
column(if(!static$noSelection){2}else{3},
checkboxInput(ns('vlabelcheck'), "Show all node labels", value = internalValues$vlabelcheck),
selectizeInput(ns("vlabelsel"), "Node Labels",
choices = names(vertex_attr(internalValues$activelayout$graph)),
selected = internalValues$vlabels)
),
column(if(!static$noSelection){2}else{3},
checkboxInput(ns('elabelcheck'), "Show all edge labels", value = internalValues$elabelcheck),
selectizeInput(ns("elabelsel"), "Edge Labels",
choices = names(edge_attr(internalValues$activelayout$graph)),
selected = internalValues$elabels)
),
column(if(!static$noSelection){2}else{3},
checkboxInput(ns('vlabccheck'), "Color-code nodes", value = internalValues$vlabccheck),
selectizeInput(ns("vlabelcol"), "Node Colors",
choices = c(NULL, names(vertex_attr(internalValues$activelayout$graph))),
selected = internalValues$vlabelc)
),
column(if(!static$noSelection){2}else{3},
fluidRow(
div(style="display:inline-block", title = "Activate interactive highlighting on the network plot when hovering or selecting items in the feature table. Poor performance for large networks.",
checkboxInput(ns('hoveractive'), "Highlights", value = internalValues$hoverActive)),
div(style="display:inline-block",title = "Use log10 scale for Node Color scales.",
checkboxInput(ns('logscale'), "log", value = internalValues$logscale)),
div(style="display:inline-block",title = "Show processing history of this network",
MseekHistoryWidgetUI(ns("nethistory"))),
div(style="display:inline-block",
MatchReferenceModuleUI(ns("matchref")))
),
fluidRow(sliderInput(ns("seledges"), "Filter edges",
min = 0, max = 1,
value = c(0,1) #internalValues$sliderValues
)
))
),
fluidRow(
selectizeInput(ns('selectedLayout'), 'Network Layout',
selected = values$GlobalOpts$graph.layouts.selected,
choices = values$GlobalOpts$graph.layouts.available,
multiple = FALSE)
)
)
}
})
observeEvent(input$selectedLayout,{
values$GlobalOpts$graph.layouts.selected <- input$selectedLayout
})
observeEvent(values$GlobalOpts$graph.layouts.selected,{
if(length(internalValues$active) && internalValues$active %in% names(values$Networks)){
values$Networks[[internalValues$active]] <- setLayout(values$Networks[[internalValues$active]],
layoutFunction = values$GlobalOpts$graph.layouts.selected )
}
})
observeEvent(input$hoveractive,{internalValues$hoverActive <- input$hoveractive})
observeEvent(input$logscale,{internalValues$logscale <- input$logscale})
observeEvent(input$vlabelcheck,{internalValues$vlabelcheck <- input$vlabelcheck})
observeEvent(input$seledges,{internalValues$sliderValues <- input$seledges})
observeEvent(input$vlabccheck,{
internalValues$vlabccheck <- input$vlabccheck
if(input$vlabccheck){
internalValues$vlabcolfactors <- as.factor(vertex_attr(internalValues$graph,input$vlabelcol))
}
})
observeEvent(input$elabelcheck,{internalValues$elabelcheck <- input$elabelcheck})
observeEvent(input$vlabelsel,{internalValues$vlabels <- input$vlabelsel})
observeEvent(input$vlabelcol,{internalValues$vlabelc <- input$vlabelcol
if(input$vlabccheck){
internalValues$vlabcolfactors <- as.factor(vertex_attr(internalValues$graph,input$vlabelcol))
}
})
observeEvent(input$elabelsel,{internalValues$elabels <- input$elabelsel})
output$nettables <- renderUI({
if(!is.null(reactives()$active)
&& reactives()$active
&& !is.null(internalValues$activelayout)){
selectizeInput(ns('tabs'), "Show network table", choices = c("","nodes", "edges"), selected = internalValues$activeTab)
}
})
observeEvent(input$tabs,{
internalValues$activeTab <- input$tabs
})
output$Netw <- renderPlot({
if(reactives()$active
&& !is.null(internalValues$activelayout$graph)){
#sc()
# make color vectors here (so that graph is not changed! -> infinite loop)
# set all frame color to black
fc <- rep("black", times = vcount(internalValues$activelayout$graph))
#set all edge colors to black
ec <- rep("black",
times = ecount(internalValues$activelayout$graph))
#set all vertex colors
if(internalValues$vlabccheck){
if(!is.numeric(vertex_attr(internalValues$activelayout$graph,input$vlabelcol))
#|| length(unique(vertex_attr(internalValues$activelayout$graph,input$vlabelcol))) <= 5
){
if(internalValues$overview){
vc <- Mseek.colors(n = length(levels(internalValues$vlabcolfactors)), alpha = 1)[internalValues$vlabcolfactors]
#make sure subgraphs use same color scheme as overview:
}else{
colassign <- as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelcol))
for (l in seq(length(levels(internalValues$vlabcolfactors)))){
sel <- which(colassign == levels(internalValues$vlabcolfactors)[l])
if(length(sel) >0){
colassign[sel] <- l
}
}
vc <- Mseek.colors(n = length(levels(internalValues$vlabcolfactors)), alpha = 1)[as.integer(colassign)]
}
}else{
if(internalValues$logscale){
vc <- assignColor(safelog(vertex_attr(internalValues$activelayout$graph,input$vlabelcol)),
internalValues$colscale,
manualRange = safelog(vertex_attr(internalValues$graph,input$vlabelcol)),
center = 0)
}else{
vc <- assignColor((vertex_attr(internalValues$activelayout$graph,input$vlabelcol)),
internalValues$colscale,
manualRange = (vertex_attr(internalValues$graph,input$vlabelcol)),
center = NULL)
}
}
}else{
vc <- rep("olivedrab1", times = vcount(internalValues$activelayout$graph))
}
#edge labels
elabs <- if(internalValues$elabelcheck){
if(is.numeric(edge_attr(internalValues$activelayout$graph,input$elabelsel))){
round(edge_attr(internalValues$activelayout$graph,input$elabelsel),2)}
else{edge_attr(internalValues$activelayout$graph,input$elabelsel)}
}else{rep(NA, times = ecount(internalValues$activelayout$graph))}
#edge label color and font
elabc <- rep("blue", times = ecount(internalValues$activelayout$graph))
elabf <- rep(1, times = ecount(internalValues$activelayout$graph))
#vertex labels
vlabs <- if(internalValues$vlabelcheck){
if(is.numeric(vertex_attr(internalValues$activelayout$graph,input$vlabelsel))){
as.character(round(vertex_attr(internalValues$activelayout$graph,input$vlabelsel), 5))
}else{
as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel))
}
}else{rep(NA, times = vcount(internalValues$activelayout$graph))}
#vertex label color and font
vlabc <- rep("black", times = vcount(internalValues$activelayout$graph))
vlabf <- rep( 2, times = vcount(internalValues$activelayout$graph))
#recolor based on hovering
if(!is.null(internalValues$hover) && !internalValues$overview){
#which vortex is hovered over
sel <- internalValues$hover$vertex
neigh <- neighbors(internalValues$activelayout$graph, V(internalValues$activelayout$graph)[sel] )
edg <- incident(internalValues$activelayout$graph,V(internalValues$activelayout$graph)[sel])
#recolor
fc[sel] <- "cyan"
fc[neigh] <- "lightcyan3"
ec[edg] <- "cyan"
elabs[edg] <- if(is.numeric(edge_attr(internalValues$activelayout$graph,input$elabelsel))){
round(edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg],2)}
else{edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg]}
elabc[edg] <- "blue"
elabf[edg] <- 2
vlabs[c(sel,neigh)] <- if(is.numeric(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)])){
as.character(round(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)], 5))
}else{as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)])}
vlabc[c(sel,neigh)] <- "black"
vlabf[sel] <- 4
}
#recolor based on marking (overrides hover colors)
if(!is.null(internalValues$marker) && !internalValues$overview){
sel <- internalValues$marker$vertex
neigh <- neighbors(internalValues$activelayout$graph, V(internalValues$activelayout$graph)[sel] )
edg <- incident(internalValues$activelayout$graph,V(internalValues$activelayout$graph)[sel])
fc[sel] <- "red"
fc[neigh] <- "orange"
#vc[sel] <- "indianred3"
#vc[neigh] <- "indianred1"
ec[edg] <- "red"
elabs[edg] <- if(is.numeric(edge_attr(internalValues$activelayout$graph,input$elabelsel))){
round(edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg],2)}
else{edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg]}
elabc[edg] <- "darkorange2"
elabf[edg] <- 2
vlabs[c(sel,neigh)] <- as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)])
vlabc[c(sel,neigh)] <- "black"
vlabf[sel] <- 4
}
#scale node width based on label width
if(!internalValues$overview){
scalingH <- 70/sqrt(vcount(internalValues$activelayout$graph))
scalingV <- (70/sqrt(vcount(internalValues$activelayout$graph)))/1.414
# scalingH <- max(420*max(strwidth(vlabs, units = "figure")),
# #420*strwidth(as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[1]),
# # units = "figure")
# 420*max(strwidth("A", units = "figure"))
# )
# scalingV <- 550*strheight(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[1], units = "figure")
#
}else{
#in overview mode, just show squares with pleasant aspect ratio
scalingH <- 70/sqrt(vcount(internalValues$activelayout$graph))
scalingV <- (70/sqrt(vcount(internalValues$activelayout$graph)))/1.414
}
ew <- rep(2, ecount(internalValues$activelayout$graph))
if(length(internalValues$sliderValues) > 0){
hidethese <- which(edge_attr(internalValues$activelayout$graph,"cosine") < min(internalValues$sliderValues)
| edge_attr(internalValues$activelayout$graph,"cosine") > max(internalValues$sliderValues))
ew[hidethese] <- 0
elabs [hidethese] <- ""
}
if(length(internalValues$highlights) >0 ){
vc[internalValues$highlights] <- "red"
}
plot(internalValues$activelayout$graph,
xlim = internalValues$xrange,
ylim = internalValues$yrange,
mark.groups = internalValues$markgroups,
mark.expand = 1,
vertex.size = scalingH,
vertex.size2 = scalingV,
vertex.frame.color = fc,
vertex.color = vc,
vertex.shape = "circle",#"rectangle",
#this alone does not improve plotting speed:
# edge.lty = if(length(elabs) > 5000){0}else{1},
edge.label= elabs,
edge.label.family = "sans",
edge.label.color = elabc,
edge.label.font = elabf,
edge.color = ec,
edge.width = ew,
vertex.label = vlabs,
vertex.label.family = "sans",
vertex.label.color = vlabc,
vertex.label.font = vlabf,
main = if(internalValues$overview){"Overview"}else{NULL},
margin = 0,
rescale = F,
layout=
internalValues$activelayout$layout
)
internalValues$recordedPlot <- recordPlot()
}
}, height = 900)
output$ColorLegend <- renderPlot({
if(internalValues$vlabccheck){
if(!is.numeric(vertex_attr(internalValues$graph,input$vlabelcol))
#|| length(unique(vertex_attr(internalValues$graph,input$vlabelcol))) <= 5
){
colfacs <- as.factor(vertex_attr(internalValues$graph,input$vlabelcol))
cols <- Mseek.colors(n = length(levels(colfacs)), alpha = 1)
legendplot("center",
legend = as.character(levels(colfacs)),
fill = cols,
col = "black", bty = "n",
cex = 1, horiz = T)
}else{
if(internalValues$logscale){
legendranges <- safelog(vertex_attr(internalValues$graph,input$vlabelcol))
legendranges <- range(legendranges[is.finite(legendranges)])
}else{
legendranges <- vertex_attr(internalValues$graph,input$vlabelcol)
legendranges <- range(legendranges[is.finite(legendranges)])
}
legendranges <- seq(min(na.omit(legendranges)),
max(na.omit(legendranges)),
length.out = 200)
colorRampLegend(legendranges,
assignColor(legendranges,
internalValues$colscale,
manualRange = legendranges,
center = if(internalValues$logscale){0}else{NULL}),
#internalValues$colscale,
input$vlabelcol)
}
}
}, height = 85)
observeEvent(input$Netw_click,{
if (length(keys())>0 && keys() == 16) {
internalValues$marker <- nearPoints(as.data.frame(internalValues$activelayout$layout),
input$Netw_click,
xvar = "x",
yvar = "y",
threshold = 100,
maxpoints = 1)
internalValues$marker$vertex <- which(internalValues$activelayout$layout[,1] == internalValues$marker$x
& internalValues$activelayout$layout[,2] == internalValues$marker$y)
#selecting a subgraph and setting up plot for it
if (internalValues$overview) {
subg <- findsubgraph(V(internalValues$activelayout$graph)$fixed__id[internalValues$marker$vertex], internalValues$layouts$subgraphs)
#record which subgraph is selected
internalValues$activelayout$subg <- subg
internalValues$activelayout$graph <- internalValues$layouts$subgraphs[[subg]]
# if(!is.null(V(internalValues$activelayout$graph)$x__coord)
# && !is.null(V(internalValues$activelayout$graph)$y__coord)){
# internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# V(internalValues$activelayout$graph)$y__coord),
# ncol = 2))
#
# }else{
internalValues$activelayout$layout <- norm_coords(as.matrix(internalValues$layouts$sublayouts[[subg]]))
# }
colnames(internalValues$activelayout$layout) <- c("x", "y")
internalValues$hover <- NULL
internalValues$marker <- NULL
internalValues$markgroups <- NULL
internalValues$overview <- F
internalValues$xrange <- internalValues$maxxrange
internalValues$yrange <- internalValues$maxyrange
}
}
#replacement for doubleclick zoom-in or zoom-out: press Z and click.
if (length(keys())>0 && keys() == 90) {
if (!is.null(input$Netw_brush)) {
internalValues$xrange <- c(input$Netw_brush$xmin, input$Netw_brush$xmax)
internalValues$yrange <- c(input$Netw_brush$ymin, input$Netw_brush$ymax)
} else {
#switch back into overview mode on doubleclick in subgraph if full xy range is shown in current plot
if(internalValues$xrange == internalValues$maxxrange
&& internalValues$yrange == internalValues$maxyrange
&& !internalValues$overview){
internalValues$activelayout$graph <- internalValues$graph
internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
# internalValues$activelayout$graph <- disjoint_union(internalValues$layouts$subgraphs)#internalValues$graph
# #update large layout with new coords from changes in subgraphs, but only if there is no predefined layout
# # if(is.null(V(internalValues$activelayout$graph)$x__coord)
# # || is.null(V(internalValues$activelayout$graph)$y__coord)){
# internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs,
# internalValues$layouts$sublayouts)
# internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
#
# # }else{
# # internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# # V(internalValues$activelayout$graph)$y__coord),
# # ncol = 2))
# # }
#update large layout with new coords from changes in subgraphs
#internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs, internalValues$layouts$sublayouts)
#internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
colnames(internalValues$activelayout$layout) <- c("x", "y")
internalValues$overview <- T
internalValues$hover <- NULL
internalValues$marker <- NULL
}
internalValues$xrange <- internalValues$maxxrange
internalValues$yrange <- internalValues$maxyrange
}
}
})
observeEvent(input$Netw_brush,{
# if(is.null(input$Netw_brush)){
# internalValues$hover <-
if (length(keys())>0 && keys() == 17) {
xs <- c(input$Netw_brush$xmin,input$Netw_brush$xmax)
ys <- c(input$Netw_brush$ymin,input$Netw_brush$ymax)
internalValues$hover$x<- xs[which.max(abs(xs-internalValues$hover$x))]
internalValues$hover$y<- ys[which.max(abs(ys-internalValues$hover$y))]
internalValues$activelayout$layout[internalValues$hover$vertex,1] <- internalValues$hover$x
internalValues$activelayout$layout[internalValues$hover$vertex,2] <- internalValues$hover$y
internalValues$layouts$sublayouts[[internalValues$activelayout$subg]] <- internalValues$activelayout$layout
}
})
observeEvent(input$Netw_hover,{
if(internalValues$hoverActive && is.null(input$Netw_brush) && !(length(keys())>0 && keys() == 17)){
internalValues$hover <- nearPoints(as.data.frame(internalValues$activelayout$layout),
input$Netw_hover,
xvar = "x",
yvar = "y",
threshold = 100,
maxpoints = 1)
internalValues$hover$vertex <- which(internalValues$activelayout$layout[,1] == internalValues$hover$x
& internalValues$activelayout$layout[,2] == internalValues$hover$y)
if(internalValues$overview && !is.null(internalValues$hover)){
internalValues$hover$subgraph <- findsubgraph(V(internalValues$activelayout$graph)$fixed__id[internalValues$hover$vertex], internalValues$layouts$subgraphs)
}
marktemp <- if(internalValues$overview && !is.null(internalValues$hover)){
which(V(internalValues$activelayout$graph)$subcl == V(internalValues$activelayout$graph)$subcl[internalValues$hover$vertex])
}else{NULL}
internalValues$markgroups <- if(length(marktemp)>0){marktemp}else{NULL}
}
})
observeEvent(input$Netw_dblclick, {
internalValues$dblclick <- input$Netw_dblclick
if (!is.null(input$Netw_brush)) {
internalValues$xrange <- c(input$Netw_brush$xmin, input$Netw_brush$xmax)
internalValues$yrange <- c(input$Netw_brush$ymin, input$Netw_brush$ymax)
} else {
#switch back into overview mode on doubleclick in subgraph if full xy range is shown in current plot
if(internalValues$xrange == internalValues$maxxrange
&& internalValues$yrange == internalValues$maxyrange
&& !internalValues$overview){
internalValues$activelayout$graph <- internalValues$graph
internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
# internalValues$activelayout$graph <- disjoint_union(internalValues$layouts$subgraphs)#internalValues$graph
# #update large layout with new coords from changes in subgraphs, but only if there is no predefined layout
# # if(is.null(V(internalValues$activelayout$graph)$x__coord)
# # || is.null(V(internalValues$activelayout$graph)$y__coord)){
# internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs,
# internalValues$layouts$sublayouts)
# internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
#
# # }else{
# # internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# # V(internalValues$activelayout$graph)$y__coord),
# # ncol = 2))
# # }
#update large layout with new coords from changes in subgraphs
#internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs, internalValues$layouts$sublayouts)
#internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
colnames(internalValues$activelayout$layout) <- c("x", "y")
internalValues$overview <- T
internalValues$hover <- NULL
internalValues$marker <- NULL
}
internalValues$xrange <- internalValues$maxxrange
internalValues$yrange <- internalValues$maxyrange
}})
showtable <- reactive({
if(length(internalValues$activelayout)
&& length(internalValues$activelayout$graph)){
if(internalValues$activeTab == "nodes"){
type.convert(as_data_frame(internalValues$activelayout$graph, "vertices"), as.is = T)
}else if(internalValues$activeTab == "edges"){
type.convert(as_data_frame(internalValues$activelayout$graph, "edges"), as.is = T)
}else{
NULL}
}else{
NULL
}
})
#Edge or Node table, now calculated on demand and for the currently shown subgraph
table1 <- callModule(TableModule,'nettab', tag = ns('nettab'), set = reactive({list(df = showtable(),
update = NULL,
layout = list(
perpage = 100,
height = 300,
readOnly = T,
contextMenu = F,
fixedColumnsLeft = 2,
format = list(col = c("RTStdErr"),
format = "0.000"),
invertReadOnly = NULL
))})
)
output$netAll <- renderUI({
if(!is.null(reactives()$active)
&& reactives()$active
&& !is.null(internalValues$graph)
){
fluidPage(
htmlOutput(ns('controls')),
fluidRow(
plotOutput(ns("Netw"),
click = ns("Netw_click"),
hover = hoverOpts(id = ns("Netw_hover"),
delay = 150),
dblclick = ns("Netw_dblclick"),
brush = brushOpts(
id = ns("Netw_brush"),
opacity = 0,
#direction = "x",
resetOnNew = TRUE),
height = "900px"#,
#width = "100%"
)
),
fluidRow(
plotOutput(ns("ColorLegend"), height = "85px")
),
fluidRow(
htmlOutput(ns("netinfo"))
)
,
hr(),
fluidRow(
htmlOutput(ns("nettables"))
),
fluidRow(
TableModuleUI(ns('nettab'))
)
)
}
})
return(internalValues)
}
#' @describeIn NetworkModule UI elements
#' @export
NetworkModuleUI <- function(id){
ns <- NS(id)
fluidPage(
htmlOutput(ns("netAll"))
)
}
mjhelf/Mosaic documentation built on April 28, 2022, 11:32 a.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 NetworkModuleUI NetworkModule
Documented in NetworkModule NetworkModuleUI
#' NetworkModule
#'
#' Visualize and interact with molecular networks
#'
#' TODO: standardize and split/simplify this module
#'
#' @describeIn NetworkModule server logic
#'
#' @inherit MseekModules
#' @param keys \code{reactive({})} that reports the current key press
#'
#' @return Returns its internalValues
#'
#' @export
NetworkModule <- function(input,output, session,
values = reactiveValues(Networks = NULL,
MSData = NULL),
reactives = reactive({list(active = T,
highlights = integer(0) # fixed__id values of nodes to be highlighted
)
}),
static = list(noSelection = T),
keys = reactive({"NO"})
){
ns <- NS(session$ns(NULL))
internalValues <- reactiveValues(graph = NULL,tables = NULL,
xrange = NULL, #the x axis range
yrange = NULL, #the y axis range
maxxrange = NULL, #maximum x axis range
maxyrange = NULL, #maximum y axis range
layouts = NULL,
activelayout = list(graph = NULL,
layout = NULL,
subg = NULL),
marker = NULL, #selected peak with $mz and $intensity
hover = NULL, #peak hovered over with $mz and $intensity
elabels = NULL,
elabelcheck = F,
vlabels = NULL,
vlabelcheck = F,
vlabelcol = NULL,
vlabccheck = F,
vlabcolfactors = NULL,
overview = F,
markgroups = NULL,
activeTab = "",
active = NULL, #which network is currently selected,
colscale = {crange <- colorRampPalette(c("blue", "gray", "red"))
crange(200) },
sliderValues = c(0,1),
highlights = integer(0),
hoverActive = T,
recordedPlot = NULL,
logscale = T,
regChange = "nothing"
)
callModule(MseekHistoryWidget, "nethistory", FT = reactive({
if(length(values$Networks)
&& length(internalValues$active)
&& internalValues$active %in% names(values$Networks)){
values$Networks[[internalValues$active]]
}else{NULL}
}),
buttonLabel = ""
)
callModule(MatchReferenceModule, "matchref", values = values)
output$activenetwork <- renderUI({
if(!static$noSelection){
selectizeInput(ns('activeNetwork'), 'Show Network',
selected = input$activeNetwork,
choices = names(values$Networks)[names(values$Networks) != "numNetworks"],
multiple = FALSE)
}
})
observeEvent(input$activeNetwork, {
if(!static$noSelection){
internalValues$active <- input$activeNetwork
}
})
observe({if(length(values$Networks)
&& length(internalValues$active)){
internalValues$regChange <- MseekHash(values$Networks[[internalValues$active]])
}else{
internalValues$regChange <- "nothing"}})
observeEvent(internalValues$regChange,{
#values$Networks[[internalValues$active]],{#c(internalValues$active),{
if(!is.null(values$Networks)
&& length(names(values$Networks)[names(values$Networks) != "numNetworks"]) > 0
# && !is.null(internalValues$active)
# && internalValues$active != ""
# && !is.null(values$Networks[[internalValues$active]]$graph)
){
if(is.null(internalValues$active)
|| is.na(internalValues$active)
|| internalValues$active == ""
|| is.null(values$Networks[[internalValues$active]]$graph)){
internalValues$active <- names(values$Networks)[names(values$Networks) != "numNetworks"][1]
}
internalValues$marker = NULL #selected peak with $mz and $intensity
internalValues$hover = NULL #peak hovered over with $mz and $intensity
internalValues$elabels = NULL
internalValues$elabelcheck = F
internalValues$vlabels = NULL
internalValues$vlabelcheck = F
internalValues$vlabelcol = NULL
internalValues$vlabccheck = F
internalValues$vlabcolfactors = NULL
internalValues$markgroups = NULL
internalValues$tables <- values$Networks[[internalValues$active]]$tables
internalValues$graph <- values$Networks[[internalValues$active]]$graph
# if(!is.null(V(internalValues$activelayout$graph)$x__coord)
# && !is.null(V(internalValues$activelayout$graph)$y__coord)){
#
# internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# V(internalValues$activelayout$graph)$y__coord),
# ncol = 2))
#
#
#
# }else{
#generate the initial layout if needed
# res <- layout_components_qgraph(internalValues$graph, eval(parse(text = values$GlobalOpts$graph.layouts.selected)))# qgraph::qgraph.layout.fruchtermanreingold)
internalValues$layouts <- values$Networks[[internalValues$active]]$graphLayouts
internalValues$activelayout$graph <- internalValues$graph
internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
# }
colnames(internalValues$activelayout$layout) <- c("x", "y")
#if there are subgraphs, start in overview mode
if(length(internalValues$layouts$subgraphs) > 1){internalValues$overview <- T}
#set the maximum x axis range to cover the spectrum data
internalValues$maxxrange <- c(-1,1)#range(internalValues$activelayout$layout[,1])
internalValues$maxyrange <- c(-1,1)#range(internalValues$activelayout$layout[,2])
internalValues$xrange <- c(-1,1)#range(internalValues$activelayout$layout[,1])
internalValues$yrange <- c(-1,1)#range(internalValues$activelayout$layout[,2])
}
})
output$netinfo <- renderUI({
if(!is.null(reactives()$active) && reactives()$active && !is.null(internalValues$graph)){
if(internalValues$overview && length(internalValues$hover$subgraph)){
p("Subgraph #", internalValues$hover$subgraph, "with ",
strong(vcount(internalValues$layouts$subgraphs[[internalValues$hover$subgraph]])),
"nodes and",
strong(ecount(internalValues$layouts$subgraphs[[internalValues$hover$subgraph]])),
"edges.")
}
else{
p(paste0(if(!is.null(internalValues$marker$vertex)){
paste0("Marker on ", input$vlabelsel," ", vertex_attr(internalValues$activelayout$graph,input$vlabelsel, internalValues$marker$vertex))
}
else{""},
if(!is.null(internalValues$hover$vertex)){
paste0(" Cursor on ",input$vlabelsel," ", vertex_attr(internalValues$activelayout$graph,input$vlabelsel, internalValues$hover$vertex))
}else{""}
))
}
}
})
output$controls <- renderUI({
if(!is.null(reactives()$active) && reactives()$active && !is.null(internalValues$activelayout$graph)){
tagList(
fluidRow(
if(!static$noSelection){column(4,
htmlOutput(ns("activenetwork")))}else{tagList()},
column(if(!static$noSelection){2}else{3},
checkboxInput(ns('vlabelcheck'), "Show all node labels", value = internalValues$vlabelcheck),
selectizeInput(ns("vlabelsel"), "Node Labels",
choices = names(vertex_attr(internalValues$activelayout$graph)),
selected = internalValues$vlabels)
),
column(if(!static$noSelection){2}else{3},
checkboxInput(ns('elabelcheck'), "Show all edge labels", value = internalValues$elabelcheck),
selectizeInput(ns("elabelsel"), "Edge Labels",
choices = names(edge_attr(internalValues$activelayout$graph)),
selected = internalValues$elabels)
),
column(if(!static$noSelection){2}else{3},
checkboxInput(ns('vlabccheck'), "Color-code nodes", value = internalValues$vlabccheck),
selectizeInput(ns("vlabelcol"), "Node Colors",
choices = c(NULL, names(vertex_attr(internalValues$activelayout$graph))),
selected = internalValues$vlabelc)
),
column(if(!static$noSelection){2}else{3},
fluidRow(
div(style="display:inline-block", title = "Activate interactive highlighting on the network plot when hovering or selecting items in the feature table. Poor performance for large networks.",
checkboxInput(ns('hoveractive'), "Highlights", value = internalValues$hoverActive)),
div(style="display:inline-block",title = "Use log10 scale for Node Color scales.",
checkboxInput(ns('logscale'), "log", value = internalValues$logscale)),
div(style="display:inline-block",title = "Show processing history of this network",
MseekHistoryWidgetUI(ns("nethistory"))),
div(style="display:inline-block",
MatchReferenceModuleUI(ns("matchref")))
),
fluidRow(sliderInput(ns("seledges"), "Filter edges",
min = 0, max = 1,
value = c(0,1) #internalValues$sliderValues
)
))
),
fluidRow(
selectizeInput(ns('selectedLayout'), 'Network Layout',
selected = values$GlobalOpts$graph.layouts.selected,
choices = values$GlobalOpts$graph.layouts.available,
multiple = FALSE)
)
)
}
})
observeEvent(input$selectedLayout,{
values$GlobalOpts$graph.layouts.selected <- input$selectedLayout
})
observeEvent(values$GlobalOpts$graph.layouts.selected,{
if(length(internalValues$active) && internalValues$active %in% names(values$Networks)){
values$Networks[[internalValues$active]] <- setLayout(values$Networks[[internalValues$active]],
layoutFunction = values$GlobalOpts$graph.layouts.selected )
}
})
observeEvent(input$hoveractive,{internalValues$hoverActive <- input$hoveractive})
observeEvent(input$logscale,{internalValues$logscale <- input$logscale})
observeEvent(input$vlabelcheck,{internalValues$vlabelcheck <- input$vlabelcheck})
observeEvent(input$seledges,{internalValues$sliderValues <- input$seledges})
observeEvent(input$vlabccheck,{
internalValues$vlabccheck <- input$vlabccheck
if(input$vlabccheck){
internalValues$vlabcolfactors <- as.factor(vertex_attr(internalValues$graph,input$vlabelcol))
}
})
observeEvent(input$elabelcheck,{internalValues$elabelcheck <- input$elabelcheck})
observeEvent(input$vlabelsel,{internalValues$vlabels <- input$vlabelsel})
observeEvent(input$vlabelcol,{internalValues$vlabelc <- input$vlabelcol
if(input$vlabccheck){
internalValues$vlabcolfactors <- as.factor(vertex_attr(internalValues$graph,input$vlabelcol))
}
})
observeEvent(input$elabelsel,{internalValues$elabels <- input$elabelsel})
output$nettables <- renderUI({
if(!is.null(reactives()$active)
&& reactives()$active
&& !is.null(internalValues$activelayout)){
selectizeInput(ns('tabs'), "Show network table", choices = c("","nodes", "edges"), selected = internalValues$activeTab)
}
})
observeEvent(input$tabs,{
internalValues$activeTab <- input$tabs
})
output$Netw <- renderPlot({
if(reactives()$active
&& !is.null(internalValues$activelayout$graph)){
#sc()
# make color vectors here (so that graph is not changed! -> infinite loop)
# set all frame color to black
fc <- rep("black", times = vcount(internalValues$activelayout$graph))
#set all edge colors to black
ec <- rep("black",
times = ecount(internalValues$activelayout$graph))
#set all vertex colors
if(internalValues$vlabccheck){
if(!is.numeric(vertex_attr(internalValues$activelayout$graph,input$vlabelcol))
#|| length(unique(vertex_attr(internalValues$activelayout$graph,input$vlabelcol))) <= 5
){
if(internalValues$overview){
vc <- Mseek.colors(n = length(levels(internalValues$vlabcolfactors)), alpha = 1)[internalValues$vlabcolfactors]
#make sure subgraphs use same color scheme as overview:
}else{
colassign <- as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelcol))
for (l in seq(length(levels(internalValues$vlabcolfactors)))){
sel <- which(colassign == levels(internalValues$vlabcolfactors)[l])
if(length(sel) >0){
colassign[sel] <- l
}
}
vc <- Mseek.colors(n = length(levels(internalValues$vlabcolfactors)), alpha = 1)[as.integer(colassign)]
}
}else{
if(internalValues$logscale){
vc <- assignColor(safelog(vertex_attr(internalValues$activelayout$graph,input$vlabelcol)),
internalValues$colscale,
manualRange = safelog(vertex_attr(internalValues$graph,input$vlabelcol)),
center = 0)
}else{
vc <- assignColor((vertex_attr(internalValues$activelayout$graph,input$vlabelcol)),
internalValues$colscale,
manualRange = (vertex_attr(internalValues$graph,input$vlabelcol)),
center = NULL)
}
}
}else{
vc <- rep("olivedrab1", times = vcount(internalValues$activelayout$graph))
}
#edge labels
elabs <- if(internalValues$elabelcheck){
if(is.numeric(edge_attr(internalValues$activelayout$graph,input$elabelsel))){
round(edge_attr(internalValues$activelayout$graph,input$elabelsel),2)}
else{edge_attr(internalValues$activelayout$graph,input$elabelsel)}
}else{rep(NA, times = ecount(internalValues$activelayout$graph))}
#edge label color and font
elabc <- rep("blue", times = ecount(internalValues$activelayout$graph))
elabf <- rep(1, times = ecount(internalValues$activelayout$graph))
#vertex labels
vlabs <- if(internalValues$vlabelcheck){
if(is.numeric(vertex_attr(internalValues$activelayout$graph,input$vlabelsel))){
as.character(round(vertex_attr(internalValues$activelayout$graph,input$vlabelsel), 5))
}else{
as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel))
}
}else{rep(NA, times = vcount(internalValues$activelayout$graph))}
#vertex label color and font
vlabc <- rep("black", times = vcount(internalValues$activelayout$graph))
vlabf <- rep( 2, times = vcount(internalValues$activelayout$graph))
#recolor based on hovering
if(!is.null(internalValues$hover) && !internalValues$overview){
#which vortex is hovered over
sel <- internalValues$hover$vertex
neigh <- neighbors(internalValues$activelayout$graph, V(internalValues$activelayout$graph)[sel] )
edg <- incident(internalValues$activelayout$graph,V(internalValues$activelayout$graph)[sel])
#recolor
fc[sel] <- "cyan"
fc[neigh] <- "lightcyan3"
ec[edg] <- "cyan"
elabs[edg] <- if(is.numeric(edge_attr(internalValues$activelayout$graph,input$elabelsel))){
round(edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg],2)}
else{edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg]}
elabc[edg] <- "blue"
elabf[edg] <- 2
vlabs[c(sel,neigh)] <- if(is.numeric(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)])){
as.character(round(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)], 5))
}else{as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)])}
vlabc[c(sel,neigh)] <- "black"
vlabf[sel] <- 4
}
#recolor based on marking (overrides hover colors)
if(!is.null(internalValues$marker) && !internalValues$overview){
sel <- internalValues$marker$vertex
neigh <- neighbors(internalValues$activelayout$graph, V(internalValues$activelayout$graph)[sel] )
edg <- incident(internalValues$activelayout$graph,V(internalValues$activelayout$graph)[sel])
fc[sel] <- "red"
fc[neigh] <- "orange"
#vc[sel] <- "indianred3"
#vc[neigh] <- "indianred1"
ec[edg] <- "red"
elabs[edg] <- if(is.numeric(edge_attr(internalValues$activelayout$graph,input$elabelsel))){
round(edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg],2)}
else{edge_attr(internalValues$activelayout$graph,input$elabelsel)[edg]}
elabc[edg] <- "darkorange2"
elabf[edg] <- 2
vlabs[c(sel,neigh)] <- as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[c(sel,neigh)])
vlabc[c(sel,neigh)] <- "black"
vlabf[sel] <- 4
}
#scale node width based on label width
if(!internalValues$overview){
scalingH <- 70/sqrt(vcount(internalValues$activelayout$graph))
scalingV <- (70/sqrt(vcount(internalValues$activelayout$graph)))/1.414
# scalingH <- max(420*max(strwidth(vlabs, units = "figure")),
# #420*strwidth(as.character(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[1]),
# # units = "figure")
# 420*max(strwidth("A", units = "figure"))
# )
# scalingV <- 550*strheight(vertex_attr(internalValues$activelayout$graph,input$vlabelsel)[1], units = "figure")
#
}else{
#in overview mode, just show squares with pleasant aspect ratio
scalingH <- 70/sqrt(vcount(internalValues$activelayout$graph))
scalingV <- (70/sqrt(vcount(internalValues$activelayout$graph)))/1.414
}
ew <- rep(2, ecount(internalValues$activelayout$graph))
if(length(internalValues$sliderValues) > 0){
hidethese <- which(edge_attr(internalValues$activelayout$graph,"cosine") < min(internalValues$sliderValues)
| edge_attr(internalValues$activelayout$graph,"cosine") > max(internalValues$sliderValues))
ew[hidethese] <- 0
elabs [hidethese] <- ""
}
if(length(internalValues$highlights) >0 ){
vc[internalValues$highlights] <- "red"
}
plot(internalValues$activelayout$graph,
xlim = internalValues$xrange,
ylim = internalValues$yrange,
mark.groups = internalValues$markgroups,
mark.expand = 1,
vertex.size = scalingH,
vertex.size2 = scalingV,
vertex.frame.color = fc,
vertex.color = vc,
vertex.shape = "circle",#"rectangle",
#this alone does not improve plotting speed:
# edge.lty = if(length(elabs) > 5000){0}else{1},
edge.label= elabs,
edge.label.family = "sans",
edge.label.color = elabc,
edge.label.font = elabf,
edge.color = ec,
edge.width = ew,
vertex.label = vlabs,
vertex.label.family = "sans",
vertex.label.color = vlabc,
vertex.label.font = vlabf,
main = if(internalValues$overview){"Overview"}else{NULL},
margin = 0,
rescale = F,
layout=
internalValues$activelayout$layout
)
internalValues$recordedPlot <- recordPlot()
}
}, height = 900)
output$ColorLegend <- renderPlot({
if(internalValues$vlabccheck){
if(!is.numeric(vertex_attr(internalValues$graph,input$vlabelcol))
#|| length(unique(vertex_attr(internalValues$graph,input$vlabelcol))) <= 5
){
colfacs <- as.factor(vertex_attr(internalValues$graph,input$vlabelcol))
cols <- Mseek.colors(n = length(levels(colfacs)), alpha = 1)
legendplot("center",
legend = as.character(levels(colfacs)),
fill = cols,
col = "black", bty = "n",
cex = 1, horiz = T)
}else{
if(internalValues$logscale){
legendranges <- safelog(vertex_attr(internalValues$graph,input$vlabelcol))
legendranges <- range(legendranges[is.finite(legendranges)])
}else{
legendranges <- vertex_attr(internalValues$graph,input$vlabelcol)
legendranges <- range(legendranges[is.finite(legendranges)])
}
legendranges <- seq(min(na.omit(legendranges)),
max(na.omit(legendranges)),
length.out = 200)
colorRampLegend(legendranges,
assignColor(legendranges,
internalValues$colscale,
manualRange = legendranges,
center = if(internalValues$logscale){0}else{NULL}),
#internalValues$colscale,
input$vlabelcol)
}
}
}, height = 85)
observeEvent(input$Netw_click,{
if (length(keys())>0 && keys() == 16) {
internalValues$marker <- nearPoints(as.data.frame(internalValues$activelayout$layout),
input$Netw_click,
xvar = "x",
yvar = "y",
threshold = 100,
maxpoints = 1)
internalValues$marker$vertex <- which(internalValues$activelayout$layout[,1] == internalValues$marker$x
& internalValues$activelayout$layout[,2] == internalValues$marker$y)
#selecting a subgraph and setting up plot for it
if (internalValues$overview) {
subg <- findsubgraph(V(internalValues$activelayout$graph)$fixed__id[internalValues$marker$vertex], internalValues$layouts$subgraphs)
#record which subgraph is selected
internalValues$activelayout$subg <- subg
internalValues$activelayout$graph <- internalValues$layouts$subgraphs[[subg]]
# if(!is.null(V(internalValues$activelayout$graph)$x__coord)
# && !is.null(V(internalValues$activelayout$graph)$y__coord)){
# internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# V(internalValues$activelayout$graph)$y__coord),
# ncol = 2))
#
# }else{
internalValues$activelayout$layout <- norm_coords(as.matrix(internalValues$layouts$sublayouts[[subg]]))
# }
colnames(internalValues$activelayout$layout) <- c("x", "y")
internalValues$hover <- NULL
internalValues$marker <- NULL
internalValues$markgroups <- NULL
internalValues$overview <- F
internalValues$xrange <- internalValues$maxxrange
internalValues$yrange <- internalValues$maxyrange
}
}
#replacement for doubleclick zoom-in or zoom-out: press Z and click.
if (length(keys())>0 && keys() == 90) {
if (!is.null(input$Netw_brush)) {
internalValues$xrange <- c(input$Netw_brush$xmin, input$Netw_brush$xmax)
internalValues$yrange <- c(input$Netw_brush$ymin, input$Netw_brush$ymax)
} else {
#switch back into overview mode on doubleclick in subgraph if full xy range is shown in current plot
if(internalValues$xrange == internalValues$maxxrange
&& internalValues$yrange == internalValues$maxyrange
&& !internalValues$overview){
internalValues$activelayout$graph <- internalValues$graph
internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
# internalValues$activelayout$graph <- disjoint_union(internalValues$layouts$subgraphs)#internalValues$graph
# #update large layout with new coords from changes in subgraphs, but only if there is no predefined layout
# # if(is.null(V(internalValues$activelayout$graph)$x__coord)
# # || is.null(V(internalValues$activelayout$graph)$y__coord)){
# internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs,
# internalValues$layouts$sublayouts)
# internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
#
# # }else{
# # internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# # V(internalValues$activelayout$graph)$y__coord),
# # ncol = 2))
# # }
#update large layout with new coords from changes in subgraphs
#internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs, internalValues$layouts$sublayouts)
#internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
colnames(internalValues$activelayout$layout) <- c("x", "y")
internalValues$overview <- T
internalValues$hover <- NULL
internalValues$marker <- NULL
}
internalValues$xrange <- internalValues$maxxrange
internalValues$yrange <- internalValues$maxyrange
}
}
})
observeEvent(input$Netw_brush,{
# if(is.null(input$Netw_brush)){
# internalValues$hover <-
if (length(keys())>0 && keys() == 17) {
xs <- c(input$Netw_brush$xmin,input$Netw_brush$xmax)
ys <- c(input$Netw_brush$ymin,input$Netw_brush$ymax)
internalValues$hover$x<- xs[which.max(abs(xs-internalValues$hover$x))]
internalValues$hover$y<- ys[which.max(abs(ys-internalValues$hover$y))]
internalValues$activelayout$layout[internalValues$hover$vertex,1] <- internalValues$hover$x
internalValues$activelayout$layout[internalValues$hover$vertex,2] <- internalValues$hover$y
internalValues$layouts$sublayouts[[internalValues$activelayout$subg]] <- internalValues$activelayout$layout
}
})
observeEvent(input$Netw_hover,{
if(internalValues$hoverActive && is.null(input$Netw_brush) && !(length(keys())>0 && keys() == 17)){
internalValues$hover <- nearPoints(as.data.frame(internalValues$activelayout$layout),
input$Netw_hover,
xvar = "x",
yvar = "y",
threshold = 100,
maxpoints = 1)
internalValues$hover$vertex <- which(internalValues$activelayout$layout[,1] == internalValues$hover$x
& internalValues$activelayout$layout[,2] == internalValues$hover$y)
if(internalValues$overview && !is.null(internalValues$hover)){
internalValues$hover$subgraph <- findsubgraph(V(internalValues$activelayout$graph)$fixed__id[internalValues$hover$vertex], internalValues$layouts$subgraphs)
}
marktemp <- if(internalValues$overview && !is.null(internalValues$hover)){
which(V(internalValues$activelayout$graph)$subcl == V(internalValues$activelayout$graph)$subcl[internalValues$hover$vertex])
}else{NULL}
internalValues$markgroups <- if(length(marktemp)>0){marktemp}else{NULL}
}
})
observeEvent(input$Netw_dblclick, {
internalValues$dblclick <- input$Netw_dblclick
if (!is.null(input$Netw_brush)) {
internalValues$xrange <- c(input$Netw_brush$xmin, input$Netw_brush$xmax)
internalValues$yrange <- c(input$Netw_brush$ymin, input$Netw_brush$ymax)
} else {
#switch back into overview mode on doubleclick in subgraph if full xy range is shown in current plot
if(internalValues$xrange == internalValues$maxxrange
&& internalValues$yrange == internalValues$maxyrange
&& !internalValues$overview){
internalValues$activelayout$graph <- internalValues$graph
internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
# internalValues$activelayout$graph <- disjoint_union(internalValues$layouts$subgraphs)#internalValues$graph
# #update large layout with new coords from changes in subgraphs, but only if there is no predefined layout
# # if(is.null(V(internalValues$activelayout$graph)$x__coord)
# # || is.null(V(internalValues$activelayout$graph)$y__coord)){
# internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs,
# internalValues$layouts$sublayouts)
# internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
#
# # }else{
# # internalValues$activelayout$layout <- norm_coords(matrix(c( V(internalValues$activelayout$graph)$x__coord,
# # V(internalValues$activelayout$graph)$y__coord),
# # ncol = 2))
# # }
#update large layout with new coords from changes in subgraphs
#internalValues$layouts$layout <- merge_coords(internalValues$layouts$subgraphs, internalValues$layouts$sublayouts)
#internalValues$activelayout$layout <- norm_coords(internalValues$layouts$layout)
colnames(internalValues$activelayout$layout) <- c("x", "y")
internalValues$overview <- T
internalValues$hover <- NULL
internalValues$marker <- NULL
}
internalValues$xrange <- internalValues$maxxrange
internalValues$yrange <- internalValues$maxyrange
}})
showtable <- reactive({
if(length(internalValues$activelayout)
&& length(internalValues$activelayout$graph)){
if(internalValues$activeTab == "nodes"){
type.convert(as_data_frame(internalValues$activelayout$graph, "vertices"), as.is = T)
}else if(internalValues$activeTab == "edges"){
type.convert(as_data_frame(internalValues$activelayout$graph, "edges"), as.is = T)
}else{
NULL}
}else{
NULL
}
})
#Edge or Node table, now calculated on demand and for the currently shown subgraph
table1 <- callModule(TableModule,'nettab', tag = ns('nettab'), set = reactive({list(df = showtable(),
update = NULL,
layout = list(
perpage = 100,
height = 300,
readOnly = T,
contextMenu = F,
fixedColumnsLeft = 2,
format = list(col = c("RTStdErr"),
format = "0.000"),
invertReadOnly = NULL
))})
)
output$netAll <- renderUI({
if(!is.null(reactives()$active)
&& reactives()$active
&& !is.null(internalValues$graph)
){
fluidPage(
htmlOutput(ns('controls')),
fluidRow(
plotOutput(ns("Netw"),
click = ns("Netw_click"),
hover = hoverOpts(id = ns("Netw_hover"),
delay = 150),
dblclick = ns("Netw_dblclick"),
brush = brushOpts(
id = ns("Netw_brush"),
opacity = 0,
#direction = "x",
resetOnNew = TRUE),
height = "900px"#,
#width = "100%"
)
),
fluidRow(
plotOutput(ns("ColorLegend"), height = "85px")
),
fluidRow(
htmlOutput(ns("netinfo"))
)
,
hr(),
fluidRow(
htmlOutput(ns("nettables"))
),
fluidRow(
TableModuleUI(ns('nettab'))
)
)
}
})
return(internalValues)
}
#' @describeIn NetworkModule UI elements
#' @export
NetworkModuleUI <- function(id){
ns <- NS(id)
fluidPage(
htmlOutput(ns("netAll"))
)
}
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.