4
$\begingroup$

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?

Improve this question
$\endgroup$
1
  • $\begingroup$ Thank you very much Martin; Now it looks much better indeed! $\endgroup$
    – Marilla
    Commented Mar 9, 2017 at 12:35

2 Answers 2

Reset to default
2
$\begingroup$

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

Improve this answer
$\endgroup$
4
  • $\begingroup$ 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. $\endgroup$
    – Martin Ender
    Commented Mar 9, 2017 at 12:37
  • $\begingroup$ 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. $\endgroup$
    – Marilla
    Commented Mar 9, 2017 at 12:38
  • $\begingroup$ @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. $\endgroup$
    – Martin Ender
    Commented Mar 9, 2017 at 12:40
  • $\begingroup$ @Martin, thanks for the link to J.M.'s answer. Did think about generalization to arbitrary number of lists in aa, but got lazy:) $\endgroup$
    – kglr
    Commented Mar 9, 2017 at 12:50
0
$\begingroup$

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

Improve this answer
$\endgroup$

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.