BezierCurve in EdgeShapeFunction fails when used on multiedges graph

Question

I would like to create a network graph with curved edges. To do this, I wrote this function:

edgeFun[pts_, e_] := Module[{controlPts},
     controlPts = pts /. {a_, b_} :> {a, {a[[1]] + .1 b[[1]], a[[2]]},
                                         {a[[1]] + 0.1 b[[1]], b[[2]]}, b}; 
      BezierCurve[controlPts]
];

With no multiedges the edgeFun function works fine:

pts = {1 -> 2, 2 -> 3, 3 -> 1};
Graph[pts, VertexLabels -> Placed["Name", Center], EdgeShapeFunction -> edgeFun]

Mathematica graphics

But when I want to create a network with multiple edges (note 1 -> 2 and 2 -> 1, Mathematica complains and the graph is pinked out:

pts1 = {1 -> 2, 2 -> 3, 3 -> 1, 2 -> 1};
Graph[pts1, VertexLabels -> Placed["Name", Center], EdgeShapeFunction -> edgeFun]

Part::partd: "Part specification 0.496922[[1]] is longer than depth of object"

Does anyone know how to solve this problem?

The problem is, that for loops Graph is greating curved edges so those are not just {point1, point2} type Lines. At the end the problem is your replacement rule which is not well suited for those lists. — Kuba, Oct 17 '13 at 08:47
See built-in automatic method using "EdgeLayout" that curves edges. — István Zachar, May 01 '15 at 18:48

score 7 · Accepted Answer · edited Oct 17 '13 at 22:25

7

As I said in my comment:

The problem is that for loops, Graph is creating curved edges. Therefore, the edges are not just {point1, point2} type Lines. Ultimately your problem is your replacement rule, which is not well suited for such lists.

You can check that the EdgeShapeFunction is passed all the points, not only the initial ones:

pts = {1 -> 2, 2 -> 1, 2 -> 3, 3 -> 1};
Graph[pts, VertexLabels -> Placed["Name", Center], 
           EdgeShapeFunction -> ((Print[Short[#]]; Line[#1]) &)]

{{0.496922,0.},{0.518107,0.109873},<<15>>,{0.999994,0.864245}}
{{0.999994,0.864245},{0.978809,0.754372},<<15>>,{0.496922,0.}}
{{0.999994,0.864245},{0.,0.867795}}
{{0.,0.867795},{0.496922,0.}}

So, keeping that in mind, you can write the proper function, for example:

edgeFun[pts_, e__] := BezierCurve[{#, # - {0, 1}, #2} & @@ pts[[{1, -1}]]];

pts = {1 -> 2, 2 -> 1, 2 -> 3, 3 -> 1};
Graph[pts, VertexLabels -> Placed["Name", Center], EdgeShapeFunction -> edgeFun]

Mathematica graphics

edited Oct 17 '13 at 22:25

Sjoerd C. de Vries

65,815
14
188
323

answered Oct 17 '13 at 08:56

Kuba

136,707
13
279
740

Hi,Thanks for your reply. unfortunately, when I copy your code exactly as you wrote it, in my notenbook, I get the same complains and the graph is pinked out. Is it possible that it has something to do with my configuration:"Version" -> "9.0 Home Edition for Microsoft Windows (64-bit) "MachineType" -> "PC", "OperatingSystem" -> "Windows", "ProcessorType" -> "x86-64", "Language" -> "English" – Michiel van Mens Oct 17 '13 at 12:37
@MichielvanMens When I'm copying the last codeblock there is no error, only the plot as the one above. Try to reset the kernel or ClearAll[edgeFun] earlier. – Kuba Oct 17 '13 at 12:42
@MichielvanMens does it help? – Kuba Oct 17 '13 at 13:02
with pattern: edgeFun[{a_, ___, b_}, e_] := BezierCurve[{a, {a[[1]] + .1 b[[1]], a[[2]]}, {a[[1]] + .1 b[[1]], b[[2]]}, b}]; – halmir Oct 17 '13 at 13:10
It Works. Thank you very much! – Michiel van Mens Oct 17 '13 at 13:51

score 3 · Answer 2 · answered Jul 30 '17 at 21:33

3

An alternative is to use "CurvedArc" as the EdgeShapeFunction:

Graph[pts, VertexLabels -> Placed["Name", Center], VertexSize -> Medium, 
 EdgeShapeFunction -> GraphElementData[{"CurvedArc", "Curvature" -> -3/2}]]

Graph[pts1, VertexLabels -> Placed["Name", Center], VertexSize -> Medium, 
 EdgeShapeFunction -> GraphElementData[{"CurvedArc", "Curvature" -> -3/2}]]

answered Jul 30 '17 at 21:33

kglr

394,356
18
477
896

Very under-rated answer! – Anton Antonov Jun 19 '20 at 14:33
I cannot find documentation for GraphElementData – Themis Jan 16 '21 at 13:07
@Themis, unfortunately, it is not documented. – kglr Jan 16 '21 at 15:53

score 2 · Answer 3 · answered Oct 17 '13 at 09:06

Just to be redundant, I think your patterns need tuning for the extra points sent by multiple edges:

{{0, 0}, {1, 2}} /. {a_, b_} :> {"a is " <> ToString[a], "b is " <> ToString[b]}

{"a is {0, 0}", "b is {1, 2}"}

{{0, 0}, {1, 1}, {2, 2}, {3, 3}} /. {a_, b_} :> {"a is " <> ToString[a], "b is " <> ToString[b]}

{{"a is 0", "b is 0"}, {"a is 1", "b is 1"}, {"a is 2", "b is 2"}, {"a is 3", "b is 3"}}

BezierCurve in EdgeShapeFunction fails when used on multiedges graph

3 Answers3

Linked

Related