How can I get edges to bend to avoid crossing?
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]
iLayeredDrawing[FromEntity[Entity["Graph", "HoffmanSingletonGraph"]],
EdgeStyle -> Black,
VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .6,
ImageSize -> 600]
- Rescale the vertex coordinates given by
"LayeredEmbedding"
to run form 0 to 1 in each dimension, Pick
the edges with vertices in the right-most layer by checking if both vertices have first coordinate equal to1.
,- Use a slightly modified version of the built-in edge shape function
"CurvedArc"
as theEdgeShapeFunction
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;
Examples:
layeredG[PetersenGraph[], EdgeStyle -> Black,
VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .3]
hsg = FromEntity[Entity["Graph", "HoffmanSingletonGraph"]];
layeredG[hsg, ImageSize -> 600, VertexSize -> .8,
VertexStyle -> White, EdgeStyle -> Gray]