# Finding patterns in Graph visualization

Please comment me if you think this question is not related to Mathematica stack exchange.

I am trying to draw a graph representation of the system shown below

As you can see, when red line passes the gray region, it split into two red lines. If two red line pass together (2 and 6 at the third grey region), they make a connection. In this system, there are four grey region, so it makes the connection such as,

{1 <-> 5, 1 <-> 6, 1 <-> 7, 1 <-> 8, 2 <-> 5, 2 <-> 6, 2 <-> 7,
3 <-> 5, 3 <-> 6, 4 <-> 5}


General equation in terms of n (number of gray region) is shown below

Manipulate[
Graph[DeleteCases[
Flatten[Table[
If[i <= n && j <= n + 1 - i, i <-> n + j], {i, 1, 2 n}, {j, 1,
n}]], Null], GraphHighlight -> Table[i, {i, 1, n}],
VertexLabels -> "Name"]
, {n, 1, 20, 1}]


If I draw this system on the Mathematica from n=1 to n=20 , graph representation is shown such as

I was expecting some kind of pattern as I increase the n value. Sadly, it just shows complicated graph, and I do not see any pattern as I increase n value from the graph generated from Mathematica.

Do you think that I can find any pattern from the graph representation using Mathematica?

• Try a different GraphLayout. "StarEmbedding" shows a pattern although I don't know what it means. Jul 17, 2018 at 0:38
• Also look at the AjdacencyMatrix of your graph. Try Graph[...]AdjacencyMatrix // MatrixPlot. You'll see a distinct pattern there, showing the evolution of two clusters bridged by an initial set of nodes. Jul 17, 2018 at 0:42
• Also look at ListPlot@VertexDegree@Graph[...] Jul 17, 2018 at 0:47
• @b3m2a1 Thank you! I think GraphLayout really helps me to see the pattern. Jul 17, 2018 at 0:56
• also GraphLayout->"BipartiteEmbedding" ?
– kglr
Jul 17, 2018 at 5:11

As mentioned in a comment, you can see these patterns three ways:

The first is using GraphLayout -> "StarEmbedding", e.g. in:

Graph[
Flatten[
Table[
If[i <= n && j <= n + 1 - i, i <-> n + j, Nothing],
{i, 1, 2 n},
{j, 1, n}
]
],
GraphHighlight -> Table[i, {i, 1, n}],
VertexLabels -> "Name",
GraphLayout -> "StarEmbedding"
]


This gives you:

where you see two groups evolve or something like that.

The second option is to view the AdjacencyMatrix directly, via:

MatrixPlot@AdjacencyMatrix@
Flatten[
Table[
If[i <= n && j <= n + 1 - i, i <-> n + j, Nothing],
{i, 1, 2 n},
{j, 1, n}
]
]


This gives:

A final way to see this evolution is plotting the VertexDegree of the vertices (helpfully they're indexed so we don't need to extract the VertexList to Thread into the degrees). This is done via:

ListPlot@VertexDegree@
Flatten[
Table[
If[i <= n && j <= n + 1 - i, i <-> n + j, Nothing],
{i, 1, 2 n},
{j, 1, n}
]
]


And then you get:

All these show the evolution of the distinct groups

• Wow! Excellent!
– JimB
Jul 17, 2018 at 17:25

Since we have a bipartite graph for every n

And @@ Table[BipartiteGraphQ @ Graph[Flatten[Table[
If[i <= n && j <= n + 1 - i, i <-> (n + j), ## &[]], {i, 1, 2 n}, {j, 1, n}]]],
{n, 1, 20}]


True

we can use Graphlayout -> "BipartiteEmbedding" which reveals a nice pattern with the first n and the last n vertices sorted by vertex degree:

frames1 = Table[Graph[Flatten[Table[
If[i <= n && j <= n + 1 - i, i <-> (n + j), ## &[]], {i, 1, 2 n}, {j, 1, n}]],
GraphHighlight -> Table[i, {i, 1, n}],
VertexLabels -> "Name", ImagePadding -> 10,
ImageSize -> {300, 300}, GraphLayout -> "BipartiteEmbedding"],
{n, 1, 20}];
Export["graph.gif", frames1]


If we use the first argument of Graph to have the vertices in a particular order, using b3m2a1'a idea of MatrixPlotting the AdjacencyMatrix gives a simpler pattern:

frames2 = Table[MatrixPlot[AdjacencyMatrix@
Graph[Join[Range@n, Reverse[Range[n + 1, 2 n]]],
Flatten[Table[If[i <= n && j <= n + 1 - i, i <-> (n + j), ## &[]],
{i, 1, 2 n}, {j, 1, n}]]]], {n, 1, 20}];
Export["matrixplot.gif", frames2]


Similarly for the ListLinePlot of VertexDegrees:

frames3 = Table[vertices = Join[Range@n, Reverse[Range[n + 1, 2 n]]];
ListLinePlot[MapIndexed[Labeled[{Rescale[#2[[1]], {1, 2 n}, {-n, n}], #},
vertices[[#2[[1]]]], If[#2[[1]] <= n, Before, After]] &, VertexDegree @ #] &@
Graph[vertices, Flatten[Table[If[i <= n && j <= n + 1 - i, i <-> (n + j), ## &[]],
{i, 1, 2 n}, {j, 1, n}]]],
PlotRange -> {{-22, 22}, {0, 21}}, BaseStyle -> PointSize[Medium],
AspectRatio -> 1, Axes -> False, Frame -> False,
Mesh -> {Join @@ (Thread /@ {{-#, Red}, {#, Blue}}) &@ Range[2 n + 1]}],
{n, 1, 20}];
Export["llplot.gif", frames3]


• Your second argument is probably somewhere where you wanted Animate? You can also export a List of objects as an animated GIF. Jul 17, 2018 at 21:24
• @b3m2a1, I use ScreenToGif (to edit size/ frame rate to stay within the 2mb limit) for gifs to post on this site, and Clock trick i find convenient to get an animation without controls.
– kglr
Jul 17, 2018 at 21:29
• Okay. I figured it was a screen capture given the mild joltiness of the thing. Just thought it might be useful for the GIF smoothing here :) Jul 17, 2018 at 21:31
• @b3m2a1, thanks for the suggestion; updated with a smoother version.
– kglr
Jul 17, 2018 at 21:48
• Very nice. I prefer your plots to mine. Jul 17, 2018 at 21:49