12
$\begingroup$

How could I obtain the list of all the groups of 5 numbers taken from Range[12] such that the 2 lists have an empty intersection :

{{1,2,3,4,5},{6,7,8,9,10}} would be a solution while

{{1,2,3,4,5}, {5,6,7,8,9}} should be rejected as 5 is common to both.

I am currently trying to do so using Position of empty Intersection very unsuccessfully.

allCombinations = 
 DeleteDuplicates@(Sort /@ Permutations[Range[12], {5}])

Function[base,
  Flatten[
   Position[
    Intersection[allCombinations[[base]], allCombinations[[#]]] & /@ 
     Drop[Range[792], {base}], {}], 1]] /@ Range[792]

With which I am trying to obtain the position of the lists in allCombination s, but I still get duplicates...

Improve this question
$\endgroup$
4
  • 1
    $\begingroup$ I'm assuming you want all possible pairs of lists, right? $\endgroup$ Commented Jan 29, 2012 at 17:29
  • 3
    $\begingroup$ Subsets[Range[12], {5}] has 792 elements. Pairing up results in a further combinatorial explosion. Some cleverness will be necessary. $\endgroup$ Commented Jan 29, 2012 at 17:37
  • $\begingroup$ Is the question general, i.e. how to get all non-intersecting size-$n$ subsets of a size-$m$ set? (This would cover all non-intersecting 3-element subsets of a 25 element set as well.) Or do you only need to partition sets into two parts (but not more than two)? $\endgroup$ Commented Jan 29, 2012 at 17:58
  • $\begingroup$ @Szabolcs, both ! My present problem was your second argument, but it is great to learn from solutions how to extend it :-) $\endgroup$ Commented Jan 30, 2012 at 3:07

7 Answers 7

Reset to default
13
$\begingroup$

Take all subsets of length 10, then for each one find all splits into two sets of five such that the first of the ten is in the first part of the split.

In[29]:= Timing[
 msets = Subsets[Range[12], {10}];
 m2 = Flatten[
   Map[With[{fst = First[#], subs = Subsets[Rest[#], {4}], mset = #}, 
      With[{s2 = Map[Join[{fst}, #] &, subs]}, 
       Map[{#, Complement[mset, #]} &, s2]]] &, msets], 1];]

Out[29]= {0.07799999999999985, Null}

In[30]:= Length[m2]

Out[30]= 8316
Improve this answer
$\endgroup$
7
$\begingroup$

This should be fast enough:

 Flatten[
     Map[
       Transpose[{ConstantArray[#1,{Length[#2]}],#2}]&@@
          {#,Subsets[Complement[Range[12],#],{5}]}&,
       Subsets[Range[12],{5}]
     ],
     1]//Short//Timing

(*
   ==>  {0.031,{{{1,2,3,4,5},{6,7,8,9,10}},<<16630>>,{{8,9,10,11,12},{3,4,5,6,7}}}}
*)

If you don't want double- counting, apply Union[Sort/@#]& to the result - will still be fast.

Improve this answer
$\endgroup$
8
  • $\begingroup$ @R.M That could be fixed by using Complement[Range[12], #, Range[Min[#]]]. $\endgroup$ Commented Jan 29, 2012 at 18:06
  • $\begingroup$ @R.M. I added a note on that, while you were writing the comment - the overhead of avoiding duplicates is not very large. The biggest win is to avoid blind search over millions of combinations - post-processing a relatively small list of results is not a big deal. $\endgroup$ Commented Jan 29, 2012 at 18:06
  • $\begingroup$ @LeonidShifrin, you could make it right with the duplicates and faster by asking only for half of the subsets, Subsets[Range[12], {5}, Binomial[12, 5]/2] $\endgroup$ Commented Jan 29, 2012 at 18:18
  • $\begingroup$ @Rojo Thanks, that's a good point. $\endgroup$ Commented Jan 29, 2012 at 18:32
  • $\begingroup$ @Leonid, fast indeed ! Thank You ! $\endgroup$ Commented Jan 29, 2012 at 20:27
5
$\begingroup$

Perhaps

res = With[{list = Range[12]},
    Function[{candidates}, DeleteDuplicates[
       Sort /@ ({#, Complement[candidates, #]} & /@ 
          Subsets[candidates, {5}])]] /@
     (Complement[list, #] & /@ Subsets[list, {2}])
    ]~Flatten~1;

In[42]:= Length[res]

Out[42]= 8316

Takes 0.06 secs Finds 8316 solutions. I first built all the subsets of 10 numbers out of Range[12]. Then, for each subset of 10 numbers, you find all the 5 subsets and their complements. Number of subsets of 10 numbers out of 12 is

In[44]:= Binomial[12, 10]

Out[44]= 66

Now, all the subsets of 5 out of 10

In[51]:= Binomial[10, 5]

Out[51]= 252

You get

In[52]:= % %%

Out[52]= 16632

Now, those are counting double. The pair {{1,2,3,5,7}, {4,6,9,10,11}} as well as the pair {{4,6,9,10,11} ,{1,2,3,5,7}} would be found. So I just flatten and delete half of them. Perhaps there's a way to avoid this but it seemed good enough at first.

In[53]:= %/2

Out[53]= 8316
Improve this answer
$\endgroup$
5
$\begingroup$

Here is a straightforward solution using Outer to get you started. It takes 3 seconds on my machine.

Outer[If[OrderedQ[{#1, #2}] && Intersection[#1, #2] == {}, {#1, #2}, ## &[]] &, 
    #, #, 1] &@Subsets[Range@12, {5}]~Flatten~1

enter image description here

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ +1. If we add // Flatten[#, 1]& to the end, then a list of pairs is returned. Also, if the OP does not care about the order within each pair, then the extra condition OrderedQ[{#1, #2}] will eliminate equivalent solutions. $\endgroup$ Commented Jan 29, 2012 at 18:07
5
$\begingroup$

Or maybe something like

lst = ReplaceList[Subsets[Range[12], {5}], {___, a_, ___, b_, ___} /; 
  Intersection[a, b] === {} :> {a, b}]

Slightly different approach would be

Flatten[{Position[#, 1], Position[#, 2]} & /@ 
  Permutations[
    Join[ConstantArray[1, 5], ConstantArray[2, 5], ConstantArray[0, 2]]], 
 {{1}, {2}, {4, 3}}]

It's a lot faster than the first approach but has the disadvantage that every pair appears twice.

Improve this answer
$\endgroup$
6
  • $\begingroup$ I like the idea behind you second solution (I came up with the same independently). My version looks like: {Pick[Range[12], #, 1], Pick[Range[12], #, 2]} & /@ Permutations[{1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 3, 3}] (just a concept to illustrate, not yet generalized to arbitrary-length sets). Union will easily get rid of duplicates. +1 $\endgroup$ Commented Jan 29, 2012 at 18:33
  • $\begingroup$ @Szabolcs Thanks, I tried Pick first but it was a factor 8 slower than this version. Plus it gave me a chance to use the fancy form of Flatten ;-) $\endgroup$ Commented Jan 29, 2012 at 18:36
  • $\begingroup$ @Heike, Thank you, I don`t get the mechanism by which you remove duplicates, could you explain ? $\endgroup$ Commented Jan 29, 2012 at 20:26
  • $\begingroup$ @500 Which mechanism are you referring to? Neither of my solutions uses a mechanism to remove duplicates. $\endgroup$ Commented Jan 29, 2012 at 20:35
  • $\begingroup$ The First one (pairs only appear once) which i believe other solution don`t do ? $\endgroup$ Commented Jan 29, 2012 at 20:37
3
$\begingroup$

The idea is generating all subsets of length $s$. For each of these sets, the complement with respect to the whole list is calculated, then the subsets of the complement lists, and then each of the original sublists has to be combined with the complement lists.

n = 4;
s = 2;
groupings[range_, subrange_] := Module[{rest, subsets, result, list},

    (* Generate all subsets of length s *)

    list = Subsets[Range[n], {s}];

    (* Find the complement of each subset w.r.t. the whole thing *)

    rest = Complement[Range[range], #] & /@ list;

    (* Generate possible subsets of that complement *)

    subsets = Subsets[#, {subrange}] & /@ rest;

    (* Everything's been generated now,
    all that's left is data aggregation magic. *)

    result = {list, subsets} // Transpose;
    result = (llist \[Function] {llist[[1]], #} & /@ llist[[2]]) /@
    result;
    result = Flatten[result, 1];
    result = Sort[#, #1[[1]] < #2[[1]] &] & /@ result;
    Union[result]
]
groupings[n, s]

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

For $n=12$, $s=5$, this produces $8316$ pairings and takes $0.1$ seconds.

Improve this answer
$\endgroup$
3
$\begingroup$

This appears to be about 40X faster than Daniel's method and 16X faster than Leonid's.

It works by calculating the sequence of parts for sets of 2 n (ten in the example) only once, and then extracting those parts from each subset of set (Range[12] in the example).

splits[set_List, n_Integer] :=
  Fold[Partition,
      Join @@ Developer`ToPackedArray[Subsets[set, {2 n}]][[All, #]],
      {n, 2}
  ] & @ Flatten[{#, Range[2 n] ~Complement~ #} & /@ Subsets[Range[2 n - 1], {n}], 2]

Usage:

splits[Range@12, 5]

A minor speed improvement may be had by also packing the parts list, but it does not seem worth the extra code.

Improve this answer
$\endgroup$
4
  • $\begingroup$ Good idea. I had toyed with doing it once and then using replacement rules but discarded that as likely to be hopelessly slow. But using the "basic case" for parts is very nice (even if it sounds cannibalistic when worded that way). $\endgroup$ Commented Jan 31, 2012 at 22:57
  • $\begingroup$ @Daniel thank you. Please see my update for another nice performance boost. Of course this is only faster if set is packable. $\endgroup$ Commented Jan 31, 2012 at 23:49
  • $\begingroup$ OK, I'll look. (Can't do anything more than that, I already gave you an upvote.) $\endgroup$ Commented Jan 31, 2012 at 23:56
  • $\begingroup$ @Daniel Thanks for the vote; I wanted your eyes because (1) I thought this was of interest (2) I often make mistakes and I hoped you'd catch any. $\endgroup$ Commented Feb 1, 2012 at 0:14

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.