# Make Graphs with disjoint edge sets that have different colors?

I would like to obtain the related graphs in mathematica which look like the following picture took from this link: 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;
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!

• 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 Commented Jul 15, 2021 at 10:12
• thank you for the answer! that's an interesting point, I thought the eShapeFunction was evaluated in each iteration. @LukasLang Commented Jul 16, 2021 at 6:51
• @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 Commented Jul 16, 2021 at 8:11
• thank you for the nice explanation!@LukasLang Commented Jul 16, 2021 at 8:36

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


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[#,
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"]


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"],
(edgelist /. {i_Integer, j_Integer} :> UndirectedEdge[i, j]) //
Multicolumn[#, 3, Appearance -> Row] &


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