How to get distinct labels on parallel edges in a graph?

Question

The following doesn't display as you'd expect:

Graph[{Labeled[1 -> 2, "A"], Labeled[1 -> 2, "B"]}, VertexLabels -> "Name"]

The parallel edges are both labeled "A". Is this a bug or is it a design feature? The definition of EdgeLabels suggests that Mathematica expects an edge to be identifiable by its ends(!)

In fact, FullForm shows that it gets converted to

{{1, 2}, {1 \[DirectedEdge] 2, 1 \[DirectedEdge] 2}, {EdgeLabels -> {1 \[DirectedEdge] 2 -> "A"}, VertexLabels -> {"Name"}}}

Ugh!

Anyone have any ideas how to get distinct labels to display on parallel edges?

Specifically, I use a simple data format for my digraphs. For the example above, it would be

{{1,{{"A",2},{"B",2}}}}

though in general there's an entry in the outermost list for each source vertex, and the vertices and labels are a variety of things.

Is there some (relatively easy) way (using EdgeShapeFunction perhaps) of creating a Graph that displays correctly?

Answer 1

Update 2: With version 12.1 comes EdgeTaggedGraph which enables individual labeling and styling multi-edges:

EdgeTaggedGraph[{Style[Labeled[1 <-> 2, "lbl1"], Red], 
    Style[Labeled[1 <-> 2, "lbl2"], Blue], 2 <-> 3,   2 <-> 3, 3 <-> 1}, 
   EdgeLabels->Placed["Name", Center]] 

Update: An alternative method that that takes lists of vertices, edges, edge labels and edge styles.

Lexicographic sorting of the edges, labels and styles based on the vertex list seem to match the order in which edges are processed for rendering.

ClearAll[multiGraph2]
multiGraph2[vl_, elist_, elabels_, estyles_, o : OptionsPattern[Graph]] := 
 Module[{esf, edges, labels, styles, 
   sorted = Transpose@ SortBy[Transpose[{elist, elabels,  estyles}], 
     {PositionIndex[vl]@#[[1, 1]] &, PositionIndex[vl]@#[[1, 2]] &}]},
  {edges, labels, styles} = {sorted[[1]], ## & @@ (RotateRight /@ sorted[[2 ;;]])};
  esf = {First[styles = RotateLeft[styles]], 
     GraphElementData["Arrow"][##] /. Arrowheads[ah_] :>
        Arrowheads[Append[ah, {.05, .5, Graphics[
          Text[Framed[First[labels = RotateLeft[labels]], 
             FrameStyle -> None, Background -> White]]]}]]} &;
  Graph[vl, edges, EdgeShapeFunction -> esf, o]]

Example:

SeedRandom[12345]
edges = RandomSample@ EdgeList[RandomGraph[{7, 10}, 
     DirectedEdges -> True]][[{1, 1, 2, 2,  2, 3, 4, 5, 6, 7, 8, 9, 10}]];
edges = Flatten@Gather[edges];
styles = ColorData[97] /@ Range[Length@edges];
labels = Flatten[MapIndexed[Row[{#, CharacterRange["A", "Z"][[#2[[1]]]]}, "-"] &, #] & /@ 
    Gather[edges]];

multiGraph2[RandomSample[Range[7]], edges, labels, styles, 
 VertexSize -> Medium, VertexLabels -> Placed["Name", Center], ImageSize -> Large]

Original answer:

A function that produces a multi-graph with distinct labels and styles for multi-edges given an input list of the form

{{v1, {{v11, label11, style11}, {v12, label12, style12}, ...}, ...}

The list is processed into an edge list and Associations for edge labels and styles that are used to construct a custom EdgeShapeFunction:

ClearAll[multiGraph]
multiGraph[a_, o : OptionsPattern[Graph]] := Module[{esf, 
  edges = Flatten[Thread[DirectedEdge[#[[1]], #[[2, All, 1]]]] & /@ a], 
  edgelabels = GroupBy[#, First -> Last, Flatten] &@
     Flatten[Thread[Thread[DirectedEdge[#[[1]], #[[2, All, 1]]]] -> #[[2, All, 2]]]& /@ a],
  edgestyles = GroupBy[#, First -> Last, Flatten] &@
     Flatten[Thread[Thread[DirectedEdge[#[[1]], #[[2, All, 1]]]] -> #[[2, All, 3]]]& /@ a]},
  esf = {Dashing[{}], First[edgestyles[#2] = RotateRight[edgestyles[#2] ]],
   GraphElementData["Arrow"][##] /. Arrowheads[ah_] :> Arrowheads[Append[ah, {.05, .5, 
     Graphics[Text[Framed[First[edgelabels[#2] = RotateRight[edgelabels[#2] ]], 
      FrameStyle -> None, Background -> White]]]}]]} &;
Graph[edges, EdgeShapeFunction -> esf, o]]

Examples:

data = {{1, {{2, "A", Red}, {2, "B", Blue}, {3, "C", Green}, 
        {3, "D", Directive[Thick, Orange]}}},
     {2, {{3, "E", Directive[Dashed, Thick, Purple]}, {1, "F", Gray}}}};

data2 = data /. s_String :> Style[RandomWord["Noun"], 16, Black];
multiGraph[data2, VertexSize -> Small, 
 VertexLabels -> Placed["Name", Center], ImageSize -> Large, VertexLabelStyle -> Large]

SeedRandom[7777]
randomdata = {#, Table[{RandomChoice[Range@4], Style[RandomWord["Noun"], 14], 
       Opacity[1, RandomColor[]]}, RandomInteger[{2, 4}]]} & /@ Range[4];
multiGraph[randomdata, VertexSize -> Small,  VertexLabels -> Placed["Name", Center],
 ImageSize -> Large, VertexLabelStyle -> Medium]

See also:

• GraphUnion but with multiple edges?
• Graph: Coloring parallel edges individually
• Weighted graph with multiple different coloured non-weighted paths - styling
• Coloring multi-edges in graphs

Answer 2

THIS IS AN EXTENDED COMMENT RATHER THAN AN ANSWER.

$Version

(* "12.0.0 for Mac OS X x86 (64-bit) (April 7, 2019)" *)

Using Labeled the first label instance is used for both edges.

Graph[
 {Labeled[1 \[DirectedEdge] 2, "A"], Labeled[1 \[DirectedEdge] 2, "B"]},
 VertexLabels -> "Name"]

However, using VertexLabels the second label instance is used for both edges.

Graph[
 {1 -> 2, 1 -> 2},
 VertexLabels -> "Name",
 EdgeLabels -> {1 \[DirectedEdge] 2 -> "A", 1 \[DirectedEdge] 2 -> "B"}]

Either approach results in a wrong label and both are bugs.

EDIT: Report was submitted to Wolfram Technical Support [CASE:4276060]