1
$\begingroup$

Consider a graph which is as shown below.

conn = {1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 7, 
   2 \[UndirectedEdge] 3, 2 \[UndirectedEdge] 4, 
   3 \[UndirectedEdge] 4, 3 \[UndirectedEdge] 5, 
   4 \[UndirectedEdge] 5, 5 \[UndirectedEdge] 6, 
   6 \[UndirectedEdge] 7, 6 \[UndirectedEdge] 8, 
   7 \[UndirectedEdge] 8};
g = Graph[conn, VertexLabels -> "Name"]

My hand drawn graph looks like this: enter image description here

Question: I would like to color this graph with 2 colors only. The VertexChromaticNumber of the graph is 3, however, I am interested in having colored with 2 with violations accepted. I would like to see maximum extent to which we are able to maintain proper coloring with adjacent nodes.

Starting with node 1: enter image description here

Starting with node 4: If we start

Basically, with a given starting node, I would like to enforce proper coloring of the starting node and then try to have all other nodes properly colored to the extent possible.

I have been trying to use IGraph functionality on vertex coloring. I found k-coloring section where nodes can be forced to have colors. But I don't know if it can be used in this context. Can someone please help me with this.

$\endgroup$
2
  • 2
    $\begingroup$ You could try to generate the distance matrix for the graph, look at the row for your starting point, and color all nodes according to their distance to the starting point (i.e. alternating colors for odd and even distances). This should get you what you want $\endgroup$
    – Lukas Lang
    Aug 26, 2023 at 12:05
  • $\begingroup$ Thank you @LukasLang for your comments. Just tried your suggestion, I think this is a nice way. m1 = GraphDistanceMatrix[g] vxs = VertexList[g]; data = AssociationThread[vxs -> Mod[m1[[1]], 2]]; I could see the starting node is ensured to have proper color mapping. Rest all nodes, seems to be okay as well. I will try to confirm further. Thanks a lot for your suggestion. $\endgroup$ Aug 26, 2023 at 14:32

1 Answer 1

2
$\begingroup$

Making use of Lukas Lang's suggestion in comments:

Graph[conn, 
 VertexCoordinates -> MapIndexed[#2[[1]] -> # &] @ 
  Thread[{Range @ VertexCount @ conn, 0}], 
 EdgeShapeFunction -> 
  (Module[{c = If[Abs[#2[[2]] - #2[[1]]] == 1, 0, -3/2 (-1)^(#2[[1]])]},
   GraphComputation`GraphElementData[{"CurvedArc", "Curvature" -> c}][#, #2]] &),
 PlotTheme -> "NameLabeled",
 VertexLabelStyle -> 16,
 VertexSize -> .5,
 VertexStyle -> 
  {v_ :> ({LightRed, LightGreen}[[Mod[GraphDistance[conn, 1, v], 2, 1]]])},
 PlotRange -> {{0, 9}, {-1, 3}},
 GridLines -> {Range[0, 10, .2], Range[-1, 3, .2]},
 GridLinesStyle -> LightGray, 
 ImageSize -> Large]

enter image description here

$\endgroup$
1
  • 1
    $\begingroup$ Thanks a lot @kglr. Lot of things to learn from your answer. $\endgroup$ Aug 27, 2023 at 5:01

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.