Weighted graph with multiple different coloured non-weighted paths - styling

Question

This follows on from my previous question answered here.

Ultimately, I now have a graph which I've simplified for posting here:

g1 = Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3, 
   3 \[UndirectedEdge] 1}, EdgeWeight -> {10, 10, 10},
  VertexLabels -> Table[i -> Placed[i, Center], {i, 3}], 
  VertexLabelStyle -> Directive[White, Bold, 15], VertexSize -> 0.1, 
  GraphLayout -> {"VertexLayout" -> {"SpringElectricalEmbedding", 
      "EdgeWeighted" -> True}}]

r0 = {1, 2, 3};
e0 = DirectedEdge @@@ Partition[r0, 2, 1];

r1 = {1, 2, 1};
e1 = DirectedEdge @@@ Partition[r1, 2, 1];

g2 = SetProperty[EdgeAdd[g1, Join[
    e0, e1
    ]], {VertexCoordinates -> GraphEmbedding[g1], 
   VertexStyle -> {1 -> Red}, EdgeStyle -> {
     Alternatives @@ e0 -> {Green, Thick}, 
     Alternatives @@ e1 -> {Blue, Thick}
     }}]

Which outputs the following:

Ideally, one of the arrows from v1 to v2 would be green. However, as Mathematica views this edge in e1 as the same as the equivalent edge in e0, the formatting of the latter defined edge overwrites the e0 edge.

Research into options so far has spanned: (1) using this EdgeShapeFunction technique, which is not working as I believe the syntax isn't handling the collection of edges correctly and (2) looking into constructing custom sub DirectedEdge type objects to trick Mathematica into thinking they were different, which I don't believe is possible given my layman's understanding of the software.

Answer 1

Using the same approach as in this answer

i = 1;
SetProperty[EdgeAdd[g1, Join[e0, e1]], 
 {VertexCoordinates -> GraphEmbedding[g1],  VertexStyle -> {1 -> Red}, 
  EdgeShapeFunction->{Alternatives @@ Intersection[e0, e1] -> 
    ({Arrowheads[{0, 0, .05, 0}], Thick, {Blue, Green}[[i++]], Arrow[#]} &)},
  EdgeStyle -> {Alternatives@@e1 -> {Blue, Thick}, Alternatives@@e0 -> {Green, Thick}}}]

For the general case with multiple groups with arbitrary intersections, you can use the general method in the linked answer by specifying the list of styles for each distinct edge in the input graph ... as follows:

ClearAll[index, style]
styles = Normal @ GroupBy[Flatten[Thread[# -> 
   Directive[#2, Arrowheads[{0, 0, .05, 0}], Thick]] & @@@ 
      Thread[{{e0, e1}, {Green, Blue}}]], First -> Last] ;
g0 = Graph[Join[EdgeList[g1], e0, e1], EdgeStyle -> styles, VertexStyle -> {1 -> Red} , 
   VertexLabels -> Table[i -> Placed[i, Center], {i, 3}], 
   VertexLabelStyle -> Directive[White, Bold, 15], 
   VertexSize -> 0.1  , VertexCoordinates -> GraphEmbedding[g1]] ;
distinctedges = DeleteDuplicates[Join[e0, e1]] ;
(style[#] = PropertyValue[{g0, #}, EdgeStyle]) & /@ distinctedges;
(index[#] = 1) & /@  distinctedges;
g2 = Fold[(SetProperty[{#,  #2}, EdgeShapeFunction -> 
     ({ style[#2][[index[#2]++]], Arrow[#]} &)]) &,   g0,  distinctedges]

   

Answer 2

In general, here's another way to style multigraph edges without using SetProperty. Just make a matrix of the edges and their styles:

$styles = {{a -> e, Green}, {e -> b, Green}, {a -> b, Red}, 
           {a -> b, Directive[Dashing[{Small, Small}], Blue]}, {a -> b, RGBColor[1, 0.5, 0]}, 
           {a -> b, Directive[RGBColor[0.5, 0, 0.5], Dashing[0.01`]]}};

ef = (Block[{st, p}, st = $styles[[p = 
          FirstPosition[$styles, #2 | (#2 /. DirectedEdge -> Rule)][[1]]]][[2]];
          $styles = Delete[$styles, p]; 
          {Thickness[0.008], Arrowheads[{{.08, .5}}], st, Arrow@#}] &)

Graph[$styles[[All,1]], 
  VertexLabels -> Placed["Name", Center], VertexSize -> 0.14, 
  VertexLabelStyle -> Directive[FontSize -> 17, FontColor -> White], 
  EdgeShapeFunction -> ef
]

Here's your example:

u = Directive[Gray, Thickness[0.002], Arrowheads[0]];
$styles = {1 \[DirectedEdge] 2 -> RGBColor[0, 0, 1], 
   1 \[DirectedEdge] 2 -> RGBColor[0, 1, 0], 
   1 \[UndirectedEdge] 2 -> u, 1 \[UndirectedEdge] 3 -> u, 
   2 \[DirectedEdge] 3 -> RGBColor[0, 1, 0], 
   2 \[UndirectedEdge] 3 -> u, 
   2 \[DirectedEdge] 1 -> RGBColor[0, 0, 1]};
Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3, 
  3 \[UndirectedEdge] 1, 1 \[DirectedEdge] 2, 1 \[DirectedEdge] 2, 
  2 \[DirectedEdge] 1, 2 \[DirectedEdge] 3}, 
 EdgeWeight -> {10, 10, 10, 0, 0, 0, 0}, 
 VertexLabels -> Table[i -> Placed[i, Center], {i, 3}], 
 VertexLabelStyle -> Directive[White, Bold, 15], VertexSize -> 0.1, 
 VertexStyle -> {1 -> Red}, 
 GraphLayout -> {"VertexLayout" -> {"SpringElectricalEmbedding", 
 "EdgeWeighted" -> True}}, EdgeShapeFunction -> (
   Module[{st, p},
 st = $styles[[p = 
          FirstPosition[$styles, #2][[1]]]][[2]]; $styles = 
      Delete[$styles, p];
     {Arrowheads[{{.03, .95}}], st, Arrow@#}] &), 
 VertexLabels -> "Name"]