Mathematica Stack Exchange is a question and answer site for users of Mathematica. Join them; it only takes a minute:

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

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

enter image description here

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])

share|improve this question
2  
Define "face", please – Dr. belisarius Jan 26 '13 at 18:37
    
@belisarius think of the faces of a cube. – Sjoerd C. de Vries Jan 26 '13 at 18:53
    
Are you sure that you are on the right site? This site is dedicated to the program MathematicA, not to MathematicS. – Sjoerd C. de Vries Jan 26 '13 at 18:55
2  
Do you already have the a layout of the graph (the vertex coordinates for each vertex)? If not, there probably isn't any already implemented simple existing way in Mathematica to lay out the graph without crossing edges. – Szabolcs Jan 27 '13 at 3:41
3  
The difficulty here is that before you can talk about faces, you need to find an actual embedding of the graph in the plane, without crossing edges. None of Mathematica's built-in layout algorithms will guarantee you this. – Szabolcs Jan 27 '13 at 4:03

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

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

enter image description here

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}]}]

enter image description here

You could use the precomputed coordinates if you want like:

g = GridGraph[{3, 3}]

enter image description here

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.

share|improve this answer
    
"... will find all faces including the external face" Should be easy to filter that out, if the OP chooses to, since it has the max area. Nice answer :) – R. M. Jan 29 '13 at 16:03
    
Your code seem to not work in 10.4 any more.And at this problem I have a same thinking in this post – yode Apr 8 at 14:14
    
@yode I just checked on 10.4 and it works fine. What is not working? – halmir Apr 8 at 16:27
    
Sorry.In my dormitory pc it work well,but the office not.I'll check it again tomorrow. – yode Apr 8 at 16:59

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.

share|improve this answer

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}}]

enter image description here

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}]}]

enter image description here

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}} *)

enter image description here

share|improve this answer
    
g1 uses predefined coordinates, so to generate corresponding faces you should use the second argument (second example in my answer): FindFace[g1, GraphEmbedding[g1]]. And FindFace generate all faces including outer like I mentioned. Here it's the largest one. To filter out, you can try faces = Most[SortBy[FindFace[g1, GraphEmbedding[g1]], Length]] – halmir Apr 11 at 13:39
    
@halmir - now I feel pretty stupid lol :-) I'm new to graphs and computational geometry. – JasonB Apr 11 at 13:45
    
@halmir - but it won't always be the largest one by number of vertices, right? It would always be the largest one by Area though, so a foolproof method might be Most[SortBy[FindFace[g1, GraphEmbedding[g1]], Area[Polygon[coord[[#]]]] &]] – JasonB Apr 11 at 13:54
    
yes, to be safe.. – halmir Apr 11 at 14:04

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.