Message Boards Message Boards

0
|
5863 Views
|
10 Replies
|
0 Total Likes
View groups...
Share
Share this post:
GROUPS:
Mathematica

Find all the possible ways of splitting a list in a set of pairs of element

Stefano De Nicola
Posted 10 years ago

I have a list {x1,...,xN] where N is even, and I need to find all the possible ways to split it into pairs of elements, e.g. the output I would like is something like (say N=4):

{{{x1,x2},{x3,x4}},{{x1,x3}{x2,x4}},{{x1,x4},{x2,x3}}}

How can this be achieved?
POSTED BY: Stefano De Nicola
10 Replies
Sort By:

How about using Permutations?

In[1]:= data = Range[4]

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

In[2]:= Permutations[data, {2}]

Out[2]= {{1, 2}, {1, 3}, {1, 4}, {2, 1}, {2, 3}, {2, 4}, {3, 1}, {3, 
  2}, {3, 4}, {4, 1}, {4, 2}, {4, 3}}
POSTED BY: Tim Mayes

@Tim Mayes, thank you but what I'm looking for is not just finding all possible pairs but find all possible partitions of the list into pairs, as in the example I gave
POSTED BY: Stefano De Nicola

Use Subsets

In[38]:= Subsets[{x1, x2, x3, x4}, {2}]
Out[38]= {{x1, x2}, {x1, x3}, {x1, x4}, {x2, x3}, {x2, x4}, {x3, x4}}

the manual on the internet is your best friend.
POSTED BY: Udo Krause

Perhaps I haven't formulated the problem clearly... What I'm looking for is all the possible partitions of the initial list in pairs of elements, i.e. a list of such partitions, as given in my example, rather than just the subsets. e.g. the partitions of {x1,x2,x3,x4} are {{x1,x2},{x3,x4}}, {{x1,x3},{x2,x4}} and {{x1,x4},{x2,x3}} (the order does not matter), so the output I want is: {{{x1,x2},{x3,x4}}, {{x1,x3},{x2,x4}}, {{x1,x4},{x2,x3}}}.
POSTED BY: Stefano De Nicola

Excuse me, over-read that; anyway, then you double it

In[43]:= Select[Subsets[Subsets[{x1, x2, x3, x4}, {2}], {2}], Sort[Flatten[#]] == {x1, x2, x3, x4} &]
Out[43]= {{{x1, x2}, {x3, x4}}, {{x1, x3}, {x2, x4}}, {{x1, x4}, {x2, x3}}}

it's not efficient because the nested Subset call generates far more expressions than needed: Select has to trim that back

In[42]:= Select[
 Subsets[Subsets[{x1, x2, x3, x4, x5, x6, x7, x8}, {2}], {4}], 
 Sort[Flatten[#]] == {x1, x2, x3, x4, x5, x6, x7, x8} &]

Out[42]= {{{x1, x2}, {x3, x4}, {x5, x6}, {x7, x8}}, {{x1, x2}, {x3, x4}, {x5, x7}, {x6, x8}}, {{x1, x2}, {x3, x4}, {x5, x8}, {x6, x7}}, 
{{x1, x2}, {x3, x5}, {x4, x6}, {x7, x8}}, {{x1, x2}, {x3, x5}, {x4, x7}, {x6, x8}}, {{x1, x2}, {x3, x5}, {x4, x8}, {x6, x7}}, 
{{x1, x2}, {x3, x6}, {x4, x5}, {x7, x8}}, {{x1, x2}, {x3,  x6}, {x4, x7}, {x5, x8}}, {{x1, x2}, {x3, x6}, {x4, x8}, {x5,  x7}}, 
{{x1, x2}, {x3, x7}, {x4, x5}, {x6, x8}}, {{x1, x2}, {x3,  x7}, {x4, x6}, {x5, x8}}, {{x1, x2}, {x3, x7}, {x4, x8}, {x5,  x6}}, 
{{x1, x2}, {x3, x8}, {x4, x5}, {x6, x7}}, {{x1, x2}, {x3,  x8}, {x4, x6}, {x5, x7}}, {{x1, x2}, {x3, x8}, {x4, x7}, {x5,  x6}}, 
{{x1, x3}, {x2, x4}, {x5, x6}, {x7, x8}}, {{x1, x3}, {x2, x4}, {x5, x7}, {x6, x8}}, {{x1, x3}, {x2, x4}, {x5, x8}, {x6,  x7}}, 
{{x1, x3}, {x2, x5}, {x4, x6}, {x7, x8}}, {{x1, x3}, {x2,  x5}, {x4, x7}, {x6, x8}}, {{x1, x3}, {x2, x5}, {x4, x8}, {x6,  x7}}, 
{{x1, x3}, {x2, x6}, {x4, x5}, {x7, x8}}, {{x1, x3}, {x2, x6}, {x4, x7}, {x5, x8}}, {{x1, x3}, {x2, x6}, {x4, x8}, {x5,  x7}}, 
{{x1, x3}, {x2, x7}, {x4, x5}, {x6, x8}}, {{x1, x3}, {x2, x7}, {x4, x6}, {x5, x8}}, {{x1, x3}, {x2, x7}, {x4, x8}, {x5, x6}},
 {{x1, x3}, {x2, x8}, {x4, x5}, {x6, x7}}, {{x1, x3}, {x2, x8}, {x4, x6}, {x5, x7}}, {{x1, x3}, {x2, x8}, {x4, x7}, {x5, x6}}, 
{{x1, x4}, {x2, x3}, {x5, x6}, {x7, x8}}, {{x1, x4}, {x2, x3}, {x5, x7}, {x6, x8}}, {{x1, x4}, {x2, x3}, {x5, x8}, {x6, x7}}, 
{{x1, x4}, {x2, x5}, {x3, x6}, {x7, x8}}, {{x1, x4}, {x2, x5}, {x3, x7}, {x6, x8}}, {{x1, x4}, {x2, x5}, {x3, x8}, {x6, x7}}, 
{{x1, x4}, {x2, x6}, {x3, x5}, {x7, x8}}, {{x1, x4}, {x2, x6}, {x3, x7}, {x5, x8}}, {{x1, x4}, {x2, x6}, {x3, x8}, {x5, x7}}, 
{{x1, x4}, {x2, x7}, {x3, x5}, {x6, x8}}, {{x1, x4}, {x2, x7}, {x3, x6}, {x5, x8}}, {{x1, x4}, {x2, x7}, {x3, x8}, {x5, x6}}, 
{{x1, x4}, {x2, x8}, {x3, x5}, {x6, x7}}, {{x1, x4}, {x2, x8}, {x3, x6}, {x5, x7}}, {{x1, x4}, {x2, x8}, {x3, x7}, {x5,  x6}}, 
{{x1, x5}, {x2, x3}, {x4, x6}, {x7, x8}}, {{x1, x5}, {x2, x3}, {x4, x7}, {x6, x8}}, {{x1, x5}, {x2, x3}, {x4, x8}, {x6,  x7}}, 
{{x1, x5}, {x2, x4}, {x3, x6}, {x7, x8}}, {{x1, x5}, {x2, x4}, {x3, x7}, {x6, x8}}, {{x1, x5}, {x2, x4}, {x3, x8}, {x6, x7}}, 
{{x1, x5}, {x2, x6}, {x3, x4}, {x7, x8}}, {{x1, x5}, {x2, x6}, {x3, x7}, {x4, x8}}, {{x1, x5}, {x2, x6}, {x3, x8}, {x4, x7}}, 
{{x1, x5}, {x2, x7}, {x3, x4}, {x6, x8}}, {{x1, x5}, {x2,  x7}, {x3, x6}, {x4, x8}}, {{x1, x5}, {x2, x7}, {x3, x8}, {x4, x6}}, 
{{x1, x5}, {x2, x8}, {x3, x4}, {x6, x7}}, {{x1, x5}, {x2, x8}, {x3, x6}, {x4, x7}}, {{x1, x5}, {x2, x8}, {x3, x7}, {x4, x6}}, 
{{x1, x6}, {x2, x3}, {x4, x5}, {x7, x8}}, {{x1, x6}, {x2, x3}, {x4, x7}, {x5, x8}}, {{x1, x6}, {x2, x3}, {x4, x8}, {x5, x7}}, 
{{x1, x6}, {x2, x4}, {x3, x5}, {x7, x8}}, {{x1, x6}, {x2, x4}, {x3, x7}, {x5, x8}}, {{x1, x6}, {x2, x4}, {x3, x8}, {x5, x7}}, 
{{x1, x6}, {x2, x5}, {x3, x4}, {x7, x8}}, {{x1, x6}, {x2, x5}, {x3, x7}, {x4, x8}}, {{x1, x6}, {x2, x5}, {x3, x8}, {x4, x7}}, 
{{x1, x6}, {x2, x7}, {x3, x4}, {x5, x8}}, {{x1, x6}, {x2, x7}, {x3, x5}, {x4, x8}}, {{x1, x6}, {x2, x7}, {x3, x8}, {x4, x5}}, 
{{x1, x6}, {x2, x8}, {x3, x4}, {x5, x7}}, {{x1, x6}, {x2, x8}, {x3, x5}, {x4, x7}}, {{x1, x6}, {x2, x8}, {x3, x7}, {x4, x5}}, 
{{x1, x7}, {x2, x3}, {x4, x5}, {x6, x8}}, {{x1, x7}, {x2, x3}, {x4, x6}, {x5, x8}}, {{x1, x7}, {x2, x3}, {x4, x8}, {x5, x6}}, 
{{x1, x7}, {x2, x4}, {x3, x5}, {x6, x8}}, {{x1, x7}, {x2, x4}, {x3, x6}, {x5, x8}}, {{x1, x7}, {x2, x4}, {x3, x8}, {x5, x6}}, 
{{x1, x7}, {x2, x5}, {x3, x4}, {x6, x8}}, {{x1, x7}, {x2, x5}, {x3, x6}, {x4, x8}}, {{x1, x7}, {x2, x5}, {x3, x8}, {x4, x6}}, 
{{x1, x7}, {x2, x6}, {x3, x4}, {x5, x8}}, {{x1, x7}, {x2, x6}, {x3, x5}, {x4, x8}}, {{x1, x7}, {x2, x6}, {x3, x8}, {x4, x5}}, 
{{x1, x7}, {x2, x8}, {x3, x4}, {x5, x6}}, {{x1, x7}, {x2, x8}, {x3, x5}, {x4, x6}}, {{x1, x7}, {x2, x8}, {x3, x6}, {x4, x5}}, 
{{x1, x8}, {x2, x3}, {x4, x5}, {x6, x7}}, {{x1, x8}, {x2, x3}, {x4, x6}, {x5, x7}}, {{x1, x8}, {x2, x3}, {x4, x7}, {x5, x6}}, 
{{x1, x8}, {x2, x4}, {x3, x5}, {x6, x7}}, {{x1, x8}, {x2, x4}, {x3, x6}, {x5, x7}}, {{x1, x8}, {x2, x4}, {x3, x7}, {x5, x6}}, 
{{x1, x8}, {x2, x5}, {x3, x4}, {x6, x7}}, {{x1, x8}, {x2, x5}, {x3, x6}, {x4, x7}}, {{x1, x8}, {x2, x5}, {x3, x7}, {x4, x6}}, 
{{x1, x8}, {x2, x6}, {x3, x4}, {x5, x7}}, {{x1, x8}, {x2, x6}, {x3, x5}, {x4, x7}}, {{x1, x8}, {x2, x6}, {x3, x7}, {x4, x5}}, 
{{x1, x8}, {x2, x7}, {x3, x4}, {x5, x6}}, {{x1, x8}, {x2, x7}, {x3, x5}, {x4, x6}}, {{x1, x8}, {x2, x7}, {x3, x6}, {x4, x5}}}
POSTED BY: Udo Krause

This doesn't quite do what I mean: for example, I changed it for a case with 6 variables (one is repeated, which is the case in my actual problem): {x1, x1, x3, x4, x5, x6}

Select[Subsets[Subsets[{x1, x1, x3, x4, x5, x6}, {2}], {3}], 
 Sort[Flatten[#]] == {x1, x1, x3, x4, x5, x6} &]

The output has 27 elements, while it should have 15 (5x3).
POSTED BY: Stefano De Nicola

Of course

In[51]:= Select[Subsets[Subsets[{x1, x2, x3, x4, x5, x6}, {2}], {3}], Sort[Flatten[#]] == {x1, x2, x3, x4, x5, x6} &] // Length
Out[51]= 15

now

DeleteDuplicates[Select[Subsets[Subsets[{x1, x1, x3, x4, x5, x6}, {2}], {3}], Sort[Flatten[#]] == {x1, x1, x3, x4, x5, x6} &]]

or

Select[Subsets[Subsets[{x1, x2, x3, x4, x5, x6}, {2}], {3}], Sort[Flatten[#]] == {x1, x2, x3, x4, x5, x6} &] /. x2 -> x1

with

In[74]:= stef1 = {x1, x1, x3, x4, x5, x6};
         stef2 = {x1, x2, x3, x4, x5, x6};
 Sort[DeleteDuplicates[Select[Subsets[Subsets[stef1, {2}], {3}], Sort[Flatten[#]] == stef1 &]]] == 
 Sort[Select[Subsets[Subsets[stef2, {2}], {3}], Sort[Flatten[#]] == stef2 &] /. x2 -> x1]

Out[76]= True
POSTED BY: Udo Krause

I tested the first option you give with

{x1, x1, x3, x4, x5, x6, x6, x6}

and the output gives 25 terms, whilst there should be 105. The other solution, involving the replacement x2->x1 at the end, should work but it's rather cumbersome for the applications I have in mind, where the number and entity of repeated terms varies.
POSTED BY: Stefano De Nicola

In a different forum I was suggested this solution, which seems to work:

<< Combinatorica`
list = {a, a, c, d};
idx[n_] := Select[SetPartitions[n], Union[Length /@ #] == {2} &];
confs[set_] := Map[set [[#]] &, idx[Length@set], {2}]
confs@list
(* {{{a, a}, {c, d}}, {{a, d}, {a, c}}, {{a, c}, {a, d}}} *)

I copy it here together with the source (http://mathematica.stackexchange.com/questions/88085/find-all-the-possible-ways-of-partitioning-a-list-into-a-set-of-pairs-of-element) for future reference.
POSTED BY: Stefano De Nicola

The other solution, involving the replacement x2->x1 at the end, should work but it's rather cumbersome for the applications I have in mind, where the number and entity of repeated terms varies.

That's easy to handle

In[12]:= Clear[deNicolaPairs]
deNicolaPairs[l_List?VectorQ] := Block[{l0 = Array[f, Length[l]]},
   Select[Subsets[Subsets[l0, {2}], {Length[l]/2}], Sort[Flatten[#]] == l0 &] /. (Rule @@@ Transpose[{l0, l}])
   ] /; EvenQ[Length[l]] && DisjointQ[l, Array[f, Length[l]]]

In[14]:= deNicolaPairs[{x1, x2, x3, x4}]
Out[14]= {{{x1, x2}, {x3, x4}}, {{x1, x3}, {x2, x4}}, {{x1, x4}, {x2, x3}}}

In[15]:= deNicolaPairs[{x1, x1, x1, x1}]
Out[15]= {{{x1, x1}, {x1, x1}}, {{x1, x1}, {x1, x1}}, {{x1, x1}, {x1, x1}}}

but the performance problem is fatal: deNicolaPairs crashes with 8 GB RAM on a list of length 12.

The proposal in the mentioned forum using ArrayReshape fixed that by generating first an index (it depends on the length of the input only) and then distributing the input accordingly.
POSTED BY: Udo Krause
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract