How to Derive Tuples Without Replacement

Question

Given a couple of lists like a={1,2,3,4,6} and b={2,3,4,6,9} I can use the built-in Mathematica symbol Tuples [{a,b}] and get all the arrangements easilly enough. But I am struggling with how to eliminate the generation of replacement results, for example:

{2,2} and {4,2} and {4,4} are not desired but all the totally unique results like {1,2} and {1,3} are desired. So essentially I want to find all the combinations of numbers that do not have any ordering repeats such as {4,2} where I already have {2,4} and no number repeats such as {2,2} and {4,4}.

Any ideas would be appreaciated!

Answer 1

Here is an alternative version of Mr. Wizard's uniqueTuples function, which is faster on the data I have tested.

The idea is to create a function f which has the following properties:

• It returns an empty Sequence[] if two of its arguments are the same

• For any other input it outputs a List of the arguments, but also sets a downvalue so that next time it is called with the same arguments, it returns an empty Sequence[]

• It is Orderless so that "the same arguments" can be in any order

The two input lists are then processed by Outer, feeding each tuple (as a flattened sequence of arguments) to f.

For example,

• The list elements provided by Outer are {1,2,3} and 2. We evaluate f[1,2,3,2] which returns Sequence[] because 2 is duplicated.

• The next list elements provided by Outer are {4,5,6} and 7. We evaluate f[4,5,6,7] which returns {4,5,6,7} and sets f[4,5,6,7]=Sequence[].

• The next list elements provided by Outer are {5,7,4} and 6. We evaluate f[5,7,4,6] which is the same as f[4,5,6,7] and therefore returns Sequence[].

So the output from these 3 calls to f is just {4,5,6,7} as the others are not considered unique.

The alternative uniqueTuples looks like this:

(* this is the re-written bit *)
uniqueTuples[a_List, b_List] := Module[{f},
  f[___, x_, x_, ___] = Sequence[];
  f[x_, y__] := (f[x, y] = Sequence[]; {x, y});
  SetAttributes[f, Orderless];
  Flatten[Outer[f @@ Flatten[{##}] &, a, b, 1], 1]]

(* this is the same as Mr. Wizard *)
uniqueTuples[{a_List, x__List}] := Fold[uniqueTuples, a, {x}] 

Testing on data = RandomInteger[40, {6, 11}] gave me a Timing of 47.7 seconds for Mr. Wizards original code, and 6.6 seconds using this. I have no idea how the timings and memory usage scale as you go to larger data sets.

Answer 2

Edit 2015

While I found Simon Woods's code informative to the degree that I awarded it a bounty it seems that the only reason it performed better than mine was that DeleteDuplicates was slow. Fred Simons pointed out that my (original) code is no longer slow, and actually outperforms Simon Woods' function. Experimentation showed that using Union in version 7 would have improved the performance of my code by more than an order of magnitude. In version 10.0.2 the improvement is more subtle but still significant. Following this discovery I am rewriting my function. The output will be in a different order but it is otherwise identical. If you wish to compare the original code please see the edit history for the image before this edit was made.

---

I recommend this:

uniqueTuples[a_List, b_List] :=
  Union @@ Table[
    Sort @ Flatten[{i, #}] & /@ DeleteCases[b, Alternatives @@ i],
    {i, a}
  ]

uniqueTuples[a : {__List}] := Fold[uniqueTuples, a]

Usage:

uniqueTuples[ {{3, 7, 2, 6}, {7, 6, 2, 1}, {7, 2, 4, 6}} ]

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

---

Explanation

The idea is to append an element only if it is not in the existing list. This is done with DeleteCases.

• Alternatives @@ (list) gives a pattern that matches any element in list.

• Flatten[{i, #}] & is used to append to both a list or a single element.

• This function is mapped (/@) to any remaining elements.

For multiple lists this process is repeated using the results of the previous lists as the new "a" list, using Fold. I am using the short syntax for Fold.

Answer 3

Take 1

You can use the following function if you don't have too many lists with too many elements:

uniqueTuples1[lists_] := 
 Union[Select[Union /@ Tuples[lists], Length[#] == Length[lists] &]]

uniqueTuples1[{a,b}]

This works by generating all possible tuples, and filtering out those that we don't want. The disadvantage is that the number of all tuples is very large, and for many lists with many elements, this will quickly fill up all available memory.

Take 2

For two lists only, the following algorithm is more memory efficient:

Join[Subsets[Intersection[a, b], {2}], 
     Tuples[{Complement[a, b], b}], 
     Tuples[{Complement[b, a], Intersection[a, b]}]]

Unfortunately generalizing this to an arbitrary number of lists is not trivial.

Answer 4

Union[Tuples[{a, b}] /. {(i_)..} :> Sequence[],SameTest -> (Length[Union[#1, #2]] == Length[#1] &)]  

not sure how fast it is compared to the other solutions though.

Answer 5

DISCLAIMER (update): as you can see my simple code just filters tuples with strictly ascending ordering. That is why it works correctly only if there is no gaps between elements of initial lists. For example:

In[23]:= Select[Tuples@{{1, 2, 5}, {3, 4, 5}}, Less @@ # &]

Out[23]= {{1, 3}, {1, 4}, {1, 5}, {2, 3}, {2, 4}, {2, 5}}

As you can see, the {5,3} tuple is missing. So I must apologize for misleading all of you.

---

Here is my variant:

lists = {{1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}};
Select[Tuples@lists, And @@ Less @@@ Partition[#, 2, 1] &]

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

EDIT

Partition and And are redundant:

lists = {{1, 2, 3, 5, 6, 7}, {2, 3, 4, 5, 6, 7}, {3, 4, 5, 6, 7, 
    8}, {4, 5, 6, 7, 8, 9}, {5, 6, 7, 8, 9, 10}, {6, 7, 8, 9, 10, 11, 12}};

a = Select[Tuples@lists, And @@ Less @@@ Partition[#, 2, 1] &]; // AbsoluteTiming
b = Select[Tuples@lists, Less @@ # &]; // AbsoluteTiming
a == b

---
{0.8125000, Null}
{0.1875000, Null}
True

Answer 6

Method 1: (simple idea, but slow performance)

Here's another implementation that seems simpler (at least to me), and with a few runs on data = RandomInteger[40, {6, 11}], it took around 120 seconds of Timing.

data = RandomInteger[40, {6, 11}];
Y = Sort[#] & /@ Tuples[data];
Z = DeleteDuplicates /@ Y;
T = Select[Z, Length[#] == Length[data] &];
DeleteDuplicates[T];

I know I'm not being very creative with the variable names, but I didn't want to make it a "one-liner". I just think it is easier to read this way :)

Optional: You can add another Sort at the end if you want your tuples sorted. That obviously adds to the CPU time.

Method 2: (same idea, but improved performance by an order of magnitude)

Use Union instead of DeleteDuplicates. Only 12 seconds are needed to calculate the result!

data = RandomInteger[40, {6, 11}];
Y = Sort[#] & /@ Tuples[data];
Z = Union /@ Y;
T = Select[Z, Length[#] == Length[data] &];
Union@T;

Now that I read it more carefully, this is actually the same method as Szabolcs' answer above.

Answer 7

Focusing on the elimination of duplicates (vs. the generation of uniqueTuples), I have two common functions I use in my notebooks, which when used together without making any assumptions about the input (ie. pairwise sublists or the input even being a list), provide a simple solution.

(* Eliminate duplicates of any permutation in a list *)
noDups@in_:=in;
noDups@in_List:=DeleteDuplicates[DeleteDuplicates@in, 
   If[#2=={},True,MemberQ[Permutations@#2,#1]]&];

(* Eliminate Nulls or empty lists or list elements with duplicate entries *)
noNull@in_List:=Select[DeleteCases[in,Null|{},2], Length@First@in==Length@noDups@#&];

Unfortunately, the //Timing is about half as fast as Spawn1701D's general Union based function. So if we make the assumption that the input can't be a single list of atomic elements (or Nulls or empty lists), we can use the following (the GatherBy given by Mr.Wizard here) which has excellent //Timing comparable even to the fastest solutions:

noDups@in_List := GatherBy[in~DeleteCases~{}, Sort][[All, 1]];
noNull@in_List := Select[in, Length@First@in == Length@Union@# &];

data = RandomInteger[80, {3, 40}];
t = Tuples@data;

noDups@noNull@t //Timing
{0.593750, {{69, 26, 32}, {69, 26, 59},...

Comparing the //Timing for reducing (vs. generating unique) Tuples on t, we get 9.5 Seconds on this reducing algorithm (vs. 5.7 Seconds for Simon Woods generating algorithm) on:

data = RandomInteger[40, {6, 11}];

See the following for explicit comparison (**Note: the timing being the same between the two functions on this significantly smaller data set).

In[1]:= noDups@in_List := GatherBy[in~DeleteCases~{}, Sort][[All, 1]];
         noNull@in_List := Select[in, Length@First@in == Length@Union@# &];

In[3]:= uniqueTuples[a_List, b_List] := 
          Module[{f}, f[___, x_, x_, ___] = Sequence[];
            f[x_, y__] := (f[x, y] = Sequence[]; {x, y});
            SetAttributes[f, Orderless];
            Flatten[Outer[f @@ Flatten[{##}] &, a, b, 1], 1]]
         uniqueTuples[{a_List, x__List}] := Fold[uniqueTuples, a, {x}]

In[5]:= a = {1, 2, 3, 4, 6};
         b = {2, 3, 4, 6, 9};
         t = Tuples[{a, b}];

In[8]:= r1 = noDups@noNull@t
Out[8]= {{1, 2}, {1, 3}, {1, 4}, {1, 6}, {1, 9}, {2, 3}, {2, 4}, {2, 6}, {2, 9}, {3, 4}, {3, 6}, {3, 9}, {4, 6}, {4, 9}, {6, 9}}

In[9]:= r2 = uniqueTuples[{a, b}]
Out[9]= {{1, 2}, {1, 3}, {1, 4}, {1, 6}, {1, 9}, {2, 3}, {2, 4}, {2, 6}, {2, 9}, {3, 4}, {3, 6}, {3, 9}, {4, 6}, {4, 9}, {6, 9}}

In[10]:= r1 == r2
Out[10]= True

In[11]:= data = RandomInteger[40, {5, 11}];
In[12]:= t = Tuples@data;

In[13]:= r1 = noDups@noNull@t // Timing
Out[13]= {1.578125,{{34,38,20,0,23},{34,38,20,0,8}{34,38,20,0,2},{34,38,20,0,7},{34,38,20,0,25},{34,38,20,0,35},{34,38,20,0,14},<<54534>>,{5,10,38,11,2},{5,10,38,11,7},{5,10,38,11,25},{5,10,38,11,35},{5,10,38,11,14},{5,10,38,11,28},{5,10,38,11,17}}}

In[14]:= r2 = uniqueTuples@data // Timing
Out[14]= {1.578125,{{0,20,23,34,38},{0,8,20,34,38},{0,2,20,34,38},{0,7,20,34,38},{0,20,25,34,38},{0,20,34,35,38},{0,14,20,34,38},<<54534>>,{2,5,10,11,38},{5,7,10,11,38},{5,10,11,25,38},{5,10,11,35,38},{5,10,11,14,38},{5,10,11,28,38},{5,10,11,17,38}}}

In[15]:= Sort[Sort@# & /@ r1[[2]]] == Sort[Sort@# & /@ r2[[2]]]
Out[15]= True