Essays, Posts & Presentations

[WSS21] Coarse-graining state networks with Approximate Graph Isomorphism

Jessica Yuan

Author

Jessica Yuan

Title

[WSS21] Coarse-graining state networks with Approximate Graph Isomorphism

Description

This project attempts to coarse-grain finite state networks by applying an algorithm of Approximate Graph Isomorphism.

Abstract

This project attempts to coarse-grain finite state networks by applying an algorithm of Approximate Graph Isomorphism. The algorithm of Approximate Graph Isomorphism is developed by checking the Euclidean distance of a given set of random graphs against a certain “threshold”, below which the graphs will be considered approximately isomorphic. Three empirical methods are presented to study such a “threshold”, which turns out to be relatively constant for large sets of random graphs. We applied the algorithm to coarse-grain finite state networks by merging all vertices that are considered approximately isomorphic.

Introduction

“Coarse-graining” denotes the simulation of the behavior of complex systems using a representation in which some of the fine details have been smoothed over. It is significant in that it allows us to model the behavior of a system without specifying all of the underlying causes that lead to system state changes.

A concrete example of coarse-graining would be the concept of temperature. Temperature is the average speed of particles in a system, meaning that it is a simplified representation of all of the particles' behavior. Therefore, coarse-graining allows us to predict a system's future state better than we could if we actually measured the speed of individual particles [1].

Coarse-graining lies at the core of the second law of thermodynamics, which states that the entropy of the universe is increasing. In the 20th century, J. Willard Gibbs gave qualitative arguments that entropy would increase if it were measured in a "coarse-grained" way in which nearby states were not distinguished [2]. As the entropy increases, information is lost about its initial state, leading to irreversibility.

In the Wolfram model, finite state networks can be constructed to further examine Gibbs' argument. Finite state networks are networks of hypergraphs showing what each hypergraph tends to evolve towards over time. Here, the concept of irreversibility can be characterized by the convergence of states in the networks. By convergence, we mean that hypergraphs that are approximately isomorphic can be merged. An interesting question is: can we quantify the changes of irreversibility of hypergraphs in the state networks?

This project is developed in two sections. In the first section, we discuss the algorithm for Approximate Graph Isomorphism, and in the second section, we apply the algorithm to finite state networks to see how the networks change.

Approximate Graph Isomorphism

Here’s a formal definition of the approximate graph isomorphism problem. Given two graphs G, H of the same order n with adjacency matrices

, a well-studied measure of similarity is the Frobenius distance

where π ranges over all permutations of the vertex set of G, where

denotes the matrix obtained from

by permuting rows and columns according to π, and where

is the Frobenius norm of a matrix M. [3]

The general logic behind approximating graph isomorphism is simple. While two graphs with a Euclidean Distance of 0 would be considered isomorphic, two graphs with a distance below a certain threshold would be considered approximately isomorphic.

However, finding the threshold value within which graphs are considered approximately isomorphic is the main challenge. We'll first list the functions developed for the section, and explains the two methods we use.

Code

Return true if the distance between two graphs are below or equal to the threshold:

In[]:=

Clear[ApproximateGraphIsomorphicQ]ApproximateGraphIsomorphicQ[g_Graph,h_Graph,threshold_]/;VertexCount[g]===VertexCount[h]:=GraphSpectralDistance[g,h]<=threshold

Return the Euclidean Distance of the Eigenvalues of the Kirchhoff Matrix of two graphs:

In[]:=

ClearAll[GraphSpectralDistance];GraphSpectralDistance[g_Graph,h_Graph]/;(VertexCount[g]===VertexCount[h]):=Quiet[EuclideanDistance[Eigenvalues[N[KirchhoffMatrix[g]]],Eigenvalues[N[KirchhoffMatrix[h]]]],{Eigenvalues::arh}]GraphSpectralDistance[_Graph,_Graph]:=InfinityGraphSpectralDistance[__]:=$Failed

Returns a list plot of the GraphSpectralDistance function:

In[]:=

GraphSpectralDistanceListPlot[table_List]:=Module[{m},m=Mean[table];ListLinePlot[{table,{{0,m},{Length[table],m}}},Joined{True,True},Filling->Axis]]

Randomly delete an edge from a complete graph and return the new graph:

In[]:=

RandomEdgeDelete[g_Graph]:=EdgeDelete[g,RandomChoice[EdgeList[g]]]

Randomly delete a percentage of total edges one by one from a complete graph and return a nest list:

In[]:=

RandomEdgeDeleteNestList[g_Graph,percentage_]:=NestList[RandomEdgeDelete,g,Floor[EdgeCount[g]*percentage]]

Returns the distance between the new graph and the initial graph when random edges are deleted one by one:

In[]:=

RandomEdgeDeleteDistances[g_Graph,percentage_]:=Map[GraphSpectralDistance[#,g]&,RandomEdgeDeleteNestList[g,percentage]]

Returns the minimum and maximum distances within one cluster of a nearest neighbor graph:

In[]:=

MinMaxDistanceInCluster[graphList_List]:=MinMax[Map[GraphSpectralDistance[#[[1]],#[[2]]]&,Subsets[graphList,{2}]]]

Returns the mean distance within one cluster of a nearest neighbor graph:

In[]:=

MeanDistanceInCluster[graphList_List]:=Mean[Map[GraphSpectralDistance[#[[1]],#[[2]]]&,Subsets[graphList,{2}]]]

Returns the minimum and maximum distances between two clusters of a nearest neighbor graph:

In[]:=

MinMaxDistancesBetweenClusters[cluster1_List,cluster2_List]:=MinMax[Outer[GraphSpectralDistance,cluster1,cluster2]]

Returns the mean distance between two clusters of a nearest neighbor graph:

In[]:=

MeanDistancesBetweenClusters[cluster1_List,cluster2_List]:=Mean[Mean[Outer[GraphSpectralDistance,cluster1,cluster2]]]

Method 1: Graph Perturbations

The graph below explores how fast graphs become different from themselves after their edges are randomly deleted one by one. The slope is defined as the change of distance between the new graph and the initial graph per deletion. A linear relationship is observed, meaning that one can infer about the number of deletions on a graph from its slope.

Explore the relationship of Euclidean Distances between the initial graph and the final graph for various graph sizes and edge deletions.

Manipulate[DynamicModule[{c,data,fit},c=RandomGraph[{size,size}];data=Map[GraphSpectralDistance[#,c]&,RandomEdgeDeleteNestList[c,percentage]];fit=LinearModelFit[data,x,x];Show[ListPlot[data,PlotLabelfit,PlotStyle->Directive[Red,PointSize[Large]],AxesLabel->{"Number of deletions","Distance between graphs"}],Plot[fit[x],{x,0,Length[data]}],FrameTrue]],{{percentage,.5,"% of edges to delete"},0.1,1},{{size,50,"number of vertices"},10,300,5}]

Out[]=

The slope for different sizes of graphs is computed. To get to the same distance, more deletions has to be made in a large graph than in a small graph. The decrease in slope as the size increases denotes that local deletions have lesser and lesser effect when size gets larger.

Plot the slope for various sizes of graphs.

Manipulate[DynamicModule[{range,graphSet,data,slopes},range=Range[Sequence@@sizeRange,10];graphSet=Map[RandomGraph[{#,#}]&,range];data=Map[RandomEdgeDeleteDistances[#,percentage]&,graphSet];slopes=Map[Coefficient[Normal[LinearModelFit[#,x,x]],x]&,data];ListPlot[Transpose[{range,slopes}],PlotLabel"Title",PlotStyle->Directive[Red,PointSize[Large]],AxesLabel->{"Size","Slope"}]],{{percentage,.5,"% of edges to delete"},0.1,1},{{sizeRange,"number of vertices"},10,200,10,ControlTypeIntervalSlider}]

Out[]=

Method 2: Nearest Neighbor Graph

Let’s take a graph set of 100 random graphs with 100 vertices and 100 edges as an example. The Nearest Neighbor Graph is shown below, indicating several distinct clusters. Values on the edges represents the distances between two graphs.

randomGraphSet=RandomGraph[{100,100},100];nearest=NearestNeighborGraph[randomGraphSet,1,DistanceFunctionGraphSpectralDistance,EdgeLabelsPlaced["Name",Center,GraphSpectralDistance[#1〚1〛,#1〚2〛]&],DirectedEdgesFalse]

Out[]=

A list plot of the mean of min/max distance within cluster and min/max distance between clusters is shown.

In[]:=

nearestGraphSet=ConnectedComponents[nearest];clusters=AssociationThread[Range[Length[nearestGraphSet]]->nearestGraphSet];minmaxDistancePerCluster=Map[MinMaxDistanceInCluster,clusters];subsets=Subsets[Keys[clusters],{2}];minmaxDistancesBetweenClusters=Association@Apply[(#1#2)->MinMaxDistancesBetweenClusters[clusters[#1],clusters[#2]]&,subsets,1];meanDistancesBetweenClusters=Association@Apply[(#1#2)->MeanDistancesBetweenClusters[clusters[#1],clusters[#2]]&,subsets,1];meanDistancePerCluster=Map[MeanDistanceInCluster,clusters];

BoxWhiskerChart[Map[Values,{minmaxDistancePerCluster[[All,1]],meanDistancePerCluster[[All]],minmaxDistancePerCluster[[All,2]],minmaxDistancesBetweenClusters[[All,1]],meanDistancesBetweenClusters[[All]],minmaxDistancesBetweenClusters[[All,2]]}],ChartLegends{"minDistancePerCluster","meanDistancePerCluster","maxDistancePerCluster","minDistanceBetweenClusters","meanDistancesBetweenClusters","maxDistanceBetweenCluster"},PlotLabel"Distances",ChartStyle"SandyTerrain"]

Out[]=

	minDistancePerCluster
	meanDistancePerCluster
	maxDistancePerCluster
	minDistanceBetweenClusters
	meanDistancesBetweenClusters
	maxDistanceBetweenCluster

Although an ideal threshold value would be between the min and max distance within cluster, possible minor overlapping between the values of the third (max distance within cluster) point and sixth point (min distance between cluster) can be observed.

However, a Mann Whitney Test conducted on the meanDistancePerCluster and meanDistancesBetweenClusters indicates that the former is significantly lower than the latter.

Therefore, we can be safe in assuming a threshold value of average of the min and max distance within cluster .

In[]:=

MannWhitneyTest[{Values[meanDistancePerCluster],Values[meanDistancesBetweenClusters]}]

Out[]=

1.13738×

-7

Manipulate the size of the random graph set and compute the threshold value.

Manipulate[DynamicModule[{range,randomGraphSet,nearest,nearestGraphSet,clusters,minmaxDistancePerCluster,subsets,minmaxDistancesBetweenClusters,thresholds},range=Range[10,250,10];randomGraphSet=Map[RandomGraph[{#,#},n]&,range];nearest=Map[NearestNeighborGraph[#,1,DistanceFunction->GraphSpectralDistance,DirectedEdges->False]&,randomGraphSet];nearestGraphSet=Map[ConnectedComponents,nearest];clusters=Map[AssociationThread[Range[Length[#]]->#]&,nearestGraphSet];minmaxDistancePerCluster=Map[MinMaxDistanceInCluster,clusters,{2}];thresholds=(MeanAround/@Values/@minmaxDistancePerCluster[[All,All,1]]+MeanAround/@Values/@minmaxDistancePerCluster[[All,All,2]])/2;ListPlot[{Transpose[{range,MeanAround/@Values/@minmaxDistancePerCluster[[All,All,1]]}],Transpose[{range,MeanAround/@Values/@minmaxDistancePerCluster[[All,All,2]]}],Transpose[{range,thresholds}]},PlotLabel"Thresholds for different graph set sizes",PlotLegends{"minDistancePerCluster","maxDistancePerCluster","threshold"},AxesLabel->{"Size","Distance"}]],{{n,10,"size of graph sets"},10,200,10}]

Results for range = Range [10, 250, 10] with graph set size set to 50.

Out[]=

Results for range = Range [50, 290, 10] with graph set size set to 50.

range=Range[50, 500, 50] with graph set size set to 50.

Method 3: Feature Space Plot

Let’s take the same graph set of 100 random graphs with 100 vertices and 100 edges from the previous section as an example.

In[]:=

ClearAll[pipe,branch,branchSeq]pipe=RightComposition;branch=Through@*{##}&;branchSeq=pipe[branch@##,Apply@Sequence]&;

If two graphs are close by, it means that they have similar features. Based on the closeness, we can construct a notion of feature distance.

In[]:=

FeatureSpacePlot[randomGraphSet]

Out[]=

In[]:=

featureVectorSet=DimensionReduce[randomGraphSet,2,Method"TSNE",PerformanceGoal"Quality"];

In[]:=

distanceM=DistanceMatrix[featureVectorSet];

In[]:=

With[{max=Length@randomGraphSet},Manipulate[DynamicModule[{g,gHlt,commNum},g=NearestNeighborGraph[Range@max,{nbr,d},DistanceFunction(distanceM[[##]]&),DirectedEdgesFalse,VertexCoordinatesfeatureVectorSet,ImageSizeSmall];gHlt=g//pipe[branchSeq[Identity,pipe[FindGraphCommunities,(commNum=Length[#];#)&]],branch[pipe[branchSeq[#1&,{g,idxSet}|->Subgraph[g,#]&/@idxSet],HighlightGraph],CommunityGraphPlot]];{{"ConnectedGraphQ?",ConnectedGraphQ@g},{"How many communities found?",commNum},{g,Sequence@@gHlt}}//Grid[#,FrameAll]&],{{nbr,4},1,10(*max*),1,ControlPlacement->Top,Appearance->"Open"},{{d,distanceM//Flatten//Mean},0.1,10,ControlPlacement->Top,Appearance->"Open"}]]

Out[]=

nbr

3.65

ConnectedGraphQ?	False
How many communities found?	commNum$$
NearestNeighborGraph[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100},{4,3.65},DistanceFunction(distanceM〚##1〛&),DirectedEdgesFalse,VertexCoordinatesfeatureVectorSet,ImageSizeSmall]	NearestNeighborGraph[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100},{4,3.65},DistanceFunction(distanceM〚##1〛&),DirectedEdgesFalse,VertexCoordinatesfeatureVectorSet,ImageSizeSmall]

Part

:Part specification distanceM〚1,1〛 is longer than depth of object.

NearestFunction

:The user-supplied distance function distanceM〚##1〛& does not give a real numeric distance when applied to the point pair 1 and 1.

Part

:Part specification distanceM〚1,1〛 is longer than depth of object.

NearestFunction

:The user-supplied distance function distanceM〚##1〛& does not give a real numeric distance when applied to the point pair 1 and 1.

Part

:Part specification distanceM〚1,1〛 is longer than depth of object.

General

:Further output of Part::partd will be suppressed during this calculation.

NearestFunction

:The user-supplied distance function distanceM〚##1〛& does not give a real numeric distance when applied to the point pair 1 and 1.

General

:Further output of NearestFunction::nearuf will be suppressed during this calculation.

We use the Feature Space Plot method as a complement to our Nearest Neighbor Graph method. Although the colored graph looks different from our Nearest Neighbor Graph, future work will be carried out to examine the min/max distance within cluster and min/max distance between clusters, which will then imply about the value of threshold. We will then compare this threshold with the one we found in the previous section, and see if the two values match each other.

Remarks on threshold

For now, as found in Method 2, we can infer that such a “threshold” stays roughly constant at 1.4 for large graph sets. Future work will be carried out to find the relationship between graph sizes and threshold values.

Coarse-graining of finite state networks

The finite state networks contain all possible initial conditions of a specific hypergraph signature, with how each condition changes after applying one specific rule. For signature-preserving rules, that is, rules that don’t generate extra relations, the state transition diagrams should be finite [4].

Now that we have examined the algorithm of Approximate Graph Isomorphism, we convert all hypergraphs to graphs and apply the algorithm to coarse-grain finite state networks. With a threshold to classify such approximation, we identify which hypergraph states can be merged, resulting in a coarse-grained version of the finite state network.

We’ll first list the functions developed for the section, and then explains them with examples.

Code

In[]:=

<<SetReplace`

In[]:=

Get[CloudObject["https://www.wolframcloud.com/obj/daniels/HypergraphTools.wl"]]

Enumerate possible ordered hypergraphs with a given signature:

In[]:=

EnumerateHypergraphs[args___] := ResourceFunction["EnumerateHypergraphs"][args] // Map[Hypergraph];

Enumerate canonical Wolfram model rules with a particular signature:

In[]:=

EnumerateSignaturePreservingRules[signature:{__List},args___]:=ResourceFunction["EnumerateWolframModelRules"][signature->signature,args];

Evolve hypergraphs with a given rule:

In[]:=

CanonicalHypergraph = ResourceFunction["CanonicalHypergraph"];HypergraphEvolve[rule_, hypergraph_Hypergraph] := CanonicalHypergraph[Hypergraph[WolframModel[rule, hypergraph, 1, "FinalState"]]]

Construct the hypergraph state network:

In[]:=

panelLabel[lbl_]:=Panel[Framed[Style[lbl,Hue[0.62,1,0.48]],BackgroundDirective[{Hue[0.63,0.41,1],Opacity[0.115]}],FrameStyleDirective[Opacity[0.5], Hue[0.62,0.52,0.82]]],FrameMargins0]ClearAll[HypergraphStateNetwork]HypergraphStateNetwork[networkEdges_List,options___] := With[{network = Graph[networkEdges]}, Graph[ network, options, VertexLabels  Table[hg  Placed[HypergraphPlot[hg, ImageSize  20], Center, panelLabel], {hg, VertexList[network]}], VertexSize -> 0, PerformanceGoal  "Quality", EdgeStyle  WolframPhysicsProjectStyleData["StatesGraph", "EdgeStyle"] ] ]

Count all vertices in a state network that has an In-Degree of more than 1:

In[]:=

MergingStatesList[graph_Graph]:=VertexList[graph,v_/;VertexInDegree[graph,v]>1]

Construct an association where the keys are the indices of the graph, and the values are the graphs themselves:

In[]:=

ClearAll[IndexGraphMapping]IndexGraphMapping[g_Graph]:=Association@Thread[Range[VertexCount[g]]->VertexList[g]];

Get the merging vertices of a graph:

In[]:=

ClearAll[MergingVertices]MergingVertices[graph_Graph]:=VertexList[graph,v_/;VertexInDegree[graph,v]>1];

Returns the value of threshold:

In[]:=

ClearAll[getThreshold]getThreshold[size_Integer]:=1.4;getThreshold[graph_Graph]:=getThreshold[VertexCount[graph]];

This contracts a list of vertices if the distances between the graphs is smaller than a threshold:

In[]:=

ClearAll[ContractApproximateVertices]ContractApproximateVertices[gTable_Association,h_Graph,vertices_List]:=Module[{distances,distancesBelowThreshold},distances=Map[Function[pair,pair->GraphSpectralDistance@@(gTable/@pair)],(*Obtainthegraphscorrespondingtotheindicesandcomputethedistance*)Subsets[Sort@vertices,{2}](*Sorttheinitiallistsothepairslooklike{index1,index2},whereindex1<index2*)];(*Selectthedistancesthatarebelowthethreshold*)distancesBelowThreshold=Select[distances,#[[2]]<getThreshold[gTable[#[[1,1]]]]&];(*Sortthemfromsmallesttolargest*)distancesBelowThreshold=SortBy[distancesBelowThreshold,Last];(*Iterativelycontractpairs*)Fold[VertexContract,h,distancesBelowThreshold[[All,1]]]];

Outermost merging vertices are identified by checking if the ancestor of said vertex does not contain an (unvisited) merging event:

In[]:=

ClearAll[OutermostMergingVertexQ]OutermostMergingVertexQ[g_Graph,unvisitedMergingVertices_List,vertex_]:=AllTrue[Rest@VertexInComponent[g,vertex],!MemberQ[unvisitedMergingVertices,#]&];

Get all the outermost (unvisited) merging vertices:

In[]:=

ClearAll[UnvisitedOutermostMergingVertices]UnvisitedOutermostMergingVertices[g_Graph,unvisitedMergingVertices_List]:=Select[unvisitedMergingVertices,OutermostMergingVertexQ[g,unvisitedMergingVertices,#]&]

This function contracts all the outermost merging events:

In[]:=

ClearAll[ContractOutermostMergingEvents]ContractOutermostMergingEvents[gTable_Association,g_Graph,unvisitedMergingVertices_List]:=Module[{outermostMergingVertices,allParents},(*Selectthelistofoutmostmergingeventsfromthelistofallmergingevents*)outermostMergingVertices=UnvisitedOutermostMergingVertices[g,unvisitedMergingVertices];(*Gettheparentsofthesemergingevents*)allParents=AssociationMap[VertexInComponent[g,#,{1}]&,outermostMergingVertices];<|"OutermostMergingVertices"->Keys[allParents],(*Gettheresultinggraphaftercontractingtheparentsofthemergingvertexiftheyareapproximatelythesame*)"Graph"->Fold[ContractApproximateVertices[gTable,#1,#2]&,g,Values[allParents]]|>];ContractOutermostMergingEvents[___]:=$Failed;

Contract merging events hierarchically:

In[]:=

ClearAll[ContractMergingEvents];ContractMergingEvents[gTable_Association,g_Graph,maxSteps:_Integer:Infinity]:=Module[{mergingVertices,res},mergingVertices=MergingVertices[g];FixedPoint[Function[assoc,res=ContractOutermostMergingEvents[gTable,assoc["Graph"],assoc["UnvisitedMergingVertices"]];<|"UnvisitedMergingVertices"->Complement[assoc["UnvisitedMergingVertices"],res["OutermostMergingVertices"]],"VisitedMergingVertices"->Join[assoc["VisitedMergingVertices"],res["OutermostMergingVertices"]],res|>],<|"Graph"->g,"UnvisitedMergingVertices"->mergingVertices,"VisitedMergingVertices"->{},"OutermostMergingVertices"->{}|>,maxSteps,SameTest->(#1["UnvisitedMergingVertices"]===#2["UnvisitedMergingVertices"]&)]];ContractMergingEvents[g_Graph,opts:OptionsPattern[ContractMergingEvents]]:=ContractMergingEvents[IndexGraphMapping[g],IndexGraph[g],opts];ContractMergingEvents[___]:=$Failed;ClearAll[ContractMergingEventsList];ContractMergingEventsList[args___]:=Block[{FixedPoint=FixedPointList},ContractMergingEvents[args]];

Gets a subgraph of the merging vertices and their parents:

In[]:=

MergingEventSubgraph[g_Graph,vertices_List]:=Subgraph[g,Join[VertexInComponent[g,vertices,{1}],vertices]]

Visualize the evolution of merging:

In[]:=

ClearAll[StateNetworkEvolutionImages]StateNetworkEvolutionImages[history:{__Association},opts:OptionsPattern[Graph]]:=MovingMap[Apply@Function[{before,after},Rasterize@(Graph[#,opts,VertexLabelsAutomatic,ImageSize550]&)@HighlightGraph[before["Graph"],{MergingEventSubgraph[before["Graph"],after["OutermostMergingVertices"]],after["UnvisitedMergingVertices"],after["VisitedMergingVertices"]}]],history,1];StateNetworkEvolutionImages[_]:=$Failed;

Constructing the finite state networks

Here is an example rule.

In[]:=

testRule$2$2={{1,2},{2,3}}{{2,1},{3,1}};

Construct a state network of hypergraphs with signatures {5, 5} (denoted

In[]:=

hypergraphs$5$2={{5,2}}//EnumerateHypergraphs;

In[]:=

testNetwork2=HypergraphStateNetwork[#->HypergraphEvolve[testRule$2$2,#]&/@hypergraphs$5$2,VertexLabels->None];

Convert the hypergraph state networks to graph networks.

In[]:=

graphStateNetwork=VertexReplace[testNetwork2,Map[#->HypergraphToGraph[#,"UndirectedDistancePreserving"]&,VertexList[testNetwork2]]];

Convert the original graph to an index graph and construct a association mapping indices to graphs.

In[]:=

indexGraphStateNetwork=IndexGraph[graphStateNetwork,VertexSizeAutomatic];

In[]:=

graphTable=Association@Thread[Range[VertexCount[graphStateNetwork]]->VertexList[graphStateNetwork]];

Find all the clusters and highlight them.

In[]:=

clusters=WeaklyConnectedGraphComponents[indexGraphStateNetwork,GraphLayout"LayeredDigraphEmbedding"];HighlightGraph[indexGraphStateNetwork,clusters]

Out[]=

Apply the coarse-graining to one cluster

We demonstrate the procedure of coarse-graining using one example cluster from the state network above.

In[]:=

h=Graph[clusters[[5]],VertexLabelsAutomatic,ImageSize800]

Out[]=

The basic idea of the algorithm is to “bin” together graphs in the state network that are approximately isomorphic. This is achieved by computing the graph spectral distance between 2 graphs, and applying the “binning” if said distance is below the aforementioned threshold.

Some nomenclature: we say a merging event occurs when multiple vertices connect to a single vertex. We call the outgoing vertex “merging vertex”, and the incoming vertices the parents (of the merging vertex).

The algorithm proceeds as follows:

Identify all the merging vertices

Out of those vertices, select the “outermost” ones

Apply the “binning” to the parents of the outermost merging vertices

Compute the distance between any pair of parent vertices

Select distances that are below the threshold

Sort the distances from smallest to largest

Group the selected parents and keep the left-most as the vertex “representative”

Continue until exhausting the list of approximate graphs

Remove the outermost merging vertices from the list of remaining merging vertices

Repeat step 3. until a fixed point is reached

The algorithm is applied hierarchically, meaning that the outermost merging vertices are computed at first, and the inner merging vertices will be computed step-by-step, until there is no change in the list of unvisited vertices.

Compute the evolution of applying the coarse-graining to the initial cluster:

In[]:=

res=ContractMergingEventsList[graphTable,Graph[h,VertexLabelsNone,ImageSize->Small]];

This is a table listing the last two steps of the merging evolution for this cluster. It is observed that the list of unvisited merging vertices becomes empty in the end.

In[]:=

res[[-3;;-2]]//Dataset

Out[]=

The evolution contains information about the unvisited/visited/outermost merging vertices as well as the current state of the network for each step.

Convert the evolution to a list of images.

In[]:=

images=StateNetworkEvolutionImages[res];

A step-by-step animation of how this cluster is coarse-grained can be seen below. The red vertices and edges represent the current merging events, the yellow vertices represent the merging vertices that are not yet visited, and the purple vertices represents the merging vertices that have been visited.

In[]:=

ListAnimate[images,AnimationRunningFalse]

Out[]=

We apply the algorithm to another cluster, and compare the network before and after the coarse-graining.

In[]:=

h2=Graph[clusters[[1]],VertexLabelsNone,ImageSize800];res2=ContractMergingEventsList[graphTable,Graph[h2,VertexLabelsNone,ImageSize->Small]];

This is a table listing the last two steps of the merging evolution for this cluster. It is observed that the list of unvisited merging vertices remains non-empty in the end.

In[]:=

res2[[-3;;-2]]//Dataset

UnvisitedMergingVertices	VisitedMergingVertices	OutermostMergingVertices	Graph
{366,422,511,696,733}	{ … 44 }	{667}
{366,511,696,733}	{ … 45 }	{422}

In[]:=

images2=StateNetworkEvolutionImages[res2];ListAnimate[images2,AnimationRunningFalse]

Out[]=

An interesting observation is that the list of unvisited vertices always ends up in two situations after the algorithm is applied:
1. Empty: which means the coarse-graining procedure ends with a self-looping vertex
2. Non-empty: which means the coarse-graining procedure ends with several vertices forming a cycle

Apply the coarse-graining to the whole network

After studying how the algorithm works for individual clusters, now we apply the coarse-graining to the whole network. This process is repeated multiple times.

In[]:=

evolution=NestList[ContractMergingEvents[graphTable,#]["Graph"]&,indexGraphStateNetwork,4];

In[]:=

TabView[Rasterize/@evolution]

Out[]=

We can compare the number of merging vertices before and after the coarse-graining.

In[]:=

Length@MergingVertices[evolution[[1]]]

Out[]=

245

After 4 applications of the algorithm, one can observe that the coarse-graining has indeed reduced the number of merging vertices.

In[]:=

Length@MergingVertices[evolution[[-1]]]

Out[]=

110

The decrease in the number of merging vertices before and after applying the algorithm can have possible interpretations in physics. For example, one can argue that we can quantify the irreversibility of finite state networks based on the number of merging events.

Remarks on coarse-graining

A feature of our method of coarse graining networks is that we can in principle generate a multiway of all possible course grainings. In 3.4. of the merging procedure described above, when we apply the approximate graph isomorphism algorithm to a group of selected parents, we keep the left-most as the vertex “representative”, but choosing different vertices as the “representative” will lead to a different coarse-graining outcome. Therefore, future work will be carried out to develop such multiway systems.

Future Work

A couple of interesting observations arise during the project, and should be further examined. First of all, although the threshold that determines Approximate Graph Isomorphism is observed to stay roughly constant, graph sets of larger sizes should be examined to achieve a more thorough understanding of the threshold. Secondly, since we have only considered one possible coarse-graining of finite state networks, a multiway of all possible coarse graining can be generated. Thirdly, having a precise way to investigate coarse-graining of finite state networks as we have done here, we can extend it to more general coarse-grainings of phase spaces of dynamical systems beyond the standard nearest neighbor (in phase space) course grainings, and that will be relevant for thermodynamics of systems with multiple scale parameters.

Acknowledgement

I would like to thank my mentors Daniel Sanchez and Xerxes Arsiwalla for their expert advice and continuous encouragement. Shoutout to Daniel for his extra coding tutoring sessions. I would also like to thank Jonathan Gorard, Cameron Beetar, Silvia Hao, and all wonderful mentors and TAs for their help with the project during the summer school. Last but not least, I would like to thank Stephen Wolfram for the amazing insights he provided during our discussions.

References

[1] https://www.edge.org/response-detail/27162
[2] https://www.wolframscience.com/nks/notes-9-3--history-of-thermodynamics/%5D/
[3] https://arxiv.org/pdf/2010.02752.pdf
[4] https://community.wolfram.com/groups/-/m/t/2029394

Cite this as: Jessica Yuan, "[WSS21] Coarse-graining state networks with Approximate Graph Isomorphism" from the Notebook Archive (2021), https://notebookarchive.org/2021-07-62q5dil