How to color edges of a graph which has multiple edges connecting certain vertices

Question

I'm studying BIBD(Balanced Incomplete Block Design) and want to draw some graphs by coloring their blocks in different colors, respectively. A block is a collection of edges (or vertices).

For example, (10,4,2)-BIBD, with blocks

{{0,1,2,3},{0,1,4,5},{0,2,4,6},{0,3,7,8},{0,5,7,9},{0,6,8,9},
 {1,2,7,8},{1,3,6,9},{1,4,7,9},{1,5,6,8},{2,3,5,9},{2,4,8,9},
 {2,5,6,7},{3,4,5,8},{3,4,6,7}}

can be drawn by

GraphPlot[{0 -> 1, 1 -> 2, 2 -> 3, 0 -> 1, 1 -> 4, 4 -> 5, 0 -> 2, 2 -> 4, 
           4 -> 6, 0 -> 3, 3 -> 7, 7 -> 9, 0 -> 6, 6 -> 8, 8 -> 9, 1 -> 2, 
           2 -> 7, 7 -> 8, 1 -> 3, 3 -> 6, 6 -> 9, 1 -> 4, 4 -> 7, 7 -> 9, 
           1 -> 5, 5 -> 6, 6 -> 8, 2 -> 3, 3 -> 5, 5 -> 9, 2 -> 4, 4 -> 8, 
           8 -> 9, 2 -> 5, 5 -> 6, 6 -> 7, 3 -> 4, 4 -> 5, 5 -> 8, 3 -> 4, 
           4 -> 6, 6 -> 7}, 
  Method -> "CircularEmbedding", 
  BaselinePosition -> Top, 
  VertexLabeling -> True, 
  MultiedgeStyle -> 0.04]

(This example is from the text book Combinatorial Design - Stinson).

I want to draw each block in its own individual color. How do I do that?

Answer 1

It seems that the following doesn't work on v9. It does work on v8 and v10.

Here is what I propose based on this:

rule = {0 -> 1, 1 -> 2, 2 -> 3, 0 -> 1, 1 -> 4, 4 -> 5, 0 -> 2, 2 -> 4, 4 -> 6, 0 -> 3, 
        3 -> 7, 7 -> 9, 0 -> 6, 6 -> 8, 8 -> 9, 1 -> 2, 2 -> 7, 7 -> 8, 1 -> 3, 3 -> 6, 
        6 -> 9, 1 -> 4, 4 -> 7, 7 -> 9, 1 -> 5, 5 -> 6, 6 -> 8, 2 -> 3, 3 -> 5, 5 -> 9, 
        2 -> 4, 4 -> 8, 8 -> 9, 2 -> 5, 5 -> 6, 6 -> 7, 3 -> 4, 4 -> 5, 5 -> 8, 3 -> 4, 
        4 -> 6, 6 -> 7};
blocks = {{0, 1, 2, 3}, {0, 1, 4, 5}, {0, 2, 4, 6}, {0, 3, 7, 8}, {0, 5, 7, 9}, 
          {0, 6, 8, 9}, {1, 2, 7, 8}, {1, 3, 6, 9}, {1, 4, 7, 9}, {1, 5, 6, 8}, 
          {2, 3, 5, 9}, {2, 4, 8, 9}, {2, 5, 6, 7}, {3, 4, 5, 8}, {3, 4, 6, 7}};
coloredRule = Select[Flatten[
    Thread[{Rule @@@ Subsets[blocks[[#]], {2}], 
        ConstantArray[#, 6]}] & /@ Range@Length@blocks, 1], MemberQ[rule, First@#] &];
col = Flatten[{#, {#2, Line[foo]}} & @@@ 
        Thread[{Range@Length@blocks, 
        RGBColor /@ RandomReal[{0, 1}, {Length@blocks, 3}]}] /. foo -> #1, 1];
GraphPlot[coloredRule, ImagePadding -> 10, 
  EdgeRenderingFunction -> (Function@Switch[Slot@3, foo] /. foo -> Sequence @@ Evaluate@col), 
  VertexLabeling -> True, 
  Method -> "CircularEmbedding"]

Of course, the doubled edges are coloured twice, so the last colour applied remains. I was wrong, the edges in that example are doubled, with two different colours.

The following produces the right number of edges:

grule = GatherBy[Gather[rule], Length];
singledColoredRule = Delete[coloredRule, List /@ Last /@ Table[Flatten@
       Position[MemberQ[grule[[2, i]], First@#] & /@ coloredRule, 
        True], {i, Length@grule[[2]]}]];
SeedRandom@4;
colours = RandomReal[{0, 1}, {Length@blocks, 3}];
col = Flatten[{#, {#2, Line[foo]}} & @@@ 
     Thread[{Range@Length@blocks, RGBColor /@ colours}] /. foo -> #1, 1];
g[size_] := GraphPlot[singledColoredRule, 
   EdgeRenderingFunction -> (Function@Switch[Slot@3, foo] /. foo -> Sequence @@ Evaluate@col), VertexLabeling -> True, 
   Method -> "CircularEmbedding", ImageSize -> size];

label = 
  Grid[Partition[Graphics[{RGBColor@#, Rectangle[], White, Text[#2, {0.5, 0.5}]}] & @@@
     Thread@{colours, StringJoin /@ Map[ToString, blocks, {2}]}, 3, 3, 1, {}], 
     Spacings -> {-1, -1}, ItemSize -> {[email protected], 0}];
Row@{g@350, label}

Of course, now one edge belonging to two different blocks will only take the colour of the latest block.

Answer 2

 blocks = {{0, 1, 2, 3}, {0, 1, 4, 5}, {0, 2, 4, 6}, {0, 3, 7, 8}, 
           {0, 5, 7, 9}, {0, 6, 8, 9}, {1, 2, 7, 8}, {1, 3, 6, 9},
           {1, 4, 7, 9}, {1, 5, 6, 8}, {2, 3, 5, 9}, {2, 4, 8, 9}, 
           {2, 5, 6, 7}, {3, 4, 5, 8}, {3, 4, 6, 7}};
edglst = {0 -> 1, 1 -> 2, 2 -> 3, 0 -> 1, 1 -> 4, 4 -> 5, 0 -> 2, 
          2 -> 4, 4 -> 6, 0 -> 3, 3 -> 7, 7 -> 9, 0 -> 6, 6 -> 8, 8 -> 9, 
          1 -> 2, 2 -> 7, 7 -> 8, 1 -> 3, 3 -> 6, 6 -> 9, 1 -> 4, 4 -> 7, 
          7 -> 9, 1 -> 5, 5 -> 6, 6 -> 8, 2 -> 3, 3 -> 5, 5 -> 9, 2 -> 4, 
          4 -> 8, 8 -> 9, 2 -> 5, 5 -> 6, 6 -> 7, 3 -> 4, 4 -> 5, 5 -> 8, 
          3 -> 4, 4 -> 6, 6 -> 7};

The following trick works in Version 9 if the number of edges between a pair of vertices is at most 2:

edglst2 = Join @@ (Tally[edglst] /. 
           {Rule[a_, b_], 2} :> {Rule[a, b], Rule[b, a]} /. {x_Rule, 1} :> {x});
vopts = {VertexStyle -> LightYellow, VertexSize -> 0.20, 
         VertexLabels -> Placed["Name", {1/2, 1/2}], 
         VertexLabelStyle -> Directive[20, Red, Bold, Italic]};

gg = Graph[edglst2, vopts, GraphLayout -> "CircularEmbedding", 
           VertexLabels -> "Name", ImagePadding -> 20, ImageSize -> 500, 
           EdgeShapeFunction -> "Line", BaseStyle -> Thick];
gg2 = HighlightGraph[gg, (EdgeList[Subgraph[gg, #]] & /@ blocks), 
                     ImageSize -> 500, BaseStyle -> Thick];
Row[{gg, gg2}]

To "mimic" the edge directions in the original graph, one can use EdgeShapeFunction as follows:

eS = Property[DirectedEdge[#, #2], EdgeShapeFunction -> 
       GraphElementData[{"FilledArrow", "ArrowSize" -> #3, "ArrowPositions" -> #4}]] &;

edglstb = Join @@ (Tally[edglst] /. {Rule[a_, b_], 2} :> 
                                     {esf[a, b, .03, .9], esf[b, a, -.03, .1]} /. 
                                 {Rule[a_, b_], 1} :> {esf[a, b, .03, .98]});
ggb = Graph[edglstb, vopts,GraphLayout -> "CircularEmbedding", VertexLabels -> "Name",
            ImagePadding -> 20, ImageSize -> 500, BaseStyle -> Thick];
ggb2 = HighlightGraph[ggb, EdgeList[Subgraph[ggb, #]] & /@ blocks, 
                      ImageSize -> 500, BaseStyle -> Thick];
Row[{ggb, ggb2}]