I want to generate a layered drawing of the Hoffman–Singlelton graph. As an example of what I want, here is a layered drawing of the Petersen graph:

enter image description here

Now if I right click on the output of PetersenGraph[] and do Graph Layout -> Layered, drawing, I get this:

enter image description here

Clearly a lot of the important visual information at the end layer is lost because the edges all overlap. Is there a way to recreate something similar to the the top image, where the edges at the last layer are visible?

My actual goal is not to do this with the Petersen, but with the Hoffman–Singleton (in Mathematica, FromEntity[Entity["Graph", "HoffmanSingletonGraph"]]). Needless to say, I got a similar output for this graph:

enter image description here

I appreciate any assistance with this.


2 Answers 2


Here's the one way by using the custom edge function:

arcRight[{a:{x1_,y1_},___,b:{x2_,y2_}}]/;y1>y2:=arcRight[{b, a}];
arcRight[{a:{x1_,y1_},___,b:{x2_,y2_}}]/;y1<=y2:=BSplineCurve[{a, {x1 + (y2-y1).7, (y1+y2)/2},b}]

iLayeredDrawing[g_, spos_Integer:1, opt___?OptionQ] :=
    Module[{s, vlist, leaves},
        vlist = VertexList[g];
        s = vlist[[spos]];
        leaves = MaximalBy[Reap[BreadthFirstScan[g, s, "DiscoverVertex"->(Sow[{#1,#3}]&)]][[2,1]], Last][[All,1]];
        Graph[vlist, EdgeList[g],
         opt, GraphLayout->{"LayeredEmbedding", "Orientation"->Left, "LeafDistance"->1/(Length[leaves]/2), "RootVertex" -> s}, EdgeShapeFunction->{a_\[UndirectedEdge]b_/;SubsetQ[leaves,{a,b}]:>(arcRight[#1]&)}]

For example,

iLayeredDrawing[PetersenGraph[], EdgeStyle -> Black, 
 VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .3]

enter image description here

iLayeredDrawing[FromEntity[Entity["Graph", "HoffmanSingletonGraph"]], 
 EdgeStyle -> Black, 
 VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .6, 
 ImageSize -> 600]

enter image description here

  • $\begingroup$ This is beautiful! $\endgroup$ Jun 24, 2019 at 15:51
  1. Rescale the vertex coordinates given by "LayeredEmbedding" to run form 0 to 1 in each dimension,
  2. Pick the edges with vertices in the right-most layer by checking if both vertices have first coordinate equal to 1.,
  3. Use a slightly modified version of the built-in edge shape function "CurvedArc" as the EdgeShapeFunction for the right-most edges.

ClearAll[eSF, toLayered, layeredG]
eSF[curv_: 1] := GraphElementData[{"CurvedArc", "Curvature" -> curv}][
    SortBy[-Last @ # &] @ #[[{1, -1}]], ##2] &;

toLayered = Module[{el = EdgeList[#], g, re, 
     vcoords = Round[#, .001] & @ Transpose[Rescale /@ 
        Transpose[GraphEmbedding[#, {"LayeredEmbedding", "Orientation" -> Left}]]]},
    g = SetProperty[#, VertexCoordinates -> vcoords];
    re = Pick[el, First[PropertyValue[{g, #}, VertexCoordinates]]& /@ Apply[List][#] == 
        {1., 1.}& /@ el];
    SetProperty[g, { EdgeShapeFunction -> {Alternatives @@ re -> eSF[]}}]] &;

We compose toLayered with Graph to get a function that takes the same arguments and options as Graph:

layeredG = toLayered @* Graph;


layeredG[PetersenGraph[], EdgeStyle -> Black, 
 VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .3]

enter image description here

hsg = FromEntity[Entity["Graph", "HoffmanSingletonGraph"]];
layeredG[hsg, ImageSize -> 600, VertexSize -> .8, 
  VertexStyle -> White, EdgeStyle -> Gray]

enter image description here


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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