Dual graph of an arbitrary (planar) graph

Update: obviously incorrect statements are removed.

I think WM doesn't include DualGraph-function because it is usually multigraph and non unique.

As far as I have read in Wikipedia a dual graph $G^*$ depends on planar embedding of $G$. If you ask for a some dual graph for a given graph, then here is my brute force heuristic algorithm. It is based on algorithm (given below) which yields the faces (and I do not guarantee that it is correct):

The pseudo-code is as follows:

1. pseudofaces={}
2. graph0 = spanning tree of graph
3. edges0 = all edges of graph which are not in graph0
4. While edges0 is non empty
   1. find edge from edges0 such that its vertices have shortest path in graph0
   2. Append path to pseudofaces
   3. Remove edge from edges0
   4. Add edge to graph0
5. return pseudofaces

Here is Mathematica implementation.

(* simple Kruskal's algorithm without sorting *) SpanningTree[graph_] := Module[{label, edges = EdgeList[graph]}, Pick[edges, Table[If[UnsameQ[#1, #2], #2 = #1; True, False] & @@ Sort[label /@ edge], {edge, edges}]]] 

It yields a spanning tree:

graph = GridGraph[{5, 9}]; HighlightGraph[graph, SpanningTree[graph]] 

makeEges[list_] := Sort /@ UndirectedEdge @@@ Partition[list, 2, 1] (* FindFace : finds the smallest cycle. This cycle is a pseudo-face. *) FindFace[graph_, edges_] := MapAt[makeEges, First@SortBy[Transpose[{FindShortestPath[graph, Sequence @@ #] & /@ edges, edges}], Composition[Length, First]], 1] (* Append analyzed edge to a graph *) appendEge[graph_, edge_] := Graph@Append[EdgeList[graph], edge] iteration[graph_, {}] := $faces; iteration[graph_, edges_] := iteration[AppendTo[$faces, Flatten[#]]; appendEge[graph, Last@#], DeleteCases[edges, Last@#]] &[FindFace[graph, edges]] (* Faces : returns all pseudo-faces of a graph *) Faces[graph_] := Block[{$faces = {}, tree = SpanningTree[graph]}, iteration[Graph[tree], Complement[EdgeList[graph], tree]]] 

It works as follows:

faces = Faces[graph]; Manipulate[HighlightGraph[graph, faces[[n]]], {n, 1, Length@faces, 1}] 

The last step is to construct the dual graph from the faces:

 shareQ[set1_, set2_] := Length@Intersection[set1, set2] > 0; (* connecting all faces *) innerDualEdges[faces_] := Join @@ Table[ Table[If[shareQ @@ faces[[{i, j}]], UndirectedEdge[i, j], Unevaluated@Sequence[]], {j, i + 1, Length[faces]}], {i, 1, Length[faces] - 1}] (* next two functions find the faces on the boundary *) boundaryEdges[faces_] := Module[{edges = Join @@ faces}, Select[Union[edges], (Count[edges, #] == 1) &]] boundaryFaces[faces_, outerEdges_] := Select[Range@Length@faces, shareQ[faces[[#]], outerEdges] &]; (* altogether *) DualGraph[faces_] := Graph[DeleteDuplicates@Join[innerDualEdges[faces], Thread@UndirectedEdge[0, boundaryFaces[faces, boundaryEdges[faces]]]]] 

That's all.

 DualGraph[faces] 

If you do not consider the outer space as a face, then you can ask:

 Graph[innerDualEdges[faces]] 

You can also compare it with Mathematica internals:

 IsomorphicGraphQ[GraphData["IcosahedralGraph", "DualGraph"], DualGraph[Faces[GraphData["IcosahedralGraph"]]]] (* True *) 

Full notebook is available here.

DualPlanarGraph is a new function in Mathematica 13.0. It works with directed graphs and multigraphs.

IGraph/M now includes functionality to find the faces of a planar graph, or to find the dual graph.

Demo:

g = IGTriangularLattice[3, VertexShapeFunction -> "Name"] 

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

The vertices of the dual are in the same order as the result of IGFaces.