# Add elements of a list to sublists of another list, such that each of these sublists has minimum edges in the corresponding graph?

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


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?

• Thank you very much Martin; Now it looks much better indeed! Mar 9, 2017 at 12:35

## 2 Answers

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


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


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


• 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. Mar 9, 2017 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. Mar 9, 2017 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. Mar 9, 2017 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 9, 2017 at 12:50

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}}}