5
$\begingroup$

I would like to obtain the related graphs in mathematica which look like the following picture took from this link: graphs What I do:

  • I have all the edge lists for the above graphs.
edgelist = {
{{{1, 2}, {3, 4}, {5, 6}}, {{1, 3}, {2, 5}, {4, 6}}, {{1, 4}, {2, 6}, {3, 5}}, {{1, 5}, {2, 4}, {3, 6}}, {{1, 6}, {2, 3}, {4, 5}}},
{{{1, 2}, {3, 4}, {5, 6}}, {{1, 3}, {2, 6}, {4, 5}}, {{1, 4}, {2, 5}, {3, 6}}, {{1, 5}, {2, 3}, {4, 6}}, {{1, 6}, {2, 4}, {3, 5}}}, 
{{{1, 2}, {3, 5}, {4, 6}}, {{1, 3}, {2, 4}, {5, 6}}, {{1, 4}, {2, 5}, {3, 6}}, {{1, 5}, {2, 6}, {3, 4}}, {{1, 6}, {2, 3}, {4, 5}}}, 
{{{1, 2}, {3, 5}, {4, 6}}, {{1, 3}, {2, 6}, {4, 5}}, {{1, 4}, {2, 3}, {5, 6}}, {{1, 5}, {2, 4}, {3, 6}}, {{1, 6}, {2, 5}, {3, 4}}}, 
{{{1, 2}, {3, 6}, {4, 5}}, {{1, 3}, {2, 4}, {5, 6}}, {{1, 4}, {2, 6}, {3, 5}}, {{1, 5}, {2, 3}, {4, 6}}, {{1, 6}, {2, 5}, {3, 4}}}, 
{{{1, 2}, {3, 6}, {4, 5}}, {{1, 3}, {2, 5}, {4, 6}}, {{1, 4}, {2, 3}, {5, 6}}, {{1, 5}, {2, 6}, {3, 4}}, {{1, 6}, {2, 4}, {3, 5}}}
};
  • then I assign each edges set with the below color setting:
colorlist = {Red, Black, Yellow, Green, Blue};
edgecolors = {};
Table[AppendTo[edgecolors, Flatten[Tuples[{colorlist[[i]]}, {Length[DeleteDuplicates[Flatten[edgelist[[1]]]]]/2, 1}], 1]];, {i, 1, Length[edgelist[[1]]]}];
edgecolors = Flatten[edgecolors, 1];
  • Inspired by this, I modified a bit the code as the following which should give me the graphs stored in allGraphs.
allGraphs = {};
getvetex={1,2,3,4,5,6} ;
For[ii = 1, ii <= Length[edgelist], ii++,
  
  edges = UndirectedEdge @@@ Flatten[edgelist[[ii]], 1];
  taggededges = EdgeList@EdgeTaggedGraph@edges;
  coloring = AssociationThread[taggededges, edgecolors];
  eShapeFunction = Module[{c=coloring@#2, bsf=BSplineFunction@#, s=Partition[Subdivide[Length@coloring@#2], 2, 1]}, {CapForm["Butt"], Thread[{c, Line /@ (bsf /@ Subdivide[##, 100] & @@@ s)}]}] &;
  
  ggg = Graph[getvetex, taggededges, GraphLayout -> {"CircularEmbedding", "Offset" -> 0}, 
    VertexLabels -> Placed["Name", Center], VertexSize -> .2, VertexStyle -> White, 
    VertexLabelStyle -> Directive[FontFamily -> "Times", Medium], 
    EdgeStyle -> Directive[CapForm["Round"], AbsoluteThickness[3]], 
    PerformanceGoal -> "Quality", EdgeShapeFunction -> eShapeFunction];
  AppendTo[allGraphs, ggg]; (*store all graphs*)
 ];

However, there is a problem: it seems graphs are replaced by the last one in allGraphs, therefore I only have the last repeated graph in allGraphs. When I add Print[ggg]; before AppendTo[allGraphs, ggg];, I could have the correct answer. I have no idea why.

Also is there other simple approach to do the above task such as using HighlightGraph or GraphHighlightStyle options? Thank you very much!

$\endgroup$
4
  • 1
    $\begingroup$ The reason why your code returns a list of identical graphs is that you are reassigning coloring, and your eShapeFunction is only evaluated at the end. You can use With or similar to "inject" the value of coloring into the function body $\endgroup$
    – Lukas Lang
    Commented Jul 15, 2021 at 10:12
  • $\begingroup$ thank you for the answer! that's an interesting point, I thought the eShapeFunction was evaluated in each iteration. @LukasLang $\endgroup$
    – Xuemei
    Commented Jul 16, 2021 at 6:51
  • 1
    $\begingroup$ @Xuemeito to be more precise: eShapeFunctiom is only evaluated when the graph is displayed (when MakeBoxes is called on it). You can partly verify this by looking at the InputForm of the graphs: the eShapeFunction definition will still be in there in its unevaluated form. This also explains why it works when you print them in each iteration: in that case, MakeBoxes (and by extension also eShapeFunction) is called during each iteration, when coloring is still correct $\endgroup$
    – Lukas Lang
    Commented Jul 16, 2021 at 8:11
  • $\begingroup$ thank you for the nice explanation!@LukasLang $\endgroup$
    – Xuemei
    Commented Jul 16, 2021 at 8:36

1 Answer 1

4
$\begingroup$
stylededges = Join @@ MapThread[Thread @* Style, {#, colorlist}] & /@ 
      (edgelist /. {i_Integer, j_Integer} :> UndirectedEdge[i, j]);

gr = Graph[#, 
    GraphLayout -> {"CircularEmbedding", "Offset" -> 0}, 
    VertexLabels -> Placed["Name", Center], 
    VertexSize -> .2, 
    VertexStyle -> White, 
    VertexLabelStyle -> Directive[FontFamily -> "Times", Medium], 
    EdgeStyle -> Directive[CapForm["Round"], AbsoluteThickness[5]], 
    PerformanceGoal -> "Quality"] &;

Multicolumn[gr /@ stylededges, 3, Appearance -> "Row"]

enter image description here

Alternatively, you can style edges using MapIndexed + Style as follows:

stylededges2 = Join @@ 
   MapIndexed[Thread[Style[#, colorlist[[First @ #2]]]] &, #] & /@ 
    (edgelist /. {i_Integer, j_Integer} :> UndirectedEdge[i, j]);

stylededges2 == stylededges
True

Update: A simpler alternative: use colorlist and lengths of edge groups to construct a list of styles and use it with the option EdgeStyle:

edgeStyle = MapThread[Apply[Sequence]@*Table, {colorlist, Length /@ edgelist[[1]]}];

edges = Join @@@ edgelist /. {i_Integer, j_Integer} :> UndirectedEdge[i, j];

gr2 = Graph[#, 
    EdgeStyle -> Thread[# -> edgeStyle], 
    GraphLayout -> {"CircularEmbedding", "Offset" -> 0}, 
    VertexLabels -> Placed["Name", Center], VertexSize -> .2, 
    VertexStyle -> White, 
    VertexLabelStyle -> Directive[FontFamily -> "Times", Medium], 
    BaseStyle -> Directive[CapForm["Round"], AbsoluteThickness[6]], 
    PerformanceGoal -> "Quality"] &;

Multicolumn[gr2 /@ edges, 3, Appearance -> "Row"]

enter image description here

Update 2: Using HighlightGraph:

HighlightGraph[Graph[Join @@ #, 
     GraphLayout -> {"CircularEmbedding", "Offset" -> 0}, 
     VertexLabels -> Placed["Name", Center], VertexSize -> .2, 
     VertexStyle -> White, 
     VertexLabelStyle -> Directive[FontFamily -> "Times", Medium], 
     BaseStyle -> Directive[CapForm["Round"], AbsoluteThickness[5]], 
     PerformanceGoal -> "Quality"], 
   MapThread[Style, {#, colorlist}]] & /@ 
      (edgelist /. {i_Integer, j_Integer} :> UndirectedEdge[i, j]) //
 Multicolumn[#, 3, Appearance -> Row] &

enter image description here

$\endgroup$
11
  • $\begingroup$ that's a very elegant solution, which is much simpler! Thank you very much! $\endgroup$
    – Xuemei
    Commented Jul 14, 2021 at 16:12
  • $\begingroup$ thank you so much! btw, do you have any idea about the strange issue to append graphs in the loop without using Print? $\endgroup$
    – Xuemei
    Commented Jul 14, 2021 at 16:23
  • $\begingroup$ @Xuemei, can you add the definition of getvetex. Without it we can't reproduce the issue. $\endgroup$
    – kglr
    Commented Jul 14, 2021 at 17:00
  • 1
    $\begingroup$ @Xuemei, i can reproduce the issue. Can't think of a reason why it is happenning. $\endgroup$
    – kglr
    Commented Jul 14, 2021 at 17:29
  • 1
    $\begingroup$ try edgelist /. {i_Integer, j_Integer} :> UndirectedEdge[i, j] $\endgroup$
    – kglr
    Commented Jul 15, 2021 at 13:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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