Selection of lists among list of lists to maximize coverage and avoid repetitions

Question

There is a list of 'list of consecutive integers'. There could be a single integer as well.

Example list:

list = {{2, 3, 4}, {3, 4, 5}, {3, 4, 5, 6}, {7}, {4, 5, 6, 7}}

Also given is the minimum and maximum integer of all lists combined (2,7) in above case.

By choosing one or more of above lists, the aim is to maximize coverage in (2,7) without having a single repetition of any integer across all selected lists.

As an example, {3,4,5,6,7} seems to be the largest set of integers that can be obtained by selecting and joining sublists from list without introducing duplicates. How to obtain this set?

Answer 1

You can use LinearProgramming for this. Let v be a vector of 1s and 0s specifying which sublist is included. Then, the criteria that 3 only appears once is equivalent to:

$$\{1,1,1,0,0\}.v\leq 1$$

That is, only one of the first 3 sublists can be included. With the constraints satisfied, the total number of integers included is just the sum of the lengths of each included sublist. Hence, the objective function is (LinearProgramming returns a minimum):

$$\{-3,-3,-4,-1,-4\}$$

So, a LinearProgramming solution is:

LinearProgramming[
    -{3, 3, 4, 1, 4},
    {
        {1,0,0,0,0}, (* 2 *)
        {1,1,1,0,0}, (* 3 *)
        {1,1,1,0,1}, (* 4 *)
        {0,1,1,0,1}, (* 5 *)
        {0,0,1,0,1}, (* 6 *)
        {0,0,0,1,1} (* 7 *)
    },
    Table[{1,-1}, {6}],
    0,
    Integers
]

LinearProgramming::lpip: Warning: integer linear programming will use a machine-precision approximation of the inputs.

{0, 0, 1, 1, 0}

We can package this up as a function:

disjointMaximum[sets_] := Module[{elems = DeleteDuplicates @ Flatten @ sets, lp},
    lp = Quiet[
        LinearProgramming[
            - Length /@ sets,
            Table[Boole @ Map[Not@*FreeQ[k]] @ sets, {k, elems}],
            Table[{1, -1}, {Length[elems]}],
            0,
            Integers
        ],
        LinearProgramming::lpip
    ];
    Pick[sets, lp, 1]
]

For the OP example, we again get:

disjointMaximum[{{2, 3, 4}, {3, 4, 5}, {3, 4, 5, 6}, {7}, {4, 5, 6, 7}}]

{{3, 4, 5, 6}, {7}}

Answer 2

This is a fun problem. I suspect there are many, very different ways of going about it. Here's a way using graphs. I'll give you the packaged version, and then I'll explain it in a bit more detail. I should note that I haven't tried to optimize this in any way, and don't know how it'll fare with large lists.

TL;DR: The Function

maxcover[listoflists_] := 
 Block[{g}, 
  g = AdjacencyGraph[
    Partition[
     Boole[Intersection[#1, #2] == {} & @@@ Tuples[listoflists, 2]], 
     Length@listoflists]];
  listoflists[[#]] & /@ 
   MaximalBy[FindClique[g, Length@listoflists, All], 
    Length@Flatten@listoflists[[#]] &]
  ]

Then with

list = {{2, 3, 4}, {3, 4, 5}, {3, 4, 5, 6}, {7}, {4, 5, 6, 7}};

we get

maxcover[list]

(* {{{3, 4, 5, 6}, {7}}} *)

as required.

The Explanation

Using a slightly more complex example:

list = DeleteDuplicates@Table[
   Range[#1, #1 + #2] & @@ {s = RandomInteger[{1, 10}], 
     RandomInteger[{0, Min[4, 10 - s]}]},
   8]

(* {{10}, {6, 7, 8, 9, 10}, {4, 5, 6, 7}, {3}, {3, 4}, {3, 4, 5, 6, 7}, {8}} *)

The first step is to create an incidence matrix for the relation of having an empty intersection. That is, where element [[i, j]] is 1 if intersection between the i^th and j^th subsets is empty, and a 0 otherwise.

im = Partition[Boole[
  Intersection[#1, #2] == {} & @@@ Tuples[lst, 2]], 
  Length@lst]

Now we can define our graph, using the incidence matrix as the adjacency matrix:

g = AdjacencyGraph[im, VertexLabels -> Automatic]

In the above graph, the nodes correspond to the subsets of list and connected nodes correspond to subset pairs with empty intersection. Therefore, a clique corresponds to a set of subsets such that all intersections are empty.

For example, in that graph there's a four-node clique ({1, 3, 4, 7}) and two three-node cliques ({1, 5, 7} and {1, 6, 7}). And you can easily check that, say,

list[[{1, 5, 7}]]

(* {{10}, {3, 4}, {8}} *)

indeed has no shared elements.

So now we grab those cliques, pick the ones that cover the largest range of values (that is, have the longest Flattened length, since there's no doubling up), and then get the corresponding subsets from list:

cliques = FindClique[g, Length@list, All]
maxcliques = MaximalBy[cliques, Length@Flatten@list[[#]] &]
list[[#]] & /@ maxcliques

(* {{1, 3, 4, 7}, {1, 6, 7}, {1, 5, 7}, {2, 5}, {2, 4}}

   {{1, 3, 4, 7}, {1, 6, 7}, {2, 5}}

   {{{10}, {4, 5, 6, 7}, {3}, {8}}, 
    {{10}, {3, 4, 5, 6, 7}, {8}}, 
    {{6, 7, 8, 9, 10}, {3, 4}}} *)

Which is, of course, the result given by maxcover.

I haven't Sorted the output in any way, or Unionized the returned components. But that's easily done if you need it.

Answer 3

Here's the brute force solution:

 list = {{2, 3, 4}, {3, 4, 5}, {3, 4, 5, 6}, {7}, {4, 5, 6, 7}}

First we get the list of all possible sublists we can select together. Tuples can do this very easily:

selectionList = Tuples[{#, {}}& /@ list]

Next we join the elements of each selection up and pick the selections that are duplicate-free:

duplicateFree = Select[Join @@@ selectionList, DuplicateFreeQ]

Finally, we take the longest selection:

First @ TakeLargestBy[duplicateFree, Length, 1 ]

The result being {3, 4, 5, 6, 7}.