Small World network on a square grid

Quick summary

• The IGraph/M package has several functions to help with this (IGRewireEdges).
• The rewired network will not have the small world property unless the starting grid connects at least second neighbours as well. IGraph/M has a function to generate such a starting grid (IGMakeLattice).

---

Easiest is to use IGraph/M!

While this can be implemented in pure Mathematica, it is even easier with the IGraph/M package.

<< IGraphM`

We start with a grid graph:

g = GridGraph[{30, 30}];
coords = GraphEmbedding[g];

IGRewireEdges will rewire each edge with probability p, preserving the total number of edges.

?IGRewireEdges

IGRewireEdges[graph, p] rewires each edge of the graph with probability p.

Graph[IGRewireEdges[g, 0.1], VertexCoordinates -> coords]

We can control whether the creation of self loops or multi-edges is allowed:

Options[IGRewireEdges]
(* {SelfLoops -> False, "MultipleEdges" -> False} *)

IGRewire will rewire in such a way as to preserve the degree of each vertex. We can specify the number of rewiring trials (not all of which may succeed).

?IGRewire

IGRewire[graph, n] attempts to rewire the edges of graph n times while preserving its degree sequence.

Graph[IGRewire[g, 100], VertexCoordinates -> coords]

We can control whether the creation of self loops is allowed:

Options[IGRewire]
(* {SelfLoops -> False} *)

---

Need for this functionality was one of the reasons why I wrote IGraph/M. While it can be implemented in Mathematica, that is simply not fast enough for many implemented.

---

What is a "small-world" network?

Originally (Watts & Strogatz) a "small world" property of the network referred to having

1. A short average shortest path length
2. A high clustering coefficient

A random graph has (1) but not (2).
A graph like in the figure below has (2) but not (1):

So they made something "inbetween" by starting with this regular lattice where every 2nd neighbour is connected and rewiring edges to make it more random, achieving both properties at the same time.

Does your network have the small world property? No, because a simple grid graph does not have a high clustering coefficient.

N@GlobalClusteringCoefficient@GridGraph[{30, 30}]

(* 0. *)

Nor does a cycle graph, which is a periodic 1D grid graph with only first neighbours connected. We need at least every second neighbour connected, like this:

g = IGMakeLattice[{10}, Radius -> 2, Periodic -> True]

N@GlobalClusteringCoefficient[g]
(* 0.5 *)

IGraph/M's grid graph generator helps here because it has the Radius option to connect $n^\text{th}$ neighbours. We can also do it for 2D:

g = IGMakeLattice[{20, 20}, Radius -> 2]

Let's check the clustering and average shortest path length before rewiring ...

N@GlobalClusteringCoefficient[g]
(* 0.468933 *)

IGAveragePathLength[g]
(* 6.91729 *)

... and after rewiring:

g2 = IGRewireEdges[g, 0.03];

N@GlobalClusteringCoefficient[g2]
(* 0.390251 *)

IGAveragePathLength[g2]
(* 3.64128 *)

The clustering coefficient is reduced somewhat, but not significantly. The average path length is however cut in half.

We see that to get the small world property we must start with a lattice where at least second neighbours are connected!

This is not an answer, but an extended comment. Dr.belisarius' answer, given in comment to the question, looks promising, but it can produce loops, Is this admissible?

SeedRandom[1];
With[{g = GridGraph[{20, 20}]}, 
  EdgeAdd[
    EdgeDelete[g, #], 
    Thread[UndirectedEdge[#[[All, 1]], RandomChoice[VertexList @ g, Length @ #]]]]& @
      Pick[
        EdgeList @ g, 
        RandomVariate[BernoulliDistribution[.05], Length@EdgeList@g], 1]]