7
$\begingroup$

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:

Example Graph

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.

$\endgroup$
  • 2
    $\begingroup$ Properties for multigraphs are not supported. This is a very annoying limitation of Mathematica. I suggest you contact Wolfram Support and complain about it. If you (and others) don't, then there is no chance that this will improve in the future. $\endgroup$ – Szabolcs Oct 4 '18 at 8:09
4
$\begingroup$

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

enter image description here

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]

enter image description here    

$\endgroup$
6
$\begingroup$

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
]

enter image description here

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

enter image description here

$\endgroup$
  • 1
    $\begingroup$ I am unsure how I am able to discern different routes via this method, sorry? On a map with 12 nodes, and five routes of length 5-10, this is quite mentally cumbersome. $\endgroup$ – Jordan MacLachlan Oct 4 '18 at 2:27
  • 1
    $\begingroup$ @JordanMacLachlan it's easy to just specify the styles explicitly $\endgroup$ – M.R. Oct 4 '18 at 3:00
  • 1
    $\begingroup$ I haven't seen this way of doing multigraph styling, nice! $\endgroup$ – user5601 Oct 4 '18 at 18:28
  • $\begingroup$ @JordanMacLachlan Do you see how it works now? $\endgroup$ – M.R. Oct 4 '18 at 19:01
  • 1
    $\begingroup$ For the record: if I could note two posts as answers to the original question, I would also accept this solution. Given I implemented the technique first posted, I will keep that as my accepted answer, however. Regardless, I really appreciate your help. Thank you. $\endgroup$ – Jordan MacLachlan Oct 4 '18 at 21:08

Your Answer

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Not the answer you're looking for? Browse other questions tagged or ask your own question.