Dual Graph

Author

Eric W. Weisstein
August 14, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/DualGraph.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/DualGraph.html.

©2024 Wolfram Research, Inc. except for portions noted otherwise

DualPlanarGraph

g=GraphData["K4"]

Show[DualPlanarGraph[g,PlotTheme->"Business"],g]

Options[DualPlanarGraph[g],VertexCoordinates]

Compute

GraphData[All];

<<MathWorld`Graphs`

Do[Print[RecognizeGraph[RandomGraph[{n,5}]];//Timing],{n,8,10}]

data=Monitor[{
g=#,
RecognizeGraph[DualGraph[GraphData[#]]],
GraphData[#,"DualGraph","Name"]
}&/@GraphData["Polyhedral"],g];//Timing

Computed dual agrees with "DualGraph" name:

TextGrid[Cases[data,{g_,x_,x_}:>{g,x}],Dividers->All]

Computed dual disagrees with "GraphDual" name:

DeleteCases[data,{g_,x_,x_}|{g_,x_,_Missing}]

Self-dual:

Cases[data,{g_,_,g_}:>g]

Indicated as self-dual but isn't:

Complement[GraphData["SelfDual"],Cases[data,{g_,_,g_}:>g]]

Self-dual but not indicated as such:

selfdualnew=Complement[Cases[data,{g_,_,g_}:>g],GraphData["SelfDual"]]

Computed dual is named but not present in GraphData:

DeleteCases[data,{g_,{},_}|{g_,_,_?DataPaclets`GraphDataDump`MyGraphQ}]

Computed dual is present in GraphData but has undefined "GraphDual" name:

new=Cases[data,{g_,x_?DataPaclets`GraphDataDump`MyGraphQ,_Missing}:>{g,x}]

Add SelfDual class to GraphData

l={#,{0,True}}&/@selfdualnew

MissingFillin[l,"SelfDual"]

RenameGraphFiles[]

Add to DualName GraphData

l={#,{0,#2}}&@@@new

PropertyFillin[l,"DualGraphName","13.1"]

RenameGraphFiles[]

Self

Enumeration

Self-Duals

GraphData["SelfDual"]

Duals

Union[Sort[GraphData[#,{"StandardName","DualGraphName"}]]&/@GraphData["DualGraphName","Defined"]]//Column

Duals on 8-node graphs

Select graphs that have unique duals

uniqdual=Select[GraphData["Planar"],GraphData[#,"VertexConnectivity"]≥3&]

GraphData properties

Select[GraphData["Properties"],StringMatchQ["*CrossingNumber"]]

Surfaces

Klein bottle [KleinBottleCrossingNumber]

K_6 can be  triangulated both on the projective plane and Klein bottle, so its dual is ambiguous (Petersen or Franklin) unless the surface is specified.

((Subscript[K, 6]), Franklin)

Klein bottle + projective plane

(Subscript[K, 6])

Plane/Sphere [CrossingNumber]

Polyhedral graphs have unique dual graphs. While some nonpolyhedral planar graphs also have a unique dual, a general planar graph has multiple dual graphs depending on the choice of planar drawing. A planar graph has a unique embedding, and consequently a unique dual, iff it is a subdivision of a polyhedral graph. The complete bipartite graph  is an example of a planar nonpolyhedral graph that is not 3-vertex-connected but whose embeddings are all isomorphic, meaning its dual graphs are also isomorphic.

GraphData["K3,3","DualGraph"]

GraphDual[Graph["K3,3"]]

Projective Plane [ProjectivePlaneCrossingNumber]

K_6 can be  triangulated both on the projective plane and Klein bottle, so its dual is ambiguous (Petersen or Franklin) unless the surface is specified.

((Subscript[K, 6]), P)

Map[GraphData[#,"ProjectivePlaneCrossingNumber"]&,{{"K6","P"}},{2}]

Torus [ToroidalCrossingNumber]

((Subscript[K, 7]), Heawood) , (Dyck, Shrikhande)

Map[GraphData[#,"ToroidalCrossingNumber"]&,{{"K7","HeawoodGraph"},{"DyckGraph","ShrikhandeGraph"}},{2}]

Torus + Klein bottle

Lawrencenko and Negami

Serge Lawrencenko and Seiya Negami, Constructing the Graphs That Triangulate Both the Torus and the Klein Bottle   -- there are some graphs with triangular embeddings on both the torus and Klein.

There exists precisely one graph, L, which admits irreducible triangulations of both the torus and the Klein bottle.

etl=Union[
Sort/@Partition[{4,7,2,3,4,2,7,4,3,2},2,1,1],
Sort/@Partition[{6,8,5,1},2,1],
Sort/@Partition[{2,6,7,8,4,5,3,1,2,4,1,7,5,2,8,3,6,4},2,1,1]
]

tl=System`Graph[Range[8],UndirectedEdge@@@etl,VertexLabels->"Name",VertexCoordinates->{{3+1/2,1},{2,0},{3,0},{0,0},{5/2,1},{1/2,1},{1,0},{3/2,1}}]

ekl=Union[
Sort/@Partition[{2,1,7,4,6,3,2,4,6,3,2,1,7,4},2,1,1],
Sort/@Partition[{2,7,6,2,4,3,1,4},2,1,1],
{{2,5},{4,5},{7,8},{3,5},{2,8},{4,8},{1,5},{3,8},{5,7},{6,8},{5,8}}
]

kl=System`Graph[Range[8],UndirectedEdge@@@etl,VertexLabels->"Name",VertexCoordinates->{{0,1/2},{1,0},{0,2+1/2},{0,1+1/2},{3/2,1},{1/2,2},{1/2,1},{3/2,2}}]

System`VertexConnectivity[tl]

RecognizeGraph@kl

VertexCount[tl]

group=GraphAutomorphismGroup[tl]

GroupOrder[group]

AbelianGroupQ[group]

As a graph join:

g2=CombinatoricaGraphToV8Graph[GraphJoin[GraphJoin[Path[4],EmptyGraph[2]],CompleteGraph[2]]]

IsomorphicGraphQ[g2,tl]

System`Graph@EdgeList[g2]

HamiltonianGraphQ[g2]

Length[hc=FindHamiltonianCycle[g2,All][[All,All,1]]]

LCF[g2,All]

Tally[%[[All,2]]]

g=First[LCFGraph@@@%]

PlanarGraphQ[g]

GraphIndex[g]

GraphEmbedding[g]//Chop

file=OpenWrite["~/kleintorus.m"]

WriteString[file,GraphDataString[g,
"StandardName"->"UniqueTorusAndKleinBottleTriangulationGraph",
"Name"->"unique torus and Klein bottle triangulation graph",
TimeConstraint->60]]

Close[file]

Datta and Upadhyay

https://arxiv.org/abs/math/0403433v1: Basudeb Datta, Ashish Kumar Upadhyay.  Degree-regular triangulations of torus and Klein bottle

Stan Wagon's Code

Excerpted from Mathematica in Action, 2nd ed.

<<GraphColoring`
<<CombinatoricaVersion1`

SimpleGraph[g_MultiGraph]:=Graph[Replace[#,l_List:>1,2]&/@g[[1]],g[[2]]]

Cycle[4] Fails

ShowGraph[graph=Cycle[4]]

FindPlanarEmbedding[graph]

planar=PlanarGraphToPlanarMap[FindPlanarEmbedding[graph]]

ShowMap[planar]

PlanarGraph@@graph

planar=PlanarGraphToPlanarMap[PlanarGraph@@graph]

ShowMap[planar]

planar=FindPlanarEmbedding[graph];
dual=DualMultiGraph[PlanarGraphToPlanarMap[planar],StraightenEdges->True,RepeatedStraightenings->True];

Show[{ShowMap[PlanarGraphToPlanarMap[planar],Background->None,Frame->False,DisplayFunction->Identity],
ShowGraph[dual,DisplayFunction->Identity]},PlotRange->All,DisplayFunction->$DisplayFunction]

Cycle[5] Fails

ShowGraph[graph=Cycle[5]]

FindPlanarEmbedding[graph]

planar=PlanarGraphToPlanarMap[FindPlanarEmbedding[graph]]

ShowMap[planar]

PlanarGraph@@graph

planar=PlanarGraphToPlanarMap[PlanarGraph@@graph]

ShowMap[planar]

Star Fails

ShowGraph[graph=Star[5]]

planar=FindPlanarEmbedding[graph];
dual=DualMultiGraph[PlanarGraphToPlanarMap[planar],StraightenEdges->True,RepeatedStraightenings->True];

Show[{ShowMap[PlanarGraphToPlanarMap[planar],Background->None,Frame->False,DisplayFunction->Identity],
ShowGraph[dual,DisplayFunction->Identity]},PlotRange->All,DisplayFunction->$DisplayFunction]

Wheel[4]

ShowGraph[graph=Wheel[4]]

e=FindPlanarEmbedding[graph];
g=DualMultiGraph[PlanarGraphToPlanarMap[e],StraightenEdges->True,RepeatedStraightenings->True];

Show[{ShowMap[PlanarGraphToPlanarMap[e],Background->None,Frame->False,DisplayFunction->Identity],
ShowGraph[g,DisplayFunction->Identity]},PlotRange->All,DisplayFunction->$DisplayFunction]

e

e=PlanarGraph[{{0,1,1,1},{1,0,1,1},{1,1,0,1},{1,1,1,0}},{{0.3204798590729372`,0.42178767566382946`},{0.7244065738890897`,0.4618103098682657`},{0.565680310794309`,0.7555534932283725`},{0.6193714733904098`,0.519512832462699`}}];

g=MultiGraph[{{0,{{}},{{{0.6718890236397497`,0.49066157116548237`}}},{{{0.7506618103521396`,0.4201042146243523`},{0.706504801474896`,0.7844798640839662`},{0.3672063610293279`,0.7844798640839662`}}}},{{{}},0,{{}},{{}}},{{{{0.6718890236397497`,0.49066157116548237`}}},{{}},0,{{{0.6360925561346025`,0.7700166786561693`},{0.46644333591181847`,0.7700166786561693`}}}},{{{{0.3672063610293279`,0.7844798640839662`},{0.706504801474896`,0.7844798640839662`},{0.7506618103521396`,0.4201042146243523`}}},{{}},{{{0.46644333591181847`,0.7700166786561693`},{0.6360925561346025`,0.7700166786561693`}}},0}},{{0.5547526354508122`,0.4677036059982647`},{0.5018438810858853`,0.5656180004516337`},{0.6364861193579362`,0.5789588785197791`},{0.38470985200469454`,0.6587614061346551`}}];

Wheel[5]

ShowGraph[graph=Wheel[5]]

planar=FindPlanarEmbedding[graph];
dual=DualMultiGraph[PlanarGraphToPlanarMap[planar],StraightenEdges->True,RepeatedStraightenings->True];

Show[{ShowMap[PlanarGraphToPlanarMap[planar],Background->None,Frame->False,DisplayFunction->Identity],
ShowGraph[dual,DisplayFunction->Identity]},PlotRange->All,DisplayFunction->$DisplayFunction]

Stack Exchange Code

http://mathematica.stackexchange.com/questions/52056/dual-graph-of-an-arbitrary-planar-graph

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.

The dual of a plane graph is a plane multigraph (with multiple edges).  If G is a connected plane graph and if G’ is the dual of G then G is isomorphic to the dual of G’.  Since the dual graph depends on a particular embedding, the dual graph of a planar graph is not unique in the sense that the same planar graph can have non-isomorphic dual graphs. In the picture, the red graphs are not isomorphic because the upper one has a vertex with degree 6 (the outer face). However, if the graph is 3-connected, then Whitney showed that the embedding, and thus the dual graph, is unique.

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

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

(* replace with FindSpanningTree *)

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_]:=System`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*)
NewFaces[graph_]:=Block[{$faces={},tree=FindSpanningTree[graph]},iteration[tree,Complement[EdgeList[graph],EdgeList[tree]]]]

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_List]:=System`Graph[DeleteDuplicates@Join[innerDualEdges[faces],Thread@UndirectedEdge[0,boundaryFaces[faces,boundaryEdges[faces]]]]]
DualGraph[g_System`Graph]:=DualGraph[NewFaces[g]]

Spanning tree:

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

It works as follows:

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

d=DualGraph[faces]

MultigraphQ[d]

RecognizeGraph[d]

FindSpanningTree[GraphData["Q3"]]//Head

DualGraph[GraphData["Q3"]]//RecognizeGraph

DualGraph[GraphData["C4"]]//RecognizeGraph

faces=NewFaces[graph=GraphData["Q3"]];
Manipulate[HighlightGraph[graph,faces[[n]]],{n,1,Length@faces,1}]

GraphData["IcosahedralGraph","Graphs","Planar"]

DualGraph/@GraphData["IcosahedralGraph","Graphs","Planar"]

RecognizeGraph/@%

faces=NewFaces[graph=GraphData["IcosahedralGraph"]];
Manipulate[HighlightGraph[graph,faces[[n]]],{n,1,Length@faces,1}]

DualGraph[CycleGraph[3]]

System`Graph[{1,2},{1\[UndirectedEdge]2,1\[UndirectedEdge]2,1\[UndirectedEdge]2}]

CommonName[EntityProperty["SportObject",#]]&/@{"PoolLength","TrackLength","RinkLength"}