Netting a weighted matrix in igraph (R) - r

Is there a simple way that I'm missing to create a netted version of a simple, weighted, directed network in igraph? This is where mutual edges are replaced with a single edge carrying the difference between the weights and the direction is such that the weight is always positive. A simple example:
gGross <- graph_from_literal(A++B)
E(gGross)$weight <- c(12, 20)
gNet <- graph_from_literal(A+-B)
E(gNet)$weight <- c(8)
In matrix notation this would be
N_{ij} = (A_{ij} - A_{ji})_+
where the + means keep positive elements.
A good starting point would be something similar to which_mutual that gives the index of the return edge. I can imagine writing a long function in R but that seems likely to be slow.

I feel I can do better than this, but I do at least have a working method. Improvements most welcome. Edited to reflect Tamás' comments and allow use of any attribute
nettedGraph <- function(g, col="weight") {
if(!(col %in% edge_attr_names(g))) {
stop(col, " not and edge attribute")
}
# Get a matrix of mutual edges (by vertex ids)
me <- ends(g, E(g)[which_mutual(g)], names=FALSE)
# Only keep one of the mutual edges
me <- me[me[,1] < me[,2], ]
toDel <- vector(mode="integer", length=nrow(me))
for (i in 1:nrow(me)) {
# Get edge ids going each way
e1 <- get.edge.ids(g, c(me[i,1],me[i,2]))
e2 <- get.edge.ids(g, c(me[i,2],me[i,1]))
weightDiff <- edge_attr(g,col, e1) - edge_attr(g,col, e2)
if(weightDiff > 0) {
# Update the edge we're keeping
edge_attr(g,col, e1) <- weightDiff
# Delete the one we're not
toDel[i] <- e2
} else {
# Update the edge we're keeping
edge_attr(g,col, e2) <- -weightDiff
# Delete the one we're not
toDel[i] <- e1
}
}
# Now delete all the unneeded edges
g <- g - E(g)[toDel]
return(g)
}
set.seed(123)
g <- graph_from_literal(A-+B, B++C, A++C)
E(g)$weight <- round(runif(ecount(g),1,20))
weight0 <- E(g)$weight
gNet <- nettedGraph(g)

Related

How to iterate with dynamic changing the number edges and nodes?

I have a random graph with 10 nodes where 4 nodes have the zero degree.
It is required to obtain the connected graph by 1) select a node with zero degree and a minimal feature (for exmaple, random number from uniform distribautin) corresponding to each edge and connect it with graph by creation two incident edges to the node and deleting the 3rd edge, 2) repeat step 1 for all zero degree nodes.
The original graph in left, the resulting one in right.
My attempt is:
library(igraph)
######################################################################
set.seed(5)
g <- sample_gnm(10, 4)
xy <- cbind(runif(10), runif(10))
par(mfrow=c(1,2))
plot(g, vertex.size=5, layout=xy)
num_point <- length(V(g)[degree(g)==0])
for(k in 1:num_point){
points = V(g)[degree(g)==0]
for(i in 1:length(E(g))) { # loop over all edges
head <- get.edgelist(g)[i,][1]; h <- c(V(g)[head]$x, V(g)[head]$y)
tail <- get.edgelist(g)[i,][2]; t <- c(V(g)[tail]$x, V(g)[tail]$y)
d <- NULL
# loop over all points
for(j in points) d <- c(d, runif(1))
E(g)[i]$d <- min(d) # local min
E(g)[i]$p <- points[which(d == min(d))]
} # i
ei = which.min(E(g)$d) # edge with the global min
vi = E(g)[ei]$p
# head and tail of edge with global min
head <- get.edgelist(g)[E(g)[ei],][1]; tail <- get.edgelist(g)[E(g)[ei],][2]
g <- add_edges(g, c(head, V(g)[vi],
V(g)[vi],
tail));
g <- delete_edges(g, get.edge.ids(g, c(head, tail) ))
}
plot(g, vertex.size=5, layout=xy)
Question. How to organize the loop over all edges when the number of edges increase by 1 and number of point decrising by 1 evety step? One can see, I don't use the k variable in explicit form.
Instead of for loop, I think you can use repeat plus a termination condition, i.e., no isolated vertices any more
repeat {
points <- V(g)[degree(g) == 0]
for (i in 1:length(E(g))) { # loop over all edges
head <- get.edgelist(g)[i, ][1]
h <- c(V(g)[head]$x, V(g)[head]$y)
tail <- get.edgelist(g)[i, ][2]
t <- c(V(g)[tail]$x, V(g)[tail]$y)
d <- NULL
# loop over all points
for (j in points) d <- c(d, runif(1))
E(g)[i]$d <- min(d) # local min
E(g)[i]$p <- points[which(d == min(d))]
} # i
ei <- which.min(E(g)$d) # edge with the global min
vi <- E(g)[ei]$p
# head and tail of edge with global min
head <- get.edgelist(g)[E(g)[ei], ][1]
tail <- get.edgelist(g)[E(g)[ei], ][2]
g <- add_edges(g, c(
head, V(g)[vi],
V(g)[vi],
tail
))
g <- delete_edges(g, get.edge.ids(g, c(head, tail)))
if (sum(degree(g) == 0) == 0) {
break
}
}
I will recommend you to use recursion for this and drop for loop- using recursion for tree and graph structures will definitely make your life easier.
Answer:
maintain a stack of all the leaf nodes
every time you iterate empty your stack by matching the leaf node values
if there's a new value and count of the stack != to old count.
Now iterate again.

How to find edge ids of some vertices in igraph?

I have an issue with get.edge.ids() function in igraph in R I need to pass odd number of vertices to it and get the edgeIDs between them but unfortunately it only gets pairwise vertices sample code to generate a directed graph:
Graph <- erdos.renyi.game(20, 100 , directed=TRUE, loops=FALSE)
how do I call get.edge.ids:
get.edge.ids(Graph, c("1", "2", "3))
I expect to get all possible edges IDs between these vertices but it doesn't work. I developed a function for this purpose but it is not fast enough. Here is the function:
insideOfCommEdgeIDs <- function(graph, vertices)
{
out <- matrix()
condition <- matrix()
if (length(vertices) < 2) {return(NULL)}
for (i in vertices)
{
for (j in vertices)
{
condition <- are_adjacent(graph,i,j)
ifelse(condition,
out <- rbind(out, get.edge.ids(graph, c(i, j), directed=TRUE)),
next)
}
}
return(out[!is.na(out)])
}
Is there any way to to this faster?
You can use the %--% operator to query edges by vertex indices and then use as_ids() to get the edge index.
Please note, I'm using igraph version 1.2.4.2, so I'm using sample_gnm() rather than erdos.renyi.game().
library(igraph)
set.seed(1491)
Graph <- sample_gnm(20, 100 , directed = TRUE, loops = FALSE)
as_ids(E(Graph)[c(1, 2, 3) %--% c(1, 2, 3)])
#> [1] 6 12
This matches the output from your custom function:
insideOfCommEdgeIDs <- function(graph,vertices)
{
out <- matrix()
condition <- matrix()
if(length(vertices) < 2) {return(NULL)}
for(i in vertices)
{
for (j in vertices)
{
condition <- are_adjacent(graph,i,j)
ifelse(condition,out <- rbind(out,get.edge.ids(graph,c(i,j),directed = TRUE)),next)
}
}
return(out[!is.na(out)])
}
insideOfCommEdgeIDs(Graph, c(1, 2, 3))
#> [1] 6 12
Created on 2020-04-10 by the reprex package (v0.3.0)

Package for Divide Chain of tesselations in R, spatstat package?

I am trying to create pretty figures of clustered points. Is there a package which will create the divide chain between tessellations of points? Ideally it would be fit for plotting in ggplot.
Here is some example code:
#DivideLineExample
library(spatstat)
W=owin(c(0,1),c(0,1)) # Set up the Window
p<-runifpoint(42, win=W) # Get random points
ll=cbind(p$x,p$y) # get lat/long for each point
zclust=kmeans(ll,centers=4) # Cluster the points spatially into 4 clusters
K<-pp<-D<-list()
plot(W,main="Clustered Points")
for (i in 1:4){ # this breaks up the points into separate ppp objects for each cluster
K[[i]]=ll[zclust$cluster==i,]
pp[[i]]=as.ppp(K[[i]],W)
plot(pp[[i]],col=i,add=TRUE,cex=1.5,pch=16)
D[[i]]=dirichlet(pp[[i]]) # This performs the Dirichlet Tessellation and plots
plot(D[[i]],col=i,add=TRUE)
}
This outputs as such:
http://imgur.com/CCXeOEB
What I'm looking for is this:
http://imgur.com/7nmtXjo
I know an algorithm exists.
Any ideas/alternatives?
I have written a function that I think will do what you want:
divchain <- function (X) {
stopifnot(is.ppp(X))
if(!is.multitype(X)) {
whinge <- paste(deparse(substitute(X)),
"must be a marked pattern with",
"factor valued marks.\n")
stop(whinge)
}
X <- unique(X, rule = "deldir", warn = TRUE)
w <- Window(X)
require(deldir)
dd <- deldir(X,z=marks(X),rw=c(w$xrange,w$yrange))
if (is.null(dd))
return(NULL)
ddd <- dd$dirsgs
sss <- dd$summary
z <- sss[["z"]]
rslt <- list()
nsgs <- nrow(ddd)
K <- 0
for (i in 1:nsgs) {
i1 <- ddd[i,5]
i2 <- ddd[i,6]
c1 <- z[i1]
c2 <- z[i2]
if(c1 != c2) {
K <- K+1
rslt[[K]] <- unlist(ddd[i,1:4])
}
}
class(rslt) <- "divchain"
attr(rslt,"rw") <- dd$rw
rslt
}
I have also written a plot method for class "divchain":
plot.divchain <- function(x,add=FALSE,...){
if(!add) {
rw <- attr(x,"rw")
plot(0,0,type="n",ann=FALSE,axes=FALSE,xlim=rw[1:2],ylim=rw[3:4])
bty <- list(...)$bty
box(bty=bty)
}
lapply(x,function(u){segments(u[1],u[2],u[3],u[4],...)})
invisible()
}
E.g.:
require(spatstat)
set.seed(42)
X <- runifpoint(50)
z <- factor(kmeans(with(X,cbind(x,y)),centers=4)$cluster)
marks(X) <- z
dcX <- divchain(X)
plot(dirichlet(X),border="brown",main="")
plot(X,chars=20,cols=1:4,add=TRUE)
plot(dcX,add=TRUE,lwd=3)
Let me know whether this is satisfactory. Sorry I can't help you with ggplot stuff; I don't do ggplot.
You could try point in polygon test for example like kirkpatrick data structure. Much easier is to divide the polygon in horizontal or vertical. Source:http://www.personal.kent.edu/~rmuhamma/Compgeometry/MyCG/Voronoi/DivConqVor/divConqVor.htm

Using igraph, how to force curvature when arrows point in opposite directions

autocurve.edges does an amazing job of curving edges in igraph plots so that they don't overlap when they point in the same direction. However, when they point in opposite directions, no curvature is applied.
d <- data.frame(start=c("a","a","b","c"),end=c("b","b","c","b"))
graph <- graph.data.frame(d, directed=T)
plot(graph,
vertex.color="white")
The issue is for the arrows between b and c (or c and b).
Other than specifying curvature manually, any suggestions?
I would use the edge.curved option with the same seq call that autocurve.edges uses.
plot(graph,
vertex.color="white", edge.curved=seq(-0.5, 0.5, length = ecount(graph)))
EDIT:
As Étienne pointed out, this solution also curves edges for unique observations. The solution is then to modify the autocurve.edges function. This is my modified function called autocurve.edges2. Basically, it generates a vector, which curves only non-unique edges.
autocurve.edges2 <-function (graph, start = 0.5)
{
cm <- count.multiple(graph)
mut <-is.mutual(graph) #are connections mutual?
el <- apply(get.edgelist(graph, names = FALSE), 1, paste,
collapse = ":")
ord <- order(el)
res <- numeric(length(ord))
p <- 1
while (p <= length(res)) {
m <- cm[ord[p]]
mut.obs <-mut[ord[p]] #are the connections mutual for this point?
idx <- p:(p + m - 1)
if (m == 1 & mut.obs==FALSE) { #no mutual conn = no curve
r <- 0
}
else {
r <- seq(-start, start, length = m)
}
res[ord[idx]] <- r
p <- p + m
}
res
}
And here's the result when adding a single, non-mutual edge (C->D):
library(igraph)
d <- data.frame(start=c("a","a","b","c","c"),end=c("b","b","c","b","d"))
graph <- graph.data.frame(d, directed=T)
curves <-autocurve.edges2(graph)
plot(graph, vertex.color="white", edge.curved=curves)

Ordering 1:17 by perfect square pairs

There was an interesting question on R-help:
"Take the numbers one up to 17. Can you write them out in a line so that every pair of numbers that are next to each other, adds up to give a square number?"
My solution is below and not particularly special. I'm curious about a more elegant and/or robust solution. Maybe a solution that can take an arbitrary string of numbers and order them like this if possible?
sq.test <- function(a, b) {
## test for number pairs that sum to squares.
sqrt(sum(a, b)) == floor(sqrt(sum(a, b)))
}
ok.pairs <- function(n, vec) {
## given n as a member of vec,
## which other members of vec satisfiy sq.test
vec <- vec[vec!=n]
vec[sapply(vec, sq.test, b=n)]
}
grow.seq <- function(y) {
## given a starting point (y) and a pairs list (pl)
## grow the squaring sequence.
ly <- length(y)
if(ly == y[1]) return(y)
## this line is the one that breaks down on other number sets...
y <- c(y, max(pl[[y[ly]]][!pl[[y[ly]]] %in% y]))
y <- grow.seq(y)
return(y)
}
## start vector
x <- 1:17
## get list of possible pairs
pl <- lapply(x, ok.pairs, vec=x)
## pick start at max since few combinations there.
y <- max(x)
grow.seq(y)
You can use outer to compute the allowable pairs.
The resulting matrix is the adjacency matrix of a graph,
and you just want a Hamiltonian path on it.
# Allowable pairs form a graph
p <- outer(
1:17, 1:17,
function(u,v) round(sqrt(u + v),6) == floor(sqrt(u+v)) )
)
rownames(p) <- colnames(p) <- 1:17
image(p, col=c(0,1))
# Read the solution on the plot
library(igraph)
g <- graph.adjacency(p, "undirected")
V(g)$label <- V(g)$name
plot(g, layout=layout.fruchterman.reingold)

Resources