I have a graph g1 and I need to find the quotient graph g2.
My attept is:
library(igraph)
n = 8
m <- t(matrix(c(
0,0,0,0,0,0,0,8,
3,0,0,0,0,0,0,0,
5,0,0,5,1,0,0,0,
0,0,6,0,0,7,1,0,
0,6,2,0,0,0,0,0,
0,0,0,0,0,0,0,0,
7,4,0,0,8,0,0,3,
0,3,0,0,0,9,0,0),ncol=n))
g1 <- graph_from_adjacency_matrix(m, weighted=TRUE, mode="directed")
V(g1)$names <- letters[1:n]
V(g1)$label <- V(g1)$names
g2 <- contract(g1, components(g1, mode = "strong")$membership, vertex.attr.comb=toString)
g2 <- simplify(g2)
The graph g2 has three componets: {a, b, h}, {c, d, e, g} and {f} and I need to use the first letters from each component as vertex.labels.
plot(g2, vertex.label = substr(toupper(V(g2)$label), 1, 1))
The result is correct for me:
Question. Is it possible to solve the task without using the additional attribute V(g1)$label?
You should use $name (instead of $names) to add vertex name attribute, e.g.,
g1 <- graph_from_adjacency_matrix(m, weighted = TRUE, mode = "directed")
V(g1)$name <- letters[1:n]
g2 <- contract(g1, components(g1, mode = "strong")$membership, vertex.attr.comb = toString)
g2 <- simplify(g2)
then, when you run plot(g2), you will see
Related
I have a graph $G=(V, E)$. I need to make a vetrex contraction by the rules:
Find all articulation vertices with degree is greater than 2 and contract all vertices into them that can only be reached through this vertex.
The original graph in left, the expected graph in right. It is should be noted: instead of leaves "14", "8" and "3" can be subgraphs with more that one vertex.
First, I have found the bridge edges (red color) and two types of the articulation vertices: a) on a chain (red color), b) not on a chain (green color). The criteria for articulation classifucation is a vertex degree (2 or not 2).
My attemp is:
library(igraph)
set.seed(44)
n = 20
m = 35
G <- sample_gnm(n=n, m=m)
V(G)$group <- 1:n
V(G)$color <- "black"
E(G)$color <- "black"
ind <- articulation.points(G)
V(G)$color[ind] <- ifelse(degree(G, V(G)[ind])==2, "red", "green")
if(degree(G, V(G)[ind])==2) V(G)[ind]$group = 0
num_comp <- length(decompose.graph(G))
for (i in 1:m) {
G_sub <- delete.edges(G, i)
if (length(decompose.graph(G_sub)) > num_comp) E(G)$color[i] <- "red"
}
plot(G, layout = layout.fruchterman.reingold,
vertex.size = 15, vertex.color= V(G)$color,
vertex.label.color = "white" )
g2 <- contract(G, mapping = factor(V(G)$group),
vertex.attr.comb=toString)
plot(g2, layout = layout.fruchterman.reingold,
vertex.size = 15, vertex.color= V(G)$color,
vertex.label.color = "white" )
Question. How to define the mapping?
Edit. After the ThomasIsCoding's answer I'd add the figure for the remark: It is should be noted: instead of leaves "14", "8" and "3" can be subgraphs with more that one vertex. For instance, I can have the case:
set.seed(44)
n <- 20
m <- 35
G <- sample_gnm(n = n, m = m) %>%
add_vertices(1) %>%
add_vertices(1) %>%
add_edges(c(3,21, 3,22, 21,22))
plot(G)
In the figure below one can see the five bridges. The degree of vertices 8 and 14 equal to one, but vertex 3 in not a leaf now.
My problem is: how to distinguish the chain and no chain.
for (k in ind) {
nbs <- neighbors(G, k)
if (degree(G, k) == 2) # chain
V(G)$group <- replace(V(G)$group,
match(nbs[degree(G, nbs) == 1], V(G)), match(k, V(G)))
else # no chain
V(G)$group <- ...
}
Also weak place is: To which subgraph (A or B) should the vertex contraction operation be applied? In the original case the one vetrex were contracted only. The original task come from the simplification big graph for future analysis. And I think I can make the simplification based on bridges and cut-vertices. But now I am thinking on the selection subgraph for the vetrex contraction. The ccurrent point of view: apply the the vertex contraction for the subgraph with the minimal geodesic spanning tree.
You can try the code below to produce the mapping argument (see the for loop part)
library(igraph)
set.seed(44)
n <- 20
m <- 35
G <- sample_gnm(n = n, m = m)
V(G)$group <- 1:n
ind <- articulation.points(G)
for (k in ind) {
nbs <- neighbors(G, k)
V(G)$group <- replace(V(G)$group, match(nbs[degree(G, nbs) == 1], V(G)), match(k, V(G)))
}
g2 <- contract(G, mapping = factor(V(G)$group))
I don't know anything about R language(syntax)
How can I delete all edges with weight=0 from the graph?
For example all edges with 0 similarity 1
Here's an example on how to delete edges between vertices with zero jaccard similarity:
library(igraph)
g <- make_ring(5) + edges(4,1,2,2)
par(mfrow = c(1,2))
plot(g)
(s <- similarity(g, method = "jaccard"))
idx <- which(s == 0, arr.ind = T)
g2 <- g - edges(as.vector(t(idx)))
plot(g2)
I am trying to
1) get the coordinates of a network
2) use them for other networks to have always the same position of nodes.
When I get the coordinates of the nodes and set the coordinates to the same network from which I got them, it changes. The x position remains the same and the y position becomes symmetric to the hypothetical y axes. Thus, when applied twice, the position is the one that I want.
The problem is probably in the tkplot.getcoords() function. Do you know if there is a trick to avoid applying it twice?
n <- 20
mat <- matrix(1:n^2, n,n)
g <- graph.adjacency(mat, mode="directed", weighted=TRUE, diag=FALSE)
V(g)$color <- "white"
id <- tkplot(g, edge.curved = 0.5)
coor <- tkplot.getcoords(id,norm=F)
coor
tkplot.setcoords(id, coor) # wrong position
coor <- tkplot.getcoords(id,norm=F)
coor
tkplot.setcoords(id, coor) # desired position
Do you know if there is a trick to avoid applying it twice?
It seems as if you had to flip the y coordinates; this works on my computer:
library(igraph)
set.seed(1);n <- 5
mat <- matrix(1:n^2, n,n)
g <- graph.adjacency(mat, mode="directed", weighted=TRUE, diag=FALSE)
V(g)$color <- "white"
id <- tkplot(g, 200, 200, edge.curved = 0.5)
coor <- tkplot.getcoords(id,norm=F)
canvas_height <- as.numeric(tcltk::tkcget(tk_canvas(id), "-height"))-20 # twenty by trial&error - prly the frame border top&bottom?
coor[,2] <- canvas_height-coor[,2]
# move some vertices and...
tkplot.setcoords(id, coor) # reset
let's say I have n igraphs objects g1, g2,.., gn. They are undirected and weighted graphs, i.e. new weight's attribute should be added. I'd like to union n graphs into the weighted graph g.
It is known from the documentation (see ?graph.union) if the n graphs have the weight attribute, it is renamed by adding a _1 and _2 (and _3, etc.) suffix, i.e. weight_1, weight_2,..., weight_n.
I have seen the answer and wrote the code for n=3 graphs (see below).
Edited:
library(igraph)
rm(list=ls(all=TRUE)) # delete all objects
g1 <- graph_from_literal(A1-B1-C1)
g2 <- graph_from_literal(A2-B2-C2)
g3 <- graph_from_literal(A3-B3-C3)
E(g1)$weight <- c(1, 2)
E(g2)$weight <- c(3, 4)
E(g3)$weight <- c(5, 6)
g <- union(g1, g2, g3)
new_attr <- as.list(list.edge.attributes(g))
k <- length(new_attr) # number of new attributes
value_new_attr <- lapply(list.edge.attributes(g),
function(x) get.edge.attribute(g,x))
df <- data.frame()
for (i in 1:k) {df <- rbind(df, value_new_attr[[i]])}
E(g)$weight <- colSums(df, na.rm=TRUE)
g <- delete_edge_attr(g, "weight_1") # 1
g <- delete_edge_attr(g, "weight_2") # 2
g <- delete_edge_attr(g, "weight_3") # 3
Question. How to rewrite the last tree commands with the lapply() function?
My attempt does not work:
g <- lapply(value_new_attr, function(x) {g <- delete_edge_attr(g, x)})
I have found the solution with for-loop
# delete edge attributes with suffix
for (i in 1:k) {g <- delete_edge_attr(g, new_attr[i])}
let me explain:
My data is a 5x5 grid of points (so n=25). Now say I want to choose J points. I can work out all possible combination combo using the function combn. But this is a very large matrix, and with what I want to achieve at the end, I can actually define a equivalence class by rotation (90, 180, 270 degree) and reflection. So for example, p1 is equivalent to p2,p3,p4,p5...,p8
data<-expand.grid(1:5,1:5)
J=5 # for example
combo<-combn(25,J)
# rotation symmetry
p1=c(1,6,15,20,25)
p2=c(3,4,5,21,22)
p3=c(1,6,11,20,25)
p4=c(4,5,21,22,23)
# reflection symmetry
p5=c(5,10,11,16,21)
p6=c(1,2,23,24,25)
p7=c(5,10,15,16,21)
p8=c(1,2,3,24,25)
# to help you visualize
par(mfrow=c(4,2))
equiv<-rbind(p1,p2,p3,p4,p5,p6,p7,p8)
fn<-function(x){
p.col=rep(1,25);p.col[x]=2
plot(expand.grid(1:5,1:5),col=p.col,asp=1)}
apply(equiv,1,fn)
After this, I can simply eliminate the equivalent rows, so that my combo is a much smaller matrix.
So basically, I am looking for a script that ultimately gives me the compact version of combo.
Any help is appreciated.
Thanks.
edit: I haven't tried anything yet. I was hoping there will be some R package for graph theory/combinatorics that does this.
For each combination, you can enumerate the other elements of the equivalence class,
compute some numeric quantity that identifies them (say, an MD5 checksum),
and only keep the combination if it has the smallest value.
# Enumerate the transformations (the dihedral group of order 8)
k <- 5
d1 <- expand.grid( 1:k, 1:k )
d2 <- expand.grid( k:1, 1:k )
d3 <- expand.grid( 1:k, k:1 )
d4 <- expand.grid( k:1, k:1 )
o1 <- order(d1[,1], d1[,2])
o2 <- order(d2[,1], d2[,2])
o3 <- order(d3[,1], d3[,2])
o4 <- order(d4[,1], d4[,2])
o5 <- order(d1[,2], d1[,1])
o6 <- order(d2[,2], d2[,1])
o7 <- order(d3[,2], d3[,1])
o8 <- order(d4[,2], d4[,1])
g1 <- function(p) o1[p]
g2 <- function(p) o2[p]
g3 <- function(p) o3[p]
g4 <- function(p) o4[p]
g5 <- function(p) o5[p]
g6 <- function(p) o6[p]
g7 <- function(p) o7[p]
g8 <- function(p) o8[p]
transformations <- list(g1,g2,g3,g4,g5,g6,g7,g8)
# Check that we have all the transformations
op <- par(mfrow=c(3,3), las=2, mar=c(1,1,1,1))
for( f in transformations ) {
plot( d1 )
lines( d1[f(1:10),] )
}
par(op)
# Function to decide whether to keep a value
library(digest)
keep <- function(p, d) {
q0 <- digest( d[ sort(p), , drop=FALSE] )
q <- sapply( transformations, function(f) digest( d[ sort(f(p)), , drop=FALSE ] ) )
q0 == sort(q)[1]
}
# Apply the function on each column
i <- apply(combo, 2, keep, d=d1) # Long...
length(i) / sum(i) # Around 8 (not exactly, because some of those combinations are symmetric)
result <- combo[,i]
In your example, we only keep one of the 8 elements:
apply( equiv, 1, keep, d=d1 )
# p1 p2 p3 p4 p5 p6 p7 p8
# FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE