1
$\begingroup$

I am new to studying networks in Mathematica and I would like to model the following network evolution process:

  1. Start with a random graph $g_0$ with $n$ nodes, $n$ even.
  2. At each time $t$, ach node $i$ is matched at random with another node $j$. If the intersection of the neighborhoods of $i$ and $j$ has at least $k$ nodes, an edge between $i$ and $j$ is added (or remains if it already existed); otherwise, the edge is deleted (or is not added if it already wasn't there).
  3. The process continues until no new link is added or deleted.

I would like to be able to view the entire network evolution process.

EDIT

Here is what I have so far.

I begin by setting a seed and generating a starting random graph $g_0$ (here with 10 edges)

SeedRandom[123]

g = RandomGraph[BernoulliGraphDistribution[10, 0.5],
VertexLabels -> All]

Then I pick out a random pairing

Pairs = Graph[UndirectedEdge @@@ 
Partition[RandomSample[Range[10],10],2],
VertexLabels -> All] 

For any two nodes, say 1 and 10, I know how to obtain their common neighborhood:

CommonNeighij = Intersection[VertexList[NeighborhoodGraph[g,1]],
VertexList[NeighborhoodGraph[g,10]]] 

Here's how I get stuck:

  1. How do I use the graph Pairs to determine which links are added/deleted from $g$?

  2. How do I repeat/loop the process (every time changing the seed so that the random partition is different)?

$\endgroup$
5
  • $\begingroup$ Welcome to MSE. How many edges does the graph have? Have you tried to implement the process in WL code? If so, please edit your question and add the code you have tried. If not, why don't you try coding it and if you get stuck, share what you tried and the issue(s) you encountered. $\endgroup$ Nov 14, 2022 at 23:48
  • $\begingroup$ Hello, I'd like the process for arbitrary number of vertices and edges, but around 10 vertices for now would work. Like I said I am new to this and just looking at the Mathematica documentation I do not really know where to start. Is there any relevant guide to these kind of simulations that you could kindly point me to? $\endgroup$ Nov 14, 2022 at 23:58
  • $\begingroup$ See this and this. Useful functions RandomGraph, VertexList, EdgeAdd, EdgeDelete. $\endgroup$ Nov 15, 2022 at 0:14
  • $\begingroup$ Thank you, those are the functions/resources I was trying to use. Good to I was on the right track! I have updated my question with what I have so far. $\endgroup$ Nov 15, 2022 at 0:34
  • $\begingroup$ For good performance, I suggest you work directly with adjacency matrices instead of Graph. For small graphs, dense matrices may perform better than sparse ones. Exploit the fact that the number of common neighbours of two vertices is given by the corresponding element of the square of the adjacency matrix, or more simply, the dot product of corresponding rows. To choose two random vertices, use RandomSample[1;;n, 2]. I do not have time to implement this, so only a comment, no answer. Hope it's useful. $\endgroup$
    – Szabolcs
    Apr 14, 2023 at 7:45

1 Answer 1

1
$\begingroup$

Here's some code to start you off. The function evolve performs the transformation you asked for:

evolve[g_Graph, k_] := Module[{i, j, nbhd},
  i = RandomChoice[VertexList[g]];
  j = RandomChoice[DeleteCases[VertexList[g], i]];
  {i, j} = Sort[{i, j}];
  nbhd = Intersection[AdjacencyList[g, i], AdjacencyList[g, j]];
  If[Length[nbhd] >= k,
   Graph[VertexList[g], 
    Union[EdgeList[g] /. 
      u_UndirectedEdge :> Sort[u], {UndirectedEdge[i, j]}]],
   Graph[VertexList[g], 
    DeleteCases[EdgeList[g] /. u_UndirectedEdge :> Sort[u], 
     UndirectedEdge[i, j]]]
   ]
  ]

And then you can use NestList to repeatedly apply the function, and ListAnimate to look at the result. Here I've done 100 iterations with k = 2 and starting from a random graph with 10 vertices and 30 edges.

start = RandomGraph[{10, 30}];
ListAnimate[NestList[evolve[#, 2] &, start, 100]]

Edit

To apply the transformation to a random partition at each step, you can use the following:

(* evolve a single pair *)
evolve[g_Graph, k_, {i_, j_}] := 
 Module[{nbhd = 
    Intersection[AdjacencyList[g, i], AdjacencyList[g, j]]},
  If[Length[nbhd] >= k, 
   Graph[VertexList[g], 
    Union[EdgeList[g] /. 
      u_UndirectedEdge :> Sort[u], {UndirectedEdge @@ Sort[{i, j}]}]],
    Graph[VertexList[g], 
    DeleteCases[EdgeList[g] /. u_UndirectedEdge :> Sort[u], 
     UndirectedEdge @@ Sort[{i, j}]]]]
  ]

(* evolve a random partition *)
evolve[g_Graph, k_] := 
 With[{pairs = 
    Partition[RandomSample[VertexList[g], Length@VertexList[g]], 2]},
  Fold[evolve[#1, k, #2] &, g, pairs]
  ]
```
$\endgroup$
4
  • $\begingroup$ Thank you very much! This is extremely helpful. Looks like what the code does is add/delete one link per period. Is there any way to instead add/delete multiple links each period, according to a random partition? The idea is to have all nodes "meet" another node at each period. $\endgroup$ Nov 15, 2022 at 1:18
  • $\begingroup$ I added some code for this case. The first definition is very similar to before, and the second one calls the first one for each of a random set of pairs. $\endgroup$
    – srossd
    Nov 15, 2022 at 2:45
  • $\begingroup$ I am so very grateful! One final question: is there any resources you'd recommend for learning more on simulations like these? I am a little lost in the Mathematica guides. $\endgroup$ Nov 15, 2022 at 2:59
  • $\begingroup$ Here's a big thread with some resources. Not sure if there's anything specific to graphs in there, but a lot of it should be generally useful. $\endgroup$
    – srossd
    Nov 15, 2022 at 3:23

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.