2
$\begingroup$

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!

Improve this question
$\endgroup$

3 Answers 3

Reset to default
4
$\begingroup$ 
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}} *) ```
Improve this answer
$\endgroup$
2
  • $\begingroup$ This took 45.7 seconds to run, and the dimensions of 'answer' match what it should be. Would you mind explaining how this amazing piece of code works, please? $\endgroup$ Commented Oct 5, 2023 at 1:11
  • 2
    $\begingroup$ @LNah I added some explanations to the answer. $\endgroup$ Commented Oct 5, 2023 at 1:49
3
$\begingroup$

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 *)
Improve this answer
$\endgroup$
3
$\begingroup$

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

enter image description here

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]

enter image description here

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.