Robertson Graph

Author

Eric W. Weisstein
October 20, 2022

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

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

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

Embeddings

GraphData["RobertsonGraph","StandardName"]

Primary

GraphData["RobertsonGraph"]//StyleGraphs[#,ImageSize->Small]&

All

GraphData["RobertsonGraph","Graph","All"]//StyleGraphs

Default embedding

GraphPlot@GraphData["RobertsonGraph","Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData["RobertsonGraph","EdgeList"]]

Degenerate

GraphData["RobertsonGraph","Graph","Degenerate"]//StyleGraphs

Bilateral

GraphData["RobertsonGraph","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["RobertsonGraph","Graph","Circular"]//StyleGraphs

Planar

GraphData["RobertsonGraph","Planar"]

GraphData["RobertsonGraph","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["RobertsonGraph",{"RCN","CN"}]

GraphData["RobertsonGraph","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData["RobertsonGraph"],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData["RobertsonGraph"],TimeConstraint->60]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData["RobertsonGraph"],"CrossingNumber"->cn]]

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["RobertsonGraph"],"CrossingNumber"->cn,RandomSeed->n]],{n,200}],Max[OuterFace[#]]<=GraphData["RobertsonGraph","V"]&]]//Timing

GraphPlot@

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

MinimalRectilinearCrossing using Exoo's data

Show[img=ImageCrop@Import["http://isu.indstate.edu/ge/COMBIN/RECTILINEAR/cage45.png"],ImageSize->Small]

Length[pts=ImageValuePositions[img,Red,.1]]

Graphics[Point[pts],ImageSize->Small]

Length[v=Mean/@FindClusters[pts,19,Method->"Agglomerate"]]

Graphics[Point[v],ImageSize->Small]

v=v/Max[Abs[v]];

GraphData["RobertsonGraph","VertexDegrees"]

g=Graph[Range[Length[v]],Union[Sort/@UndirectedEdge@@@Join@@(Partition[#,2,1]&/@{
{1,19},{4,3,5,8},{9,11},{1,2,3},{1,6},{2,18},{7,12,2},{7,5},{6,13},{14,1},{14,10},{10,11,8},{9,11},{12,15},{7,17},{6,9,11},{14,16},{18,17},{3,10},{5,6},{9,12},{14,16},{7,14},{19,8},{13,10},{4,9},{4,19},{8,15},{16,18}
})],VertexCoordinates->v,VertexLabels->"Name"]

EdgeCount[g]

GraphData["RobertsonGraph","M"]

Position[System`AdjacencyMatrix[g][[13]]//Normal,1]//Flatten

Remainder of edges are difficult to extract since it can't be discerned if they pass over or are actually incident to vertices in some cases.  So look at vertex degrees and construct an edge set using missing vertices that gives correct final vertex degrees:

VertexDegree[g]

unk=Flatten[MapIndexed[ConstantArray[#2[[1]],4-#]&,%]]

tuples=Union@DeleteCases[Subsets[unk,{2}],{x_,x_}]

Length[tuples]

Length[sub=Developer`ToPackedArray[Subsets[tuples,{38-EdgeCount[g]}]]]

tallies=Tally[unk]

sub2=sub;
Print[Length[sub2=Pick[sub2,Function[s,Count[Flatten[s],#1]]/@sub2,#2]]]&@@@tallies;

Of these, pick the set whose addition to the partial graph gives the desired final graph:

Select[sub2,IsomorphicGraphQ[EdgeAdd[g,UndirectedEdge@@@#],GraphData["RobertsonGraph"]]&]

gnew=EdgeAdd[g,UndirectedEdge@@@%]

GraphData["RobertsonGraph","Graph",{"All","Labeled"}][[2]]/.g_System`Graph:>SetProperty[g,{VertexSize->.5,GraphLayout->{"RenderingOrder"->"EdgeFirst"}}]

Show[GraphData["RobertsonGraph","Graph",{"All","Labeled"}][[2]]/.g_System`Graph:>SetProperty[g,{VertexSize->.2,GraphLayout->{"RenderingOrder"->"EdgeFirst"}}],Axes->True,PlotRange->{{.2,.4},{0,.2}}]

RecognizeGraph[gnew]

RectilinearCrossingNumber@gnew

Circulant

GraphData["RobertsonGraph","Circulant"]

GraphData["RobertsonGraph","Graph","Circulant"]//StyleGraphs

Halin

GraphData["RobertsonGraph","Halin"]

GraphData["RobertsonGraph","Graph","Halin"]//StyleGraphs

LCF

GraphData["RobertsonGraph","LCF"]

GraphData["RobertsonGraph","LCFSignature"]

GraphData["RobertsonGraph","Graph","LCF"]//StyleGraphs

Tally[LCFFromEmbedding[#][[2]]&/@%]

LCF compute

Length[FindHamiltonianCycle[GraphData["RobertsonGraph"],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["RobertsonGraph"],All])[[All,2]]]//Timing

gs=LCFGraph@@@lcf//StyleGraphs

gs=Join[With[{g=BilateralLCFEmbedding[#]},If[MissingQ[g],#,g]]&/@LCFGraph@@@DeleteCases[lcf,{_,1}],DeleteMissing[BilateralLCFEmbedding/@LCFGraph@@@Cases[lcf,{_,1}]]]

UnitDistance

GraphData["RobertsonGraph","UnitDistance"]

UnitDistanceGraphQ[GraphData["RobertsonGraph"],Debug->True]//Timing

GraphData["RobertsonGraph","Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData["RobertsonGraph","Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData["RobertsonGraph","Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData["RobertsonGraph"],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData["RobertsonGraph"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData["RobertsonGraph"],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{"RobertsonGraph",l=FindSubgraphUnitDistanceEmbedding[GraphData["RobertsonGraph"],TimeConstraint->300,"Results"->All]//Timing}

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Matchstick

GraphData["RobertsonGraph","Matchstick"]

GraphData["RobertsonGraph","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["RobertsonGraph","Edges"]]

3D All

GraphData["RobertsonGraph","Graph",{"3D","All"}]

3D UnitDistance

GraphData["RobertsonGraph","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["RobertsonGraph","Polyhedral"]