Finding face vertices from the face adjacency graph

Question

I have a question about face adjacency graphs.

Suppose that I have an adjacency matrix

M = {{0, 1, 0, 0, 1, 1, 0, 0}, 
     {1, 0, 1, 0, 0, 0, 0, 1},  
     {0, 1, 0, 1, 0, 0, 1, 0}, 
     {0, 0, 1, 0, 1, 0, 1, 0}, 
     {1, 0, 0, 1, 0, 1, 0, 0}, 
     {1, 0, 0, 0, 1, 0, 0, 1}, 
     {0, 0, 1, 1, 0, 0, 0, 1}, 
     {0, 1, 0, 0, 0, 1, 1, 0}}

that is known to be a planar graph. So I use the command GraphPlot[M] and give vertex labeling. The result is

There are 5 faces in the figure (exclude the outer face). The set of vertices of the faces is {{1,6,8,2}, {1,6,5},{4,5,6,8,7},{3,4,7},{2,3,7,8}}.

I don't know how to find this list of vertices automatically if I enter any adjacency matrix (I'm sure that all picked matrices are planar graphs due to PlanarGraph[M])

Answer 1

As Szabolcs mentioned, you could use ordering (PlanarEmbedding) to find faces.

g = AdjacencyGraph[M, GraphLayout -> "PlanarEmbedding", 
             VertexLabels -> "Name", ImagePadding -> 5]

The following function will find next vertex of the face based on the given planar embedding:

nextCandidate[s_, t_, adj_] :=
   Block[{ length, pos},
      length = Length[adj];
      pos = Mod[Position[adj, s][[1, 1]] + 1, length, 1];
      {t, adj[[pos]]}
    ];

The main function to get all faces:

FindFace[g_?PlanarGraphQ] :=
   Block[{emb},
      emb = GraphEmbedding[g, "PlanarEmbedding"];
      FindFace[g, emb]
   ];

FindFace[g_?PlanarGraphQ, emb_] :=
   Block[{m, orderings, pAdj, rightF, s, t, initial, face},
       m = AdjacencyMatrix[g];
       Table[pAdj[v] = 
           SortBy[Pick[VertexList[g], m[[v]], 1], 
           ArcTan @@ (emb[[v]] - emb[[#]]) &], {v, VertexList[g]}];
       rightF[_] := False;
       Reap[
         Table[
           If[! rightF[e],
             s = e[[1]];
             t = e[[2]];
             initial = s;
             face = {s};
             While[t =!= initial,
               rightF[UndirectedEdge[s, t]] = True;
               {s, t} = nextCandidate[s, t, pAdj[t]];
               face = Join[face, {s}];
             ];
             Sow[face];
           ],
         {e, EdgeList[g]}]][[2, 1]]
     ]

For example,

In[162]:= faces = FindFace[g]
Out[162]= {{1, 2, 8, 6}, {1, 5, 4, 3, 2}, {1, 6, 5}, {2, 3, 7, 8}, {3,
     4, 7}, {4, 5, 6, 8, 7}}

coord = GraphEmbedding[g]; 
Graphics[{EdgeForm[Directive[Black, Thick]], 
 Thread[{ColorData[3, "ColorList"][[;; Length[faces]]], 
           Polygon[coord[[#]]] & /@ faces}]}]

You could use the precomputed coordinates if you want like:

g = GridGraph[{3, 3}]

In[166]:= FindFace[g, GraphEmbedding[g]]
Out[166]= {{1, 2, 5, 4}, {1, 4, 7, 8, 9, 6, 3, 2}, {2, 3, 6, 5}, {4, 
     5, 8, 7}, {5, 6, 9, 8}}

Note that this function will find all faces including the external face.

Hope this help you to start this.

Answer 2

As Sjoerd noted, version 9 includes a layout algorithm that will avoid edge crossings if the graph is planar. This is the most difficult part of the task, but once you have the planar embedding, it is relatively easy to find the faces.

You can start by finding counterclockwise orderings of vertices around any vertex. Let g be the planar graph, then

emb = GraphEmbedding[g, "PlanarEmbedding"]
m = AdjacencyMatrix[g]

orderings = Table[
  SortBy[
   Pick[VertexList[g], m[[v]], 1],     (* all neigbours of v *)
   ArcTan @@ (emb[[v]] - emb[[#]]) &
  ],
  {v, VertexList[g]}
 ]

Based on this information you can walk the vertices belonging to each face, you just need to make sure you never make a turn greater than 180 degrees.

I don't have time to finish implementing this. I hope this information was helpful and you'll be able to program it.

Answer 3

The answer proposed by halmir is very efficient and will give a list featuring all the internal faces along with one face that represents the outer perimeter, but the outer face is not always at the same point in the list, and plotting the polygons sometimes results in obscuring some internal faces.

Consider the following graph,

g1 = AdjacencyGraph[{{0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0}, {1, 0, 1, 
    0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 
    0}, {1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0}, {1, 0, 0, 0, 0, 1, 0, 1,
     0, 0, 0, 0}, {0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0}, {0, 0, 0, 1, 
    0, 1, 0, 0, 0, 0, 0, 1}, {0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0}, {0,
     0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 
    0, 0}, {0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 1,
     0, 0, 0, 1, 0}},
  GraphLayout -> "PlanarEmbedding", 
  VertexCoordinates -> {{0.68, 0.88}, {0.84, 0.85}, {1.12, 
     0.89}, {0.33, 1.13}, {0.81, 0.33}, {0.43, 0.33}, {0.15, 
     1.13}, {0.96, 0.33}, {1.12, 0.33}, {1.12, 1.13}, {-0.12, 
     0.33}, {-0.12, 1.13}}]

The above algorithm will give

faces = FindFace[g1,GraphEmbedding[g1]];
coord = GraphEmbedding[g1];
Graphics[{EdgeForm[Directive[Black, Thick]], 
  Thread[{ColorData[3, "ColorList"][[;; Length[faces]]], 
    Polygon[coord[[#]]] & /@ faces}]}]

which has the polygons in such an order that you can't see all internal faces. The obvious solution (obvious after halmir pointed it out to me) is to remove the element with the largest area. But, as often happens to me, I had spent some time writing a code that does the same thing but much slower (because I didn't think halmir's code worked on the above graph).

The algorithm I propose should output the list of non-overlapping polygons from the input graph. The idea is to use FindCycles to get a full list of cycles from the graph, then sort this list in terms of the resulting polygon area. We know that the smallest polygon is one we want to keep. Then we look at the rest of the polygons, keeping only those with zero overlap with the current list of faces. This is the slow step, because it uses RegionIntersection to determine whether two polygons overlap.

I use a While loop to make sure that we stop looking at the cycles once we have enough for a complete basis.

graphToFaces[graph_?PlanarGraphQ] := Module[{graphpoints, cycles, polygons, n},
  graphpoints = GraphEmbedding[graph];
  cycles = 
   Polygon[graphpoints[[#]]] & /@ 
    FindCycle[graph,  Max[Length /@ FindFundamentalCycles[graph]], All][[All, All, 2]];
  cycles = SortBy[cycles, Area];
  polygons = {cycles[[1]]};
  n = 2;
  While[Length@polygons < Length@FindFundamentalCycles@graph && 
    n <= Length@cycles,
   If[
    And @@ (Area[Rationalize@cycles[[n]], Rationalize@ #]] === 0 & /@ 
       polygons),
    AppendTo[polygons, cycles[[n]]]
    ];
   n++
   ];
  First /@ (polygons /. 
     Thread[graphpoints -> Range@Length@graphpoints])
  ]

Applied to the problem above,

faces = graphToFaces[g1]
coord = GraphEmbedding[g1];
Graphics[{EdgeForm[Directive[Black, Thick]], 
  Thread[{ColorData[3, "ColorList"][[;; Length[faces]]], 
    Polygon[coord[[#]]] & /@ faces}]}]
(* {{5, 8, 2, 1}, {9, 8, 2, 3}, {2, 3, 10, 4, 1}, {5, 6, 7, 4, 
  1}, {11, 12, 7, 6}} *)

Answer 4

IGraph/M now has functionality to find the faces of a planar graph and to find the dual graph.

g = AdjacencyGraph[M]

IGFaces[g]
(* {{1, 2, 8, 6}, {1, 6, 5}, {1, 5, 4, 3, 2}, {2, 3, 7, 8}, {3, 4, 7}, {4, 5, 6, 8, 7}} *)

This finds all faces, including the outer face. Which face to consider the outer one is arbitrary. It cannot be inferred from the connectivity alone.

Here are six different planar drawings of your graph. The outer face is different in each:

IGLayoutTutte[g, "OuterFace" -> #, VertexShapeFunction -> "Name"] & /@ IGFaces[g]

To find the dual graph, use

dg = IGDualGraph[g]

The vertices of the dual come in the same order as the output of IGFaces. Let's label them:

Graph[dg, VertexLabels -> Thread[VertexList[dg] -> HoldForm /@ IGFaces[g]]]

Answer 5

You can use PlanarFaceList https://reference.wolfram.com/language/ref/PlanarFaceList.html

M = {{0, 1, 0, 0, 1, 1, 0, 0}, 
     {1, 0, 1, 0, 0, 0, 0, 1},  
     {0, 1, 0, 1, 0, 0, 1, 0}, 
     {0, 0, 1, 0, 1, 0, 1, 0}, 
     {1, 0, 0, 1, 0, 1, 0, 0}, 
     {1, 0, 0, 0, 1, 0, 0, 1}, 
     {0, 0, 1, 1, 0, 0, 0, 1}, 
     {0, 1, 0, 0, 0, 1, 1, 0}}

A = AdjacencyGraph[M, DirectedEdges -> False, GraphLayout -> "PlanarEmbedding", 
             VertexLabels -> "Name", ImagePadding -> 5];

Faces = PlanarFaceList[A]

Output = {{1, 2, 3, 4, 5}, {1, 5, 6}, {1, 6, 8, 2}, {2, 8, 7, 3}, {3, 7, 4}, {4, 7, 8, 6, 5}}

However, this includes the outer face.