I have constructed multiple protein - protein networks for diseases in shiny app and I ploted them using visnetwork. I found the articulation points for each network and I want to remove them.
My code for a disease looks like this:
output$plot54 <- renderVisNetwork({
alsex <- as.matrix(alsex)
sel1 <- alsex[,1]
sel2 <- alsex[,2]
n10 <- unique(c(sel1,sel2))
n10 <- as.data.frame(n10)
colnames(n10) <- "id"
ed10 <- as.data.frame(alsex)
colnames(ed10) <- c("from", "to", "width")
n10
g <- graph_from_data_frame(ed10)
articulation.points(g)
nodes4 <- data.frame(n10, color = ifelse(n10$id=="CLEC4E"|n10$id=="ACE2"|n10$id=="MYO7A"|n10$id=="HSPB4"
|n10$id=="EXOSC3"|n10$id=="RBM45"|n10$id=="SPAST"|n10$id=="ALMS1"|n10$id=="PIGQ"
|n10$id=="CDC27"|n10$id=="GFM1"|n10$id=="UTRN"|n10$id=="RAB7B"|n10$id=="GSN"|n10$id=="VAPA"|n10$id=="GLE1"
|n10$id=="FA2H"|n10$id=="HSPA4"|n10$id=="SNCA"|n10$id=="RAB5A"|n10$id=="SETX","red","blue"))
visNetwork(nodes4, ed10, main = "Articulation Points") %>%
visNodes (color = list(highlight = "pink"))%>%
visIgraphLayout()%>%
visOptions(highlightNearest = list(enabled = T, hover = T),
nodesIdSelection = T)%>%
visInteraction(keyboard = TRUE)
})
observe({
input$delete54
visNetworkProxy("plot54") %>%
visRemoveNodes(id="CLEC4E")%>%visRemoveEdges(id = "CLEC4E")%>%
visRemoveNodes(id="ACE2")%>%visRemoveEdges(id = "ACE2")%>%
visRemoveNodes(id="MYO7A")%>%visRemoveEdges(id = "MYO7A")%>%
visRemoveNodes(id="HSPB4")%>%visRemoveEdges(id = "HSPB4")%>%
visRemoveNodes(id="EXOSC3")%>%visRemoveEdges(id = "EXOSC3")%>%
visRemoveNodes(id="RBM45")%>%visRemoveEdges(id = "RBM45")%>%
visRemoveNodes(id="SPAST")%>%visRemoveEdges(id = "SPAST")%>%
visRemoveNodes(id="ALMS1")%>%visRemoveEdges(id = "ALMS1")%>%
visRemoveNodes(id="PIGQ")%>%visRemoveEdges(id = "PIGQ")%>%
visRemoveNodes(id="CDC27")%>%visRemoveEdges(id = "CDC27")%>%
visRemoveNodes(id="GFM1")%>%visRemoveEdges(id = "GFM1")%>%
visRemoveNodes(id="UTRN")%>%visRemoveEdges(id = "UTRN")%>%
visRemoveNodes(id="RAB7B")%>%visRemoveEdges(id = "RAB7B")%>%
visRemoveNodes(id="GSN")%>%visRemoveEdges(id = "GSN")%>%
visRemoveNodes(id="VAPA")%>%visRemoveEdges(id = "VAPA")%>%
visRemoveNodes(id="GLE1")%>%visRemoveEdges(id = "GLE1")%>%
visRemoveNodes(id="FA2H")%>%visRemoveEdges(id = "FA2H")%>%
visRemoveNodes(id="HSPA4")%>%visRemoveEdges(id = "HSPA4")%>%
visRemoveNodes(id="SNCA")%>%visRemoveEdges(id = "SNCA")%>%
visRemoveNodes(id="RAB5A")%>%visRemoveEdges(id = "RAB5A")%>%
visRemoveNodes(id="SETX")%>%visRemoveEdges(id = "SETX")
})
Using
g <- graph_from_data_frame(ed10)
articulation.points(g)
I found the articulation points, and I marked them with red color using ifelse as you can see in nodes4 vector.
My questions:
How to shorten my code in ifelse using loop, so I don't have to write the articullation points one by one manually.
How to shorten my code in visRemoveNodes and visRemoveEdges using loop, so I don't have to write them one by one manually as well.
Crossed posted at:
https://community.rstudio.com/t/how-to-shorten-code-for-visremovenodes-using-loop/72506
The answer for the second question is:
observe({
l <- c("CLEC4E","ACE2", "MYO7A", "HSPB4", "EXOSC3", "RBM45","SPAST","ALMS1",
"PIGQ","CDC27","GFM1","UTRN",
"RAB7B", "GSN", "VAPA", "GLE1","FA2H","HSPA4",
"SNCA","RAB5A","SETX") #we put all genes that we want to delete in a vector
for (i in l){
input$delete54
visNetworkProxy("plot54")%>%
visRemoveNodes(id= i)%>%visRemoveEdges(id = i)
}
})
Related
I have a network diagram with a fairly large amount of nodes (~600), each node having some data, including an ID and its name.
I want to be able to run a very simple function when double-clicking on a specific node.
For that purpose, I have followed the instructions from this thread.
Using the code provided:
library(shiny)
library(visNetwork)
ui <- fluidPage(
visNetworkOutput('network')
)
server <- function(input, output, session) {
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges
) %>%
visPhysics(stabilization = TRUE, enabled = TRUE) %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>% # The colour of the edge linking nodes
visLayout(improvedLayout = TRUE) %>%
visEdges(arrows = edges$arrows) %>%
visInteraction(multiselect = F) %>%
visEvents(doubleClick = "function(nodes) {
Shiny.onInputChange('current_node_id', nodes.nodes);
;}")
return(v)
}
testFunction <- function(node_id){
print(paste("The selected node ID is:", node_id))
}
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
output$network <- renderVisNetwork(
getDiagramPlot(nodes, edges)
)
observeEvent(input$current_node_id,{
testFunction(input$current_node_id)
})
}
shinyApp(ui, server)
The codes works well but when I replace the simple nodes and edges dataframe provided as example by my data (much larger network) then the code doesn't work anymore (nothing gets printed in the console when I double-click on any nodes).
Would anyone know why the code is not running with my data ?
Here is the adjustments that should be done to the code below:
load("NodesEdges.RData")
# nodes <- data.frame(id = 1:3, label = 1:3)
# edges <- data.frame(from = c(1,2), to = c(1,3))
Best wishes,
C.
I have tried:
adding more columns to the example nodes/edges (group, value, color, etc.) and the codes still runs well.
restricting my larger nodes/edges dataframes respectively to the "id", "label" and "from", "to" columns (same as example data) but the codes still fails.
I wonder whether the problem comes from the size of the dataframe.
The whole function which i need to convert the for loop in to apply for optimization
plans_achievements <- function(pa_m,pa_q){
if(nrow(pa_m)==0 & nrow(pa_q==0)){
df = data.frame(a = c(""), b = c("No Data Available"))
colnames(df)=""
}else{
pa_m= pa_m%>% select(inc,month_year,Plans,Achievements,quarter_year)
colnames(pa_mon)[2] = "Period"
pa_q= pa_q%>% select(inc,quarter_year,Plans,Achievements)
colnames(pa_qtr)[2] = "Period"
df = data.frame(inc=c(""),Period=c(""),Plans=c(""),Achievements=c(""))
for (q in unique(pa_q$Period)){
df1 = pa_q[pa_q$Period==q,]
df1$Period = paste0("<span style=\"color:#288D55\">",df1$Period,"</span>")
df1$Plans = paste0("<span style=\"color:#288D55\">",df1$Plans,"</span>")
df1$Achievements = paste0("<span style=\"color:#288D55\">",df1$Achievements,"</span>")
df = rbind(df,df1)
for (m in unique(pa_m$quarter_year)){
if(m==q){
df2 = pa_m[pa_m$quarter_year==q,][-5]
df = rbind(df,df2)
}
}
}
df = df[-1,]
}
return(df)
}
The apply which i tried
my_fun <- function(q){
df1 = pa_qtr[pa_qtr$Period==q,]
df1$Period = paste0("<span style=\"color:#288D55\">",df1$Period,"</span>")
df1$Plans = paste0("<span style=\"color:#288D55\">",df1$Plans,"</span>")
df1$Achievements = paste0("<span style=\"color:#288D55\">",df1$Achievements,"</span>")
df = rbind(df,df1)
}
df = do.call(rbind,lapply(unique(pa_qtr$Period), my_fun))
my_fun2 <- function(m,my_fun){
if (m == q) {
df2 = pa_mon[pa_mon$qtr_yr == q, ][-5]
df = rbind(df,df2)
}
}
df = do.call(cbind,lapply(unique(pa_mon$qtr_yr), my_fun2))
DT::datatable(plans_achievements(pa_m[pa_m$inc=="vate",],pa_q[pa_q$inc=="vate",]), rownames = F,escape = FALSE,selection=list(mode="single",target="row"),options = list(pageLength = 50,scrollX = TRUE,dom = 'tp',ordering=F,columnDefs = list(list(visible=FALSE, targets=c(0)),list(className = 'dt-left', targets = '_all'))))
Why you get the error comparison is possible only for atomic and list types
I will answer your original question first:
You get the error because you haven't defined q as a variable inside the function my_fun2. Since you haven't defined this variable, R will look for it in the global environment. There R will find the function q() (used to quit R). So you get the error message comparison (1) is possible only for atomic and list types because R thinks you are trying to compare a number m with the function q.
Here is a small example to make it easy to see:
# Run this in a clean environment
m <- 1
m == b # Understandable error message - "b" is not found
m == q # Your error - because R thinks you are comparing m to a function
You fix this error by making sure that q is defined inside your function. Either by creating it inside the function, or by supplying it as an input argument.
A possible solution for your problem
As I understand your code, you want to format, merge and sort the values in pa_q and pa_m, to display them in a html table.
Under is a possible solution, using tidyverse and vectorized operations, rather than a loop or apply functions. Vectorized functions are typically your fastest option in R, as I know you want to optimize your code.
library(dplyr)
plans_achievements <- function(pa_m, pa_q) {
# I've modified the logic a bit: there is no need to wrap the full function in
# an else statement, since we can return early if the data has no rows
if (nrow(pa_m) == 0 && nrow(pa_q == 0)) {
df = data.frame(a = c(""), b = c("No Data Available"))
colnames(df) = ""
return(df)
}
pa_q <-
pa_q %>%
# Select and rename the columns vi need
select(inc, Period = quarter_year, Plans, Achievements, date) %>%
# Format the values
mutate(
Period = paste0("<span style=\"color:#288D55\">", Period,"</span>"),
Plans = paste0("<span style=\"color:#288D55\">", Plans,"</span>"),
Achievements = paste0("<span style=\"color:#288D55\">", Achievements,"</span>")
)
pa_m <-
pa_m %>%
# Select and rename the columns we need
select(inc, Period = month_year, Plans, Achievements, date) #%>%
# Combine the datasets
bind_rows(
pa_q,
pa_m
) %>%
# Make sure that R understand date as a date value
mutate(
date = lubridate::dmy(date)
) %>%
# Sort by date
arrange(desc(date)) %>%
# Remove columns we do not need
select(-date, -inc)
}
DT::datatable(
plans_achievements(
pa_m[pa_m$inc=="vate",],
pa_q[pa_q$inc=="vate",]
),
rownames = FALSE,
escape = FALSE,
selection = list(mode = "single", target = "row"),
options = list(
pageLength = 50,
scrollX = TRUE,
dom = 'tp',
ordering = FALSE,
columnDefs = list(
list(className = 'dt-left', targets = '_all')
)
)
)
Hopefully this solves your problem.
So I'm working on a Shiny dashboard, which I deployed on an AWS EC2 instance. It behaves exactly the same both locally and online save for one detail: the labels on the right hand side do not behave properly!
Here is the online version of the Plotly Sankey diagram in question:
Here is what I see locally when I run the app through RStudio.
There's absolutely no difference among any files. I don't see why the rendering of the labels should differ on both versions, but anyway, here's the relevant part of the code inside server.R:
# gender_sankey
nodes <- c('Hombres', 'Mujeres', unique(gender_df$UltimoGradoEstudios))
nodes <- nodes[c(1,2,4,3,5,7,12,10,8,6,11,9)]
gender_df$count <- 1
hom_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$hom == 1,])
muj_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$muj == 1,])
# Setting the sources and targets
hom_stud$src <- 0
muj_stud$src <- 1
hom_stud$tgt <- c(2,4,3,11,5,8,6,9,7)
muj_stud$tgt <- c(2,4,3,11,5,8,10,6,9,7)
# Setting the positions for the nodes
node_x <- c(0,0,1,1,1,1,1,1,1,1,1,1)
node_y <- c(0,1,-10:-1) # NOTE: Probably one of the fishy parts (2/2)
colors <- c('#C7FFA9','#E4A9FF','#2424FF','#2477FF','#248EFF','#249FFF',
'#24B3FF','#24C7FF','#24DEFF','#24F8FF','#24FFF8','#24FFEE')
# NOTE: Probably one of the fishy parts (1/2)
# Button to select/de-select all
observe({
if (input$selectall_sankey > 0) {
if (input$selectall_sankey %% 2 == 0){
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c(choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
))
)
} else {
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c())
}}
})
# Plot
output$gender_sankey <- renderPlotly({
hom_stud <- hom_stud[hom_stud$UltimoGradoEstudios %in% input$schoolSelect,]
muj_stud <- muj_stud[muj_stud$UltimoGradoEstudios %in% input$schoolSelect,]
node_x <- c(node_x[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
node_y <- c(node_y[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
colors <- c(colors[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
fig <- plot_ly(
type = "sankey",
orientation = "h",
arrangement = 'snap',
node = list(
label = nodes,
color = colors,
x = node_x,
y = node_y,
pad = 15,
thickness = 20,
line = list(
color = "black",
width = 0.5
)
),
link = list(
source = c(hom_stud$src, muj_stud$src),
target = c(hom_stud$tgt, muj_stud$tgt),
value = c(hom_stud$count, muj_stud$count)
)
)
fig <- fig %>% layout(
font = list(
size = 10
)
) %>% config(modeBarButtons = list(list('toImage'), list('resetScale2d')), displaylogo = F)
})
Packages used: shiny, shinydashboard, shinythemes and plotly (same versions both locally and on server). dplyr, magrittr, and ggplot2 are on the same version as well.
R version in my computer is 4.0.2, R version in the server is 3.6.3
It's not the cleanest implementation, specially on the button part, but it works perfectly locally! Note that I marked the sketchy practices I used, and where the problem could lie. Basically the default node order wasn't cutting it because the position on the right hand side itself contains information (Doctorado > Maestría > Licenciatura> ...), so I kind of forced a different order for the nodes through node_x and node_y. The thing is, the implementation works locally! What could be the reason for it not to work online?
I want to plot a graph via Rgraphviz but I can't handle the design attributes of the clusters that I set.
There are similar questions already on SO and elsewhere but none has a real minimal working example and none of them is answered. So I want to try to ask a complete question to receive a complete answer. As an introduction to the package, I read the paper "How To Plot A Graph Using Rgraphviz" by Gentry, Gentleman, and Huber.
My example network:
library(Rgraphviz)
set.seed(123)
V <- letters[1:6]
M <- 1:4
g1 <- randomGraph(V, M, 0.2)
If I want to plot it, I can easily give it some attributes via a list:
attributes <- list(node = list(shape = "rectangle", fixedsize = FALSE),
graph = list(layout = "dot", bgcolor = "transparent"))
plot(g1, attrs = attributes )
Plotting it via plot(g1) gives the following result:
Now I want to define two clusters/subgraphs. This can be done this way:
sg1= subGraph(c("a", "e", "f"), g1)
sg2= subGraph(c("b", "c", "d"), g1)
subGList <- vector(mode = "list", length = 2)
subGList[[1]] <- list(graph = sg1, cluster = TRUE)
subGList[[2]] <- list(graph = sg2, cluster = TRUE)
Plotting the graph again now including a subGlist argument:
plot(g1, attrs = attributes , subGList = subGList)
So, obviously, there has been a change in the setting and even though it would be convenient having the clusters a little bit more separated, the result is ok.
Now if I want to define cluster-specific styles or try to have them framed, I start having problems. According to page 4 of the mentioned introductory paper one can simply add an element called attrs to the sublists of subGlist.
To my understanding, it should work this way:
subGList[[1]] <- list(graph = sg1,
cluster = TRUE,
attrs = c(fontcolor = "red"))
plot(g1, attrs = attrs, subGList = subGList)
Unfortunately, it doesn't. As mentioned, I would like to frame my clusters (similar to this SO post) but as I can't even handle the fontcolors of the clusters, I think I make a somehow more fundamental mistake.
My complete code:
library(Rgraphviz)
set.seed(123)
V <- letters[1:6]
M <- 1:4
g1 <- randomGraph(V, M, 0.2)
attributes <- list(node = list(shape = "rectangle", fixedsize = FALSE),
graph = list(layout = "dot", bgcolor = "transparent"))
#plot(g1, attrs = attributes )
sg1= subGraph(c("a", "e", "f"), g1)
sg2= subGraph(c("b", "c", "d"), g1)
subGList <- vector(mode = "list", length = 2)
subGList[[1]] <- list(graph = sg1, cluster = TRUE)
subGList[[2]] <- list(graph = sg2, cluster = TRUE)
#plot(g1, attrs = attributes , subGList = subGList)
subGList[[1]] <- list(graph = sg1,
cluster = TRUE,
attrs = c(fontcolor = "red"))
plot(g1, attrs = attrs, subGList = subGList)
I hope someone can help! Thank you
I created a Sankey diagram using the plotly package.
Please look at below example. I tried to make five streams, 1_6_7, 2_6_7, and so on. But two of five links between 6 and 7 disappeared. As far as I see, plotly allows to make only three or less links between two nodes.
Can I remove this restrictions ? Any help would be greatly appreciated.
Here is an example code and the outputs:
d <- expand.grid(1:5, 6, 7)
node_label <- 1:max(d)
node_colour <- scales::alpha(RColorBrewer::brewer.pal(7, "Set2"), 0.8)
link_source_nodeind <- c(d[,1], d[,2]) - 1
link_target_nodeind <- c(d[,2], d[,3]) - 1
link_value <- rep(100, nrow(d) * 2)
link_label <- rep(paste(d[,1], d[,2], d[,3], sep = "_"), 2)
link_colour <- rep(scales::alpha(RColorBrewer::brewer.pal(5, "Set2"), 0.2), 2)
p <- plotly::plot_ly(type = "sankey",
domain = c(x = c(0,1), y = c(0,1)),
orientation = "h",
node = list(label = node_label,
color = node_colour),
link = list(source = link_source_nodeind,
target = link_target_nodeind,
value = link_value,
label = link_label,
color = link_colour))
p