graphs and networks - Display a labeled multigraph

Introduced in version 9, fixed in version 10.

Thanks Szabolcs for providing this screenshot showing that the bug is fixed.

---

Despite the integration of graphs and networks, multigraphs are not supported in Mathematica 8+.

In Mathematica 9+, GraphPlot misbehaves for multigraphs having labelled parallel edges:

GraphPlot[{{1 -> 2, "a"}, {1 -> 2, "b"}, {2 -> 1, "c"}}]
GraphPlot[{{1 -> 2, "a"}, {1 -> 2, "b"}, {2 -> 1, "c"}}, DirectedEdges -> True]

EdgeRenderingFunction is passed the nonsense labels, so using it is out of the question.

Due to this bug, it appears there is no easy way for Mathematica 9+ to render a multigraph with labels.

Are there any workarounds, or should I look somewhere other than Mathematica?

Answer

Here is a manual EdgeRenderingFunction that you can start from if you supply your labels as lists.

erf = Module[{spacing = .2, 
     transform = 
      Last@FindGeometricTransform[#, {{0, 0}, {1, 0}}]}, {Text[#, 
        transform[{1/2, #2}]], 
       GeometricTransformation[
        Arrow[BSplineCurve[{{0, 0}, {1/3, #2}, {2/3, #2}, {1, 0}}, 
          SplineWeights -> {1, 10, 10, 1}]], transform]} & @@@ 
     Thread[{#3, 

       Table[spacing*a, {a, Length@#3}] - 
        spacing*(Length@#3 + 1)/2}]] &;

GraphPlot[{{1 -> 2, {"a"}}, {2 -> 3, {"b", "c", "d"}}, {3 -> 4, {"e", 
    "f"}}, {1 -> 5, {"g", "h", "i", "j"}}, {3 -> 6, {"k"}}}, 
 EdgeRenderingFunction -> erf]

To do the same with Graph instead of GraphPlot requires a bit more work because EdgeShapeFunctions for Graphs aren't given the labels. So you need to Fold across the edges of the Graph and replace the EdgeLabels with a custom EdgeShapeFunction containing the labels for each edge.

g = Graph[{Property[1 -> 2, EdgeLabels -> {"a"}], 

    Property[2 -> 3, EdgeLabels -> {"b", "c", "d"}], 
    Property[3 -> 4, EdgeLabels -> {"e", "f"}], 
    Property[1 -> 5, EdgeLabels -> {"g", "h", "i", "j"}], 
    Property[3 -> 6, EdgeLabels -> {"k"}]}];

es[labels_] := 
 Module[{spacing = .2, 
    transform = 
     Last@FindGeometricTransform[#, {{0, 0}, {1, 0}}]}, {Text[#, 
       transform[{1/2, #2}]], 

      GeometricTransformation[
       Arrow[BSplineCurve[{{0, 0}, {1/3, #2}, {2/3, #2}, {1, 0}}, 
         SplineWeights -> {1, 10, 10, 1}]], transform]} & @@@ 
    Thread[{labels, 
      Table[spacing*a, {a, Length@labels}] - 
       spacing*(Length@labels + 1)/2}]] &

g // Fold[
   RemoveProperty[{SetProperty[{#, #2}, 
       EdgeShapeFunction -> 

        es@PropertyValue[{#, #2}, EdgeLabels]], #2}, EdgeLabels] &, #,
    EdgeList@#] &