How to get distinct labels on parallel edges in a graph?
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 Association
s 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