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.
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)
Consider the Togliatti implicit surface. I want to clip it to the ball centered at the origin with radius 4.8. A solution, with the misc3d package, consists in using the mask argument of the computeContour3d function, which allows to use only the points satisfying x^2+y^2+z^2 < 4.8^2:
library(misc3d)
# Togliatti surface equation: f(x,y,z) = 0
f <- function(x,y,z){
w <- 1
64*(x-w)*
(x^4-4*x^3*w-10*x^2*y^2-4*x^2*w^2+16*x*w^3-20*x*y^2*w+5*y^4+16*w^4-20*y^2*w^2) -
5*sqrt(5-sqrt(5))*(2*z-sqrt(5-sqrt(5))*w)*(4*(x^2+y^2-z^2)+(1+3*sqrt(5))*w^2)^2
}
# make grid
nx <- 220; ny <- 220; nz <- 220
x <- seq(-5, 5, length=nx)
y <- seq(-5, 5, length=ny)
z <- seq(-4, 4, length=nz)
g <- expand.grid(x=x, y=y, z=z)
# calculate voxel
voxel <- array(with(g, f(x,y,z)), dim = c(nx,ny,nz))
# mask: keep points satisfying x^2+y^2+z^2 < 4.8^2, in order to
# clip the surface to the ball of radius 4.8
mask <- array(with(g, x^2+y^2+z^2 < 4.8^2), dim = c(nx,ny,nz))
# compute isosurface
surf <- computeContour3d(voxel, maxvol=max(voxel), level=0, mask=mask, x=x, y=y, z=z)
# draw isosurface
drawScene.rgl(makeTriangles(surf, smooth=TRUE))
But the borders of the resulting surface are irregular:
How to get regular, smooth borders?
The solution I found resorts to spherical coordinates. It consists in defining the function f in terms of spherical coordinates (ρ, θ, ϕ), then to compute the isosurface with ρ running from 0 to the desired radius, and then to transform the result to Cartesian coordinates:
# Togliatti surface equation with spherical coordinates
f <- function(ρ, θ, ϕ){
w <- 1
x <- ρ*cos(θ)*sin(ϕ)
y <- ρ*sin(θ)*sin(ϕ)
z <- ρ*cos(ϕ)
64*(x-w)*
(x^4-4*x^3*w-10*x^2*y^2-4*x^2*w^2+16*x*w^3-20*x*y^2*w+5*y^4+16*w^4-20*y^2*w^2) -
5*sqrt(5-sqrt(5))*(2*z-sqrt(5-sqrt(5))*w)*(4*(x^2+y^2-z^2)+(1+3*sqrt(5))*w^2)^2
}
# make grid
nρ <- 300; nθ <- 400; nϕ <- 300
ρ <- seq(0, 4.8, length = nρ) # ρ runs from 0 to the desired radius
θ <- seq(0, 2*pi, length = nθ)
ϕ <- seq(0, pi, length = nϕ)
g <- expand.grid(ρ=ρ, θ=θ, ϕ=ϕ)
# calculate voxel
voxel <- array(with(g, f(ρ,θ,ϕ)), dim = c(nρ,nθ,nϕ))
# calculate isosurface
surf <- computeContour3d(voxel, maxvol=max(voxel), level=0, x=ρ, y=θ, z=ϕ)
# transform to Cartesian coordinates
surf <- t(apply(surf, 1, function(rtp){
ρ <- rtp[1]; θ <- rtp[2]; ϕ <- rtp[3]
c(
ρ*cos(θ)*sin(ϕ),
ρ*sin(θ)*sin(ϕ),
ρ*cos(ϕ)
)
}))
# draw isosurface
drawScene.rgl(makeTriangles(surf, smooth=TRUE, color = "violetred"))
Now the resulting surface has regular, smooth borders:
Your solution is excellent for the problem you stated, because spherical coordinates are so natural for that boundary. However, here is a more general solution that would work for other smooth boundaries.
The idea is to allow input of a boundary function, and cull points when they are too large or too small. In your case it would be the squared distance from the origin, and you would want to cull points where the value is bigger than 4.8^2. But sometimes the triangles being drawn to make the smooth surface should only be partially culled: one point would be kept and two deleted, or two kept and one deleted. If you cull the whole triangle that leads to the jagged edges in your original plot.
To fix this, the points can be modified. If only one is supposed to be kept, then the other two points can be shrunk towards it until they lie on an approximation to the boundary. If two are supposed to be kept you want the shape to be a quadrilateral, so you would build that out of two triangles.
This function does that, assuming the input surf is the output of computeContour3d:
boundSurface <- function(surf, boundFn, bound = 0, greater = TRUE) {
# Surf is n x 3: each row is a point, triplets are triangles
values <- matrix(boundFn(surf) - bound, 3)
# values is (m = n/3) x 3: each row is the boundFn value at one point
# of a triangle
if (!greater)
values <- -values
keep <- values >= 0
# counts is m vector counting number of points to keep in each triangle
counts <- apply(keep, 2, sum)
# result is initialized to an empty array
result <- matrix(nrow = 0, ncol = 3)
# singles is set to all the rows of surf where exactly one
# point in the triangle is kept, say s x 3
singles <- surf[rep(counts == 1, each = 3),]
if (length(singles)) {
# singleValues is a subset of values where only one vertex is kept
singleValues <- values[, counts == 1]
singleIndex <- 3*col(singleValues) + 1:3 - 3
# good is the index of the vertex to keep, bad are those to fix
good <- apply(singleValues, 2, function(col) which(col >= 0))
bad <- apply(singleValues, 2, function(col) which(col < 0))
for (j in 1:ncol(singleValues)) {
goodval <- singleValues[good[j], j]
for (i in 1:2) {
badval <- singleValues[bad[i,j], j]
alpha <- goodval/(goodval - badval)
singles[singleIndex[bad[i,j], j], ] <-
(1-alpha)*singles[singleIndex[good[j], j],] +
alpha *singles[singleIndex[bad[i,j], j],]
}
}
result <- rbind(result, singles)
}
doubles <- surf[rep(counts == 2, each = 3),]
if (length(doubles)) {
# doubleValues is a subset of values where two vertices are kept
doubleValues <- values[, counts == 2]
doubleIndex <- 3*col(doubleValues) + 1:3 - 3
doubles2 <- doubles
# good is the index of the vertex to keep, bad are those to fix
good <- apply(doubleValues, 2, function(col) which(col >= 0))
bad <- apply(doubleValues, 2, function(col) which(col < 0))
newvert <- matrix(NA, 2, 3)
for (j in 1:ncol(doubleValues)) {
badval <- doubleValues[bad[j], j]
for (i in 1:2) {
goodval <- doubleValues[good[i,j], j]
alpha <- goodval/(goodval - badval)
newvert[i,] <-
(1-alpha)*doubles[doubleIndex[good[i,j], j],] +
alpha *doubles[doubleIndex[bad[j], j],]
}
doubles[doubleIndex[bad[j], j],] <- newvert[1,]
doubles2[doubleIndex[good[1,j], j],] <- newvert[1,]
doubles2[doubleIndex[bad[j], j],] <- newvert[2,]
}
result <- rbind(result, doubles, doubles2)
}
# Finally add all the rows of surf where the whole
# triangle is kept
rbind(result, surf[rep(counts == 3, each = 3),])
}
You would use it after computeContour3d and before makeTriangles, e.g.
fn <- function(x) {
apply(x^2, 1, sum)
}
drawScene.rgl(makeTriangles(boundSurface(surf, fn, bound = 4.8^2,
greater = FALSE),
smooth = TRUE))
Here's the output I see:
It's not quite as good as yours, but it would work for many different boundary functions.
Edited to add: Version 0.100.26 of rgl now has a function clipMesh3d which incorporates these ideas.
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)
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)