4

I've got a graph g with the following adjacency matrix:

adj = {{0, 0, 0, 1, 0, 0, 1, 0, 1, 0}, 
       {0, 0, 1, 0, 1, 1, 0, 0, 1, 1}, 
       {0, 1, 0, 0, 1, 1, 0, 0, 1, 1}, 
       {1, 0, 0, 0, 1, 0, 1, 0, 1, 0}, 
       {0, 1, 1, 1, 0, 1, 0, 0, 1, 0}, 
       {0, 1, 1, 0, 1, 0, 1, 1, 1, 1}, 
       {1, 0, 0, 1, 0, 1, 0, 1, 1, 1}, 
       {0, 0, 0, 0, 0, 1, 1, 0, 1, 1}, 
       {1, 1, 1, 1, 1, 1, 1, 1, 0, 1}, 
       {0, 1, 1, 0, 0, 1, 1, 1, 1, 0}};

g = AdjacencyGraph[adj, VertexLabels -> "Name"]

enter image description here

Now I have list A, which contains mutually disjoint sets of vertices, such that no two vertices in one of the sets share an edge:

A = {{3, 4, 8}, {1, 5, 10}}

In other words, the subgraphs spanned by each of these subsets contain no edges.

And I've also got a list B which contains the remaining vertices:

B = {2, 6, 7, 9}

Now I want to add the vertices from B to the subsets in A such that the total number of edges in the subgraphs spanned by the resulting subsets is minimal. For example, if I were to add 2 to the set {3, 4, 8} the resulting subgraph would contain a single edge, but adding it to {1, 5, 10} instead would result in a subgraph with two edges.

For this example, the optimal solution is to add 2 and 7 to the first set, and 6 and 9 to the second, resulting in only 9 edges in both subgraphs together.

Is there a simple and efficient way to compute an optimal solution this problem?

Martin Ender
  • 8,774
  • 1
  • 34
  • 60
Marilla
  • 165
  • 7

2 Answers2

2

A brute-force approach:

ClearAll[objF]
adjm = {{0, 0, 0, 1, 0, 0, 1, 0, 1, 0}, {0, 0, 1, 0, 1, 1, 0, 0, 1, 1}, 
        {0, 1, 0, 0, 1, 1, 0, 0, 1, 1}, {1, 0, 0, 0, 1, 0, 1, 0, 1, 0}, 
        {0, 1, 1, 1, 0, 1, 0, 0, 1, 0}, {0, 1, 1, 0, 1, 0, 1, 1, 1, 1}, 
        {1, 0, 0, 1, 0, 1, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 1, 1, 0, 1, 1}, 
        {1, 1, 1, 1, 1, 1, 1, 1, 0, 1}, {0, 1, 1, 0, 0, 1, 1, 1, 1, 0}};

aa = {{3, 4, 8}, {1, 5, 10}};
bb = {2, 6, 7, 9};

ag = AdjacencyGraph[adjm, VertexLabels->"Name", VertexStyle->Large, ImagePadding->20];

cc = {Join[aa[[1]], #], Join[aa[[2]], Complement[bb, #]]} & /@ Subsets[bb];

objF[g_] := EdgeCount[Subgraph[g, #[[1]]]] + EdgeCount[Subgraph[g, #[[2]]]] &;

HighlightGraph[ag, Join[Style[#, Green] & /@ aa[[1]], Style[#, Red] & /@ aa[[2]]]]

Mathematica graphics

 dd = MinimalBy[cc, objF[ag]][[1]]

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

 objF[ag]@dd

9

HighlightGraph[ag, Join[Style[#, Green] & /@ dd[[1]], Style[#, Red] & /@ dd[[2]]]]

Mathematica graphics

HighlightGraph[ag, Join[Style[#, Thick, Green] & /@ EdgeList[Subgraph[ag, dd[[1]]]], 
   Style[#, Thick, Red] & /@ EdgeList[Subgraph[ag, dd[[2]]]]]]

Mathematica graphics

kglr
  • 394,356
  • 18
  • 477
  • 896
  • This is actually what I did just now to figure out the reference solution, but note that using Subsets and Complement doesn't generalise if there are more than two sets in A (although it's not clear whether that's a possibility). If it is, then one would need option three from this answer, filtered for the right number of partitions. – Martin Ender Mar 09 '17 at 12:37
  • Thank you very much kglr for your extensive answer. I did it with a nested Do loop; however, your way looks more professional and efficient. Thanks once again. – Marilla Mar 09 '17 at 12:38
  • @Marilla It's nice and clean but it's certainly not efficient (which is implied by kglr's first three words). This will look at all |B|^|A| possible solutions, and each of them is at least linear in the size of the graph, so this will be infeasible once your graph gets bigger. – Martin Ender Mar 09 '17 at 12:40
  • @Martin, thanks for the link to J.M.'s answer. Did think about generalization to arbitrary number of lists in aa, but got lazy:) – kglr Mar 09 '17 at 12:50
0

Compute possible partitions:

Needs["Combinatorica`"];
part = Join[KSetPartitions[bb, Length[aa]], Permutations[Append[ConstantArray[{}, Length[aa] - 1], bb]]]

MinimalBy[part, 
 Total[MapThread[EdgeCount[Subgraph[g, Join[#1, #2]]] &, {aa, #}]] &]

{{{2, 7}, {6, 9}}}

halmir
  • 15,082
  • 37
  • 53