Function Repository Resource:

NearestNeighborGraphEntropy

Source Notebook

Compute the Shannon entropy of a set of points connected by a nearest neighbor graph

Contributed by: Jessica Alfonsi (Padova, Italy)

ResourceFunction["NearestNeighborGraphEntropy"][pts,nnradius]

computes the Shannon entropy of a set of points pts connected by a nearest neighbor graph, where a given point is connected to all its nearest neighbors within an input given radius nnradius.

Details

The edge set is obtained by applying the NearestNeighborGraph function to a set of points given as input.
The entropy of a graph is defined as S{XMLElement[i, {}, {XMLElement[span, {class -> stylebox}, {graph}]}]}=-Σi PLiln PLi , where the probability PLi=n(Li)/E is given by the number of edges with length over the total number of edges E. The sum over index i is performed all over available (unequal) edge lengths.
The formula for the graph entropy is derived from the statistical measure of information and entropy in statistical mechanics, which is also known in the literature as Shannon entropy.
The Euclidean distances between nearest neighbor points is treated as equal if they differ by the optional "MinThreshold" value, which is set by default to 0.00001.
The graph entropy S{XMLElement[i, {}, {XMLElement[span, {class -> stylebox}, {graph}]}]} is zero for a graph with all edges of the same length , since PL=n(L)/E = 1 and ln(PL)=0. If all the graph edges are unequal the graph entropy equals S{XMLElement[i, {}, {XMLElement[span, {class -> stylebox}, {graph}]}]}=ln(E), which means that the graph shows no symmetry at all. If symmetry is present, then S{XMLElement[i, {}, {XMLElement[span, {class -> stylebox}, {graph}]}]}<ln(E). The range for the graph entropy is therefore 0 ≤ S{XMLElement[i, {}, {XMLElement[span, {class -> stylebox}, {graph}]}]}ln(E).

Examples

Basic Examples (2) 

Compute entropy for a nearest neighbor graph of 20 random points:

In[1]:=
ResourceFunction["NearestNeighborGraphEntropy"][
 RandomReal[{-1, 1}, {20, 2}], 1.0]
Out[1]=

Build the nearest neighbor graph of a perfect square lattice with unit lattice constant:

In[2]:=
b = LatticeData["SquareLattice", "Basis"]; 
pts = Tuples[Range[0, 5], 2] . b
Out[3]=
In[4]:=
NearestNeighborGraph[pts, {All, 1.0}]
Out[4]=

Compute the graph entropy and verify it is equal to zero as expected by symmetry:

In[5]:=
ResourceFunction["NearestNeighborGraphEntropy"][pts, 1.0]
Out[5]=

Scope (3) 

Define a 2D set of point arranged in a square lattice, add distortions to have all edges unequal as in a 2D disordered system and build the corresponding NearestNeighborGraph with all nearest neighbor connections within a given radius:

In[6]:=
SeedRandom[123];
b = LatticeData["SquareLattice", "Basis"]; pts = Tuples[Range[0, 5], 2] . b; 
dissquarepts = pts + RandomReal[{-0.075, 0.075}, {Length[pts]}];
NearestNeighborGraph[dissquarepts, {All, 1.2}]
Out[9]=

Compute the graph entropy:

In[10]:=
ResourceFunction["NearestNeighborGraphEntropy"][dissquarepts, 1.2]
Out[10]=

Check it is equal to the natural logarithm of the number of distinct edges in the graph:

In[11]:=
EdgeCount[NearestNeighborGraph[dissquarepts, {All, 1.2}]]
Out[11]=

Options (2) 

Treat some distance values as equal if they differ by an optional threshold "MinThreshold" set to a given positive value. This introduces some order into the graph layout:

In[12]:=
SeedRandom[123];
dissquarepts = Tuples[Range[0, 5], 2] . LatticeData["SquareLattice", "Basis"] + RandomReal[{-0.075, 0.075}, {Length[pts]}];
In[13]:=
dissqgr = NearestNeighborGraph[dissquarepts, {4, 1.2}];
In[14]:=
ResourceFunction["NearestNeighborGraphEntropy"][dissquarepts, 1.2, "MinThreshold" -> 0.01]
Out[14]=

Check that graph entropy is lower than in the case without rounding factor:

In[15]:=
TrueQ[ResourceFunction["NearestNeighborGraphEntropy"][dissquarepts, 1.2, "MinThreshold" -> 0.01] < ResourceFunction["NearestNeighborGraphEntropy"][dissquarepts, 1.2]]
Out[15]=

Applications (2) 

Build a linear graph mapped to the coordinates of a one-dimensional Fibonacci quasiperiodic chain with nit iterations and spacing ratio between nodes tau:

In[16]:=

grfibo1d[nit_, tau_] := Module[{niter = nit (* number of iterations *),
   Fibonaccirule, wordlist, coordlist, tauratio = tau (* ratio between edge lenghts *), ptsfibo1d},
  Fibonaccirule = {S :> {L}, L :> {L, S}};(* two-
  letter Fibonacci inflation-deflation substitution rule *)
  (* generation of the Fibonacci word sequence *)
  wordlist = Flatten[Nest[(# /. Fibonaccirule) &, S, niter]];
  coordlist = Prepend[Accumulate[wordlist], 0];(* added origin *)
  ptsfibo1d = Transpose[{coordlist /. {L -> tauratio, S -> 1}, ConstantArray[0, Length[coordlist]]}]]
In[17]:=
NearestNeighborGraph[grfibo1d[5, 2], {All, 2}]
Out[17]=

Computes its graph entropy:

In[18]:=
ResourceFunction["NearestNeighborGraphEntropy"][grfibo1d[5, 2], 2]
Out[18]=

Check that the numerical value of the graph entropy converges to the universal value 0.665:

In[19]:=
Show[{ListPlot[
   Transpose[{Range[2, 10, 1], Table[ResourceFunction["NearestNeighborGraphEntropy"][
       grfibo1d[i, 2], 2], {i, 2, 10, 1}]}], PlotRange -> {{0, 12}, {0, 1.2}}, Frame -> True, FrameLabel -> {"Iterations", "Graph Entropy"}, LabelStyle -> Directive[Black, 14]], Plot[0.665, {x, 0, 12}, PlotStyle -> Red]}]
Out[19]=

This universal value 0.665 is also independent of the spacing ratio between graph nodes:

In[20]:=
Show[{ListPlot[
   Transpose[{Range[2, 10, 1], Table[ResourceFunction["NearestNeighborGraphEntropy"][
       grfibo1d[10, t], t], {t, 2, 10, 1}]}], PlotRange -> {{0, 11}, {0, 1.2}}, Frame -> True, FrameLabel -> {"Spacing ratio", "Graph Entropy"}, LabelStyle -> Directive[Black, 14]], Plot[0.665, {x, 0, 11}, PlotStyle -> Green]}]
Out[20]=

If a point symmetry element of order Cn is present in the graph, then the graph entropy is equal to ln(E/n) where E is the total number of edges in the graph and n is the order of the rotation symmetry.

Start from a slightly disordered square lattice and apply rotations of 0, π/2, π and -π/2 to the starting lattice points to get three additional sub-lattices:

In[21]:=
SeedRandom[123];
b = LatticeData["SquareLattice", "Basis"]; pts = Tuples[Range[0, 5], 2] . b; 
(* starting lattice *)
dissquarepts = pts + RandomReal[{-0.075, 0.075}, {Length[pts]}];
(* apply rotations *)
t0 = RotationTransform[\[Pi], {0, 0}];
t1 = RotationTransform[\[Pi]/2, {0, 0}];
t2 = RotationTransform[-\[Pi]/2, {0, 0}];
rotpts0 = t0[dissquarepts];
rotpts1 = t1[dissquarepts];
rotpts2 = t2[dissquarepts];
(* merge all sublattices *)
allpts = Flatten[{dissquarepts, rotpts0, rotpts1, rotpts2}, 1];

Build the overall graph connecting all points belonging to the four sub-lattices:

In[22]:=
nngrsymC4 = NearestNeighborGraph[allpts, {All, 1.2}]
Out[22]=

Compute numerically the graph entropy for this system:

In[23]:=
N@ResourceFunction["NearestNeighborGraphEntropy"][allpts, 1.12]
Out[23]=

Check that it is close to the natural logarithm of the number of graph edges divided by the symmetry order:

In[24]:=
Log[EdgeCount[nngrsymC4]/4] // N
Out[24]=

Properties and Relations (2) 

Define a grid of points:

In[25]:=
b = LatticeData["SquareLattice", "Basis"]; grid = Tuples[Range[0, 5], 2] . b
Out[25]=

As noise is added to the graph, the entropy increases:

In[26]:=
Labeled[NearestNeighborGraph[#, 2], N@ResourceFunction["NearestNeighborGraphEntropy"][#, 2]] & /@ Table[(grid + RandomReal[noise, Dimensions[grid]]), {noise, {0, 2*10^-5, 0.1, 1}}]
Out[26]=

Neat Examples (2) 

Build a 2D graph mapped to the coordinates of a two-dimensional Fibonacci quasiperiodic array with nit iterations:

In[27]:=

grfibo2d[nit_] := Module[{niter = nit (* number of iterations *),
   Fibonaccirule, wordlist, coordlist, coordgridprod, ptsfibo2d},
  Fibonaccirule = {S :> {L}, L :> {L, S}};(* two-
  letter Fibonacci inflation-deflation substitution rule *)
  (* generation of the Fibonacci word sequence *)
  wordlist = Flatten[Nest[(# /. Fibonaccirule) &, S, niter]];
  coordlist = Prepend[Accumulate[wordlist], 0];(* added origin *)
  coordgridprod = Outer[{#1, #2} &, coordlist, coordlist]; (* grid product *)
        ptsfibo2d = Flatten[coordgridprod /. {L -> 1.4, S -> 1}, 1]
        ]
In[28]:=
NearestNeighborGraph[grfibo2d[5], {All, 1.41}]
Out[28]=
In[29]:=
ResourceFunction["NearestNeighborGraphEntropy"][grfibo2d[5], 1.41] // N
Out[29]=

Check that the numerical value of the graph entropy still converges to the universal value 0.665 known from 1D case (computation takes a few seconds):

In[30]:=
Show[{ListPlot[
   Transpose[{Range[2, 10, 1], Table[ResourceFunction["NearestNeighborGraphEntropy"][
       grfibo2d[i], 1.41], {i, 2, 10, 1}]}], PlotRange -> {{0, 12}, {0, 1.2}}, Frame -> True, FrameLabel -> {"Iterations", "Graph Entropy"}, LabelStyle -> Directive[Black, 14]], Plot[0.665, {x, 0, 12}, PlotStyle -> Red]}]
Out[30]=

A semi-regular set of points obtained by alternatively deleting sites from a square lattice:

In[31]:=
b = LatticeData["SquareLattice", "Basis"];
pts = Tuples[Range[0, 9], 2] . b;
newpts = Delete[pts, {{1}, {3}, {5}, {7}, {9}, {21}, {23}, {25}, {27}, {29}, {41}, {43}, {45}, {47}, {49}, {61}, {63}, {65}, {67}, {69}, {81}, {83}, {85}, {87}, {89}}];
Graphics[{PointSize[Medium], Red, Point@newpts}]
Out[4]=
In[32]:=
nngrewpts = NearestNeighborGraph[newpts, {2, 1.}]
Out[32]=

Check that the graph entropy is still zero as expected by symmetry:

In[33]:=
ResourceFunction["NearestNeighborGraphEntropy"][newpts, 1.0]
Out[33]=

Publisher

Jessica Alfonsi

Requirements

Wolfram Language 14.0 (January 2024) or above

Version History

  • 1.0.0 – 04 September 2024

Source Metadata

Related Resources

License Information