The Diffusion Operator and Graphs in Mathematica.

--Jason Cantarella, January 2021. 
MATH/CSCI 4690/6690 Course Materials.

We are going to start by learning how to define some graphs in Mathematica:

CycleGraph4 = Graph[{1,2,3,4},{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]1}]

PathGraph4 = Graph[{1,2,3,4},{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4}]

CompleteGraph4 = Graph[{1,2,3,4},{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]4,2\[UndirectedEdge]3,2\[UndirectedEdge]4,3\[UndirectedEdge]4}]

Now actually all of these are built-in to Mathematica:

CycleGraph[153]

PathGraph[Range[7]]

CompleteGraph[17]

We can create adjacency matrices in Mathematica as well:

AdjacencyMatrix[PathGraph4]  // MatrixForm

AdjacencyMatrix[CycleGraph4] // MatrixForm

AdjacencyMatrix[CompleteGraph4] // MatrixForm

DegreeMatrix[G_] := DiagonalMatrix[VertexDegree[G]]

DegreeMatrix[PathGraph4] // MatrixForm

DegreeMatrix[CycleGraph4] // MatrixForm

DegreeMatrix[CompleteGraph[4]] // MatrixForm

Now we can construct the diffusion operator using our theorem:

DiffusionOperator[G_] := AdjacencyMatrix[G].Inverse[DegreeMatrix[G]]

And recheck the diffusion operator for our favorite examples:

DiffusionOperator[CycleGraph4] // MatrixForm

DiffusionOperator[PathGraph4] // MatrixForm

DiffusionOperator[CompleteGraph4] // MatrixForm

We can now think about the effect of diffusion after taking a large number of steps. We’ll want to make some pictures, so here’s some code which plots a function over a graph:

GraphFunctionPlot[𝒢_?GraphQ,p_,scale_] := Block[{low,hi,faces},
low = scale(Append[#,0] & /@GraphEmbedding[𝒢]);
hi = scale(Append @@@ Transpose[{GraphEmbedding[𝒢],p}]);
faces = Flatten /@ Transpose[{#,VertexCount[𝒢]+(Reverse/@#)}]&@ Map[VertexIndex[𝒢,#]&,List@@@EdgeList[𝒢],{2}]; 
Show[GraphPlot3D[Graph[VertexList[𝒢],EdgeList[𝒢],VertexCoordinates->#],VertexSize->Small]& /@ {low,hi},
Graphics3D[{Opacity[0.9],LightBlue,GraphicsComplex[Join[low,hi],Polygon[faces]]}]
,ImageSize->Medium]
]/; TrueQ[Length[p] == VertexCount[𝒢]]

GraphFunctionPlot[𝒢_?GraphQ,p_] := GraphFunctionPlot[𝒢,p,1.0]

GraphFunctionPlot[PathGraph[Range[25]],ConstantArray[1,25]]

DF[G_] := Manipulate[{# // MatrixForm,GraphFunctionPlot[G,Flatten@#]}&@(N@MatrixPower[DiffusionOperator[G],n].SparseArray[{3,1}->1,{VertexCount[G],1}]),{n,1,50,1}]

DF[CompleteGraph[6]]

It’s this kind of thing which motivates us to consider the “lazy random walk”, where the walker remains in place with probability 0.5 and takes a diffusion step with probability 0.5. This walk is modeled by the operator:

LazyWalkOperator[G_] := (1/2)IdentityMatrix[VertexCount[G]] + (1/2)DiffusionOperator[G]

LW[G_] := Manipulate[{# // MatrixForm,GraphFunctionPlot[G,Flatten@#]}&@(N@MatrixPower[LazyWalkOperator[G],n].SparseArray[{3,1}->1,{VertexCount[G],1}]),{n,1,1000,1}]

LW[CompleteGraph[6]]

This motivates a lot of interesting questions. For instance, what about a random graph?

LW[RandomGraph[{7,18}]]