How can I optimise the creation of subsets?

Question

I have a list of 21 elements from which I have obtained possible combinations of minimum 3 and up to 10 elements using the Subsets function as follows:

Elements=RandomReal[1, 21];
Combinations=Subsets[Elements,{3,10}];

For simplicity's sake I have made the list of elements in this example a vector of 21 random reals. In reality, each element in my list is in itself a vector of length = ~60.

The elements in my list belong to 3 separate groups, and I need to ensure that the combinations contain at least one element from each group. I have done this in the following manner:

Group1 = Elements[[1 ;; 7]];
Group2 = Elements[[8 ;; 14]];
Group3 = Elements[[15 ;; 21]];

NewCombinations = {};
i = 1;
For[i = 1, i <= Length[Combinations], i++,
 If[ContainsAny[Combinations[[i]], Group1] &&
    ContainsAny[Combinations[[i]], Group2] &&
    ContainsAny[Combinations[[i]], Group3],
   AppendTo[NewCombinations, Combinations[[i]]]
   ];
 ];

However, because the total possible number of subsets from 3 to 10 elements of a list of 21 elements (i.e. Length[Combinations]) is 1,048,344, and this way of creating new combinations includes a For cycle with 3 nested If cycles, the evaluation is taking forever.

Is there a way of simplifying or optimising the subroutine that calculates 'NewCombinations' to make it faster?

Thank you very much in advance!

Answer 1

SeedRandom[1];
elements = RandomReal[1, 21];
combinations = Subsets[elements, {3, 10}];
groups = Partition[elements, 7];

This took about 11 sec:

Timing[ingroups = 
  Length /@ (Table[
       Intersection[g, #] /. {} -> Nothing, {g, groups}] & /@ 
     combinations);
 pos = Position[ingroups, 3];
 answer = Extract[combinations, pos];]

{10.7969, Null}

Edited to add explanations

Taking a small subset of combinations for demonstration:

testlist = combinations[[100 ;; 107]]

  (* {{0.817389, 0.231155, 0.396006}, {0.817389, 0.231155, 
  0.700474}, {0.817389, 0.231155, 0.211826}, {0.817389, 0.231155, 
  0.748657}, {0.817389, 0.231155, 0.422851}, {0.817389, 0.231155, 
  0.247495}, {0.817389, 0.231155, 0.977172}, {0.817389, 0.231155, 
  0.825163}} *)

This takes the intersection of each element of testlist with each of the three groups:

Table[Intersection[g, #], {g, groups}] & /@ testlist

  (* {{{0.817389}, {0.231155, 0.396006}, {}}, {{0.817389}, {0.231155, 
   0.700474}, {}}, {{0.817389}, {0.211826, 
   0.231155}, {}}, {{0.817389}, {0.231155, 
   0.748657}, {}}, {{0.817389}, {0.231155, 
   0.422851}, {}}, {{0.817389}, {0.231155, 
   0.247495}, {}}, {{0.817389}, {0.231155}, {0.977172}}, {{0.817389}, \
{0.231155}, {0.825163}}} *)

When there is no intersection, the result is an empty list {}. Adding /. {} -> Nothing removes the empty lists.

temp = Table[Intersection[g, #] /. {} -> Nothing, {g, groups}] & /@ testlist

  (* {{{0.817389}, {0.231155, 0.396006}}, {{0.817389}, {0.231155, 
   0.700474}}, {{0.817389}, {0.211826, 
   0.231155}}, {{0.817389}, {0.231155, 
   0.748657}}, {{0.817389}, {0.231155, 
   0.422851}}, {{0.817389}, {0.231155, 
   0.247495}}, {{0.817389}, {0.231155}, {0.977172}}, {{0.817389}, \
{0.231155}, {0.825163}}} *)

Getting the length of each result (3 means the element of testlist at the same position had an intersection with all three groups):

ingroups = Length /@ temp

  (* {2, 2, 2, 2, 2, 2, 3, 3} *)

And the positions of 3

pos = Position[ingroups, 3]

  (* {{7}, {8}} *)

This gets the elements of testlist at those positions

Extract[testlist, pos]

  (* {{0.817389, 0.231155, 0.977172}, {0.817389, 0.231155, 0.825163}} *)
```

Answer 2

Here is a brute-force approach that deals with the indices of elements first but is not as flexible as the answer from @MelaGo. One advantage is that if there are several sets of elements, then the time consuming part which is getting the list of the positions only needs to be done once.

The combinations are the subsets with the indices rather than the elements. Then a combination is selected if the minimum is less than 8 (to make sure Group 1 is represented), the maximum is greater than 14 (to make sure Group 3 is represented), and the absolute distance from 11 is less than 4 (to make sure Group 2 is represented. (If there are more than 3 groups, then using the absolute distance of the midpoint of each group can be used as the metric to make decisions.)

elements = RandomReal[{0, 1}, 21];
indices = Range[21];
combinations = Subsets[indices, {3, 10}];

AbsoluteTiming[
 positions = Select[combinations, Min[#] < 8 && Max[#] > 14 && Min[Abs[# - 11]] < 4 &];
 answer = elements[[#]] & /@ positions;]
(* {5.2536641`,Null} *)

Length[answer]
(* 1001217 *)

Answer 3

TL/;DR

SeedRandom[1];

elements = RandomReal[1, 21];

constrainedSubsets[Partition[elements, 7], Range[3, 10]] // 
   Length // AbsoluteTiming

{0.765587, 1001217}

---

The function constrainedSubsets, defined below, generates the desired list of 1001217 constrained subsets directly rather than filtering combinations.

ClearAll[groupSubsets, groupCounts, constrainedSubsets]

The first helper function groupSubsets[{group1,group2,..., groupm}, {n1,n2,...,nm}] generates subsets of length $ n_1 + n_2 +\cdots+n_m$ containing exactly $n_i$ elements from $group_i$:

groupSubsets[grps_, gcounts_] /; And @@ Thread[gcounts <= Length /@ grps] := 
 Flatten[MapApply[Join] @ 
    Tuples @ MapThread[Subsets] @ {grps, List /@ gcounts}, {1}]

Example:

grps = {grp1, grp2, grp3} = {{1, 2}, {3, 4, 5}, {6, 7, 8, 9}};

highlight = MapThread[(a : Alternatives @@ # :> 
   Highlighted[a, Background -> #2]) &] @ {grps, {Red, Green, Yellow}};

Subsets of length 6 containing exactly 1 element from grp1, exactly 2 elements from grp2 and exactly 3 elements from grp3:

groupSubsets[grps, {1, 2, 3}] /. highlight

For a list of groups (groups = {group1, group2,..., groupm} ) and a list of subset sizes (sizes = {s1, s2,..., sk}), the second helper function groupSubsets[groups, sizes] generates integer partitions $p_i$ of $s_i$ of length $m$ (where m = Length @ {group1,...,groupm}) with the constraint that each element of $p_i$ is greater than 1 and no greater than the size of $group_i$:

groupCounts[grps_, sLengths_] := Select[And@@Thread[# <= (Length /@ grps)] &] @
  Flatten[Permutations /@ 
    IntegerPartitions[#, {Length @ grps}] & /@ sLengths, 2];

Example:

grps =  {{1, 2}, {3, 4, 5}, {6, 7, 8, 9}};

groupCounts[grps, Range[3, 5]]

 {{1, 1, 1}, {2, 1, 1}, {1, 2, 1}, {1, 1, 2}, {1, 3, 1},   
  {1, 1, 3}, {2, 2, 1}, {2, 1, 2}, {1, 2, 2}}

We combine groupSubsets and groupCounts to get a function that gives all subsets of a list of groups with lenghts in the list sLengths:

constrainedSubsets[grps_, sLengths_] := 
  Module[{gcounts = groupCounts[grps, sLengths]}, 
     Map[Splice @ groupSubsets[grps, #] &] @ gcounts]

Examples:

SeedRandom[1];

elements = RandomReal[1, 21];

combinations = Subsets[elements, {3, 10}];


constrainedSubsets[Partition[elements, 7], Range[3, 10]] // 
   Length // AbsoluteTiming

 {0.765587, 1001217}

Subsets of grps with length 3 or 4 containing at least one element from each group:

Multicolumn[constrainedSubsets[grps, Range[3, 4]] /. highlight, 8]