7
$\begingroup$

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?

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ 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. $\endgroup$ Commented Oct 17, 2013 at 8:47
  • $\begingroup$ See built-in automatic method using "EdgeLayout" that curves edges. $\endgroup$ Commented May 1, 2015 at 18:48

3 Answers 3

Reset to default
7
$\begingroup$

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

Improve this answer
$\endgroup$
5
  • $\begingroup$ 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" $\endgroup$ Commented Oct 17, 2013 at 12:37
  • $\begingroup$ @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. $\endgroup$ Commented Oct 17, 2013 at 12:42
  • $\begingroup$ @MichielvanMens does it help? $\endgroup$ Commented Oct 17, 2013 at 13:02
  • $\begingroup$ with pattern: edgeFun[{a_, __, b}, e_] := BezierCurve[{a, {a[[1]] + .1 b[[1]], a[[2]]}, {a[[1]] + .1 b[[1]], b[[2]]}, b}]; $\endgroup$ Commented Oct 17, 2013 at 13:10
  • $\begingroup$ It Works. Thank you very much! $\endgroup$ Commented Oct 17, 2013 at 13:51
3
$\begingroup$

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

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

enter image description here

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

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ Very under-rated answer! $\endgroup$ Commented Jun 19, 2020 at 14:33
  • $\begingroup$ I cannot find documentation for GraphElementData $\endgroup$ Commented Jan 16, 2021 at 13:07
  • $\begingroup$ @Themis, unfortunately, it is not documented. $\endgroup$ Commented Jan 16, 2021 at 15:53
2
$\begingroup$

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"}}

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.