Correlation Functions
Correlation Functions
GraphCorrelationFunction[g_,2]:=Module[{gg=IndexGraph[UndirectedGraph[g]],gnv,vl,gdist},gnv=GraphNeighborhoodVolumes[g,All,Automatic];vl=VertexList[gg];gdist=GraphDistanceMatrix[gg];KeySort[Mean/@(Map[Last]/@GroupBy[{gdist[[#1,#2]],gnv[#1]gnv[#2]}&@@@Tuples[{vl,vl}],First])]]
In[]:=
GraphCorrelationFunction[g_,1]:=Module[{gg=IndexGraph[UndirectedGraph[g]],gnv,vl,gdist},Mean[GraphNeighborhoodVolumes[g,All,Automatic]^2]]
In[]:=
MeanVR[g_]:=Mean[Values[GraphNeighborhoodVolumes[UndirectedGraph[g],All,Automatic]]]
In[]:=
With[{w=MeanVR[gtest]},#-w^2&/@GraphCorrelationFunction[gtest,2]]//N
In[]:=
Out[]=
ListLogPlot[Abs[Transpose[Values[%273]]],JoinedTrue]
In[]:=
Out[]=
With[{gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},11,"FinalState"]]},With[{w=MeanVR[gtest]},#-w^2&/@GraphCorrelationFunction[gtest,2]]//N]
In[]:=
Out[]=
ListPlot[Take[Transpose[Values[%277]],7],JoinedTrue]
In[]:=
Out[]=
Take[Transpose[Values[%277]],7]
In[]:=
Out[]=
ListLinePlot[Take[%,4]]
In[]:=
Out[]=
With[{gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},12,"FinalState"]]},With[{w=MeanVR[gtest]},#-w^2&/@GraphCorrelationFunction[gtest,2]]//N]
In[]:=
Out[]=
Take[Transpose[Values[%]],5]
In[]:=
Out[]=
ListLinePlot[%286[[2]]]
In[]:=
Out[]=
ListLinePlot[%286[[3]]]
In[]:=
Out[]=
ListLinePlot[%286[[4]]]
In[]:=
Out[]=
With[{gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},12,"FinalState"]]},With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N]
In[]:=
Out[]=
Take[Transpose[Values[%]],5]
In[]:=
Out[]=
ListLinePlot[%]
In[]:=
Out[]=
ListLinePlot[Take[Transpose[Values[%290]],12]]
In[]:=
Out[]=
ListLinePlot[Take[Transpose[Values[%290]],-5]]
In[]:=
Out[]=
With[{gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},11,"FinalState"]]},With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N];
In[]:=
ListLinePlot[Take[Transpose[Values[%]],12]]
In[]:=
Out[]=
With[{gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},13,"FinalState"]]},With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N];
In[]:=
ListLinePlot[Take[Transpose[Values[%]],12]]
In[]:=
Out[]=
Summary:
Summary:
[[ Note : 1 on x axis should be 0 ]]
,
With[{gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},14,"FinalState"]]},With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N];
In[]:=
gtest=UndirectedGraph[Rule@@@WolframModel[{{x,y},{x,z}}{{x,z},{x,w},{y,w},{z,w}},{{1,2},{1,3}},10,"FinalState"]]
In[]:=
Out[]=
BuckyballGraph[6]
Tests
Tests
Torus
Torus
With[{gtest=IndexGraph[TorusGraph[{10,10}]]},With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N]
In[]:=
Out[]=
Buckyball
Buckyball
With[{gtest=IndexGraph[BuckyballGraph[6]]},With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N]
In[]:=
Out[]=
ListLinePlot[Take[Transpose[Values[%]],12]]
In[]:=
Out[]=
Sierpinski
Sierpinski
Graph/@Apply[UndirectedEdge,(WolframModel[{{0,1},{2,1}}{{0,2}},#,"FinalState"]&)/@WolframModel[{{0,1},{0,2},{0,3}}{{4,5},{6,5},{4,7},{8,7},{6,9},{8,9},{4,1},{6,2},{8,3}},{{0,1},{2,1},{0,3},{4,3},{0,5},{6,5},{2,7},{4,7},{2,8},{6,8},{4,9},{6,9}},4,"StatesList"],{2}]
In[]:=
Out[]=
Withgtest=IndexGraph
,With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N;
In[]:=
ListLinePlot[Take[Transpose[Values[%]],12]]
In[]:=
Out[]=
Withgtest=IndexGraph
,With[{w=MeanVR[gtest]},(#-w^2)/w^2&/@GraphCorrelationFunction[gtest,2]]//N;
In[]:=
ListLinePlot[Take[Transpose[Values[%]],12]]
In[]:=
Out[]=