# 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. – b3m2a1 Jul 17 '18 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. – b3m2a1 Jul 17 '18 at 0:42
• Also look at ListPlot@VertexDegree@Graph[...] – b3m2a1 Jul 17 '18 at 0:47
• @b3m2a1 Thank you! I think GraphLayout really helps me to see the pattern. – Saesun Kim Jul 17 '18 at 0:56
• also GraphLayout->"BipartiteEmbedding" ? – kglr Jul 17 '18 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 '18 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, 2 n}, {-n, n}], #},
vertices[[#2[]]], If[#2[] <= 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. – b3m2a1 Jul 17 '18 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 '18 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 :) – b3m2a1 Jul 17 '18 at 21:31
• @b3m2a1, thanks for the suggestion; updated with a smoother version. – kglr Jul 17 '18 at 21:48
• Very nice. I prefer your plots to mine. – b3m2a1 Jul 17 '18 at 21:49