Finding patterns in Graph visualization

Question

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?

Answer 1

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

Answer 2

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]