7
$\begingroup$

Given a list with an even number of elements, e.g.

list = RandomSample[Array[e, 20]];

how can one generate a list of all different commutative pairings of the elements most efficiently in Mathematica?

A tiny example is:

list = {e[1],e[4],e[3],e[2]};
pairings[list]

{

{ {e[1],e[2]} , {e[3],e[4]} } ,

{ {e[1],e[3]} , {e[2],e[4]} } ,

{ {e[1],e[4]} , {e[2],e[3]} } ,

}

Note how the commutativity of the pairings sets e.g. {e[1],e[2]} and {e[2],e[1]} to be the same pair, so that only one such term is generated.

EDIT:

Alternatively, one can ask this question in terms of graphs:

How to generate all distinct sets of disconnected un-directed edges from a list of vertices most efficiently?

$\endgroup$
  • 1
    $\begingroup$ Subsets[list, {2}] ? $\endgroup$ – Christopher Lamb Jun 3 at 21:10
  • $\begingroup$ @ChristopherLamb This creates a list of all possible pairs. But starting with a list of 2n elements, we are looking for a list of groups of n pairs instead. $\endgroup$ – Kagaratsch Jun 3 at 21:12
  • 2
    $\begingroup$ @Kagaratsch partition[l_, v_, comp_] := Flatten /@ Reap [ Scan [ Which[ comp[ v, #], Sow[#, -1], comp[v, #], Sow[#, 1], True, Sow[#,0]]&,l], {-1,0,1}][[2]] (* Three way partition function using and ordering function by sowing values with tags -1,0, or 1, depending on a relation. You could build up a list by specifying tags with Sow and patterns that match those tags in Reap. If you build the list piece by piece with recursion I would not recommend using Append instead an approach using Reap and Sow could be more effective to collect intermediate results*) $\endgroup$ – Schopenhauer Jun 4 at 1:55
  • 1
    $\begingroup$ @Kagaratsch I’ve seen programs that use Fold as alternative to recursion. g[{}] = x; g[l_] = f[First[l], g[Rest[l]]; could be translated to g[l_]= Fold[f[#1,#2]&, x,l]. $\endgroup$ – Schopenhauer Jun 4 at 2:08
  • 2
    $\begingroup$ @Kagaratsch I would also check the ??Developer`* and ??Experimental`* contexts for hidden gems like PartitionMap. $\endgroup$ – Schopenhauer Jun 4 at 2:14
4
$\begingroup$

I think the number of such pairings is given by:

pairCounts[n_?EvenQ] := Multinomial @@ ConstantArray[2, n/2]/(n/2)!

So, you will get:

pairCounts[20]

654729075

which is a lot of pairings for a list of length 20. What do you plan to do with this list?

At any rate, here is a not very efficient method:

partitions[{a_,b_}] := {{{a,b}}}
partitions[{a_,b__}] := Catenate@Table[
    Prepend[{a, {b}[[i]]}] /@ partitions[Delete[{b}, i]],
    {i, Length[{b}]}
]

For example:

partitions[Range[4]]
partitions[Range[6]]

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

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

$\endgroup$
  • $\begingroup$ Thanks, this one is quicker than the one I could write! I plan to collapse some of the vertices to obtain connected graphs and determine their multiplicity. $\endgroup$ – Kagaratsch Jun 3 at 22:16
  • $\begingroup$ By the way pairCounts[n_?EvenQ] := (n-1)!! $\endgroup$ – Kagaratsch Jun 3 at 23:10
3
$\begingroup$
ClearAll[perfectMatchings]
perfectMatchings = Module[{subs = Subsets[#, {2}], l = Length @ #, matchings},
    matchings = FindIndependentVertexSet[LineGraph[UndirectedEdge @@@ subs], l/2, All];
    Extract[subs, List /@ matchings] ] &;

perfectMatchings[Range @ 4] // Grid // TeXForm

$\small\begin{array}{cc} \{1,4\} & \{2,3\} \\ \{1,3\} & \{2,4\} \\ \{1,2\} & \{3,4\} \\ \end{array}$

perfectMatchings[Range @ 6] // Grid // TeXForm

$\small\begin{array}{ccc} \{1,6\} & \{2,5\} & \{3,4\} \\ \{1,6\} & \{2,4\} & \{3,5\} \\ \{1,6\} & \{2,3\} & \{4,5\} \\ \{1,5\} & \{2,6\} & \{3,4\} \\ \{1,5\} & \{2,4\} & \{3,6\} \\ \{1,5\} & \{2,3\} & \{4,6\} \\ \{1,4\} & \{2,6\} & \{3,5\} \\ \{1,4\} & \{2,5\} & \{3,6\} \\ \{1,4\} & \{2,3\} & \{5,6\} \\ \{1,3\} & \{2,6\} & \{4,5\} \\ \{1,3\} & \{2,5\} & \{4,6\} \\ \{1,3\} & \{2,4\} & \{5,6\} \\ \{1,2\} & \{3,6\} & \{4,5\} \\ \{1,2\} & \{3,5\} & \{4,6\} \\ \{1,2\} & \{3,4\} & \{5,6\} \\ \end{array}$

Note: This is much slower than Carl's partitions and Kagaratsch's pairings.

$\endgroup$
2
$\begingroup$

Here a recursive solution, which I suspect is similar to the one by Carl Woll:

pairings[list_, progress_] := Block[{},
  If[Length[list] > 1,
   Flatten[
    Table[
     pairings[Drop[list[[2 ;;]], {i - 1}], 
      Append[progress, {list[[1]], list[[i]]}]]
     , {i, 2, Length[list]}]
    , 1]
   ,
   p[progress]
   ]
  ]

With outputs

pairings[Range[4], {}]

{p[{{1, 2}, {3, 4}}], p[{{1, 3}, {2, 4}}], p[{{1, 4}, {2, 3}}]}

and

pairings[Range[6], {}]

{p[{{1, 2}, {3, 4}, {5, 6}}], p[{{1, 2}, {3, 5}, {4, 6}}],

p[{{1, 2}, {3, 6}, {4, 5}}], p[{{1, 3}, {2, 4}, {5, 6}}],

p[{{1, 3}, {2, 5}, {4, 6}}], p[{{1, 3}, {2, 6}, {4, 5}}],

p[{{1, 4}, {2, 3}, {5, 6}}], p[{{1, 4}, {2, 5}, {3, 6}}],

p[{{1, 4}, {2, 6}, {3, 5}}], p[{{1, 5}, {2, 3}, {4, 6}}],

p[{{1, 5}, {2, 4}, {3, 6}}], p[{{1, 5}, {2, 6}, {3, 4}}],

p[{{1, 6}, {2, 3}, {4, 5}}], p[{{1, 6}, {2, 4}, {3, 5}}],

p[{{1, 6}, {2, 5}, {3, 4}}]}

Turns out, this one is a bit slower than partitions by Carl Woll:

pairings[Range[14], {}] // Length // AbsoluteTiming

{1.91637, 135135}

partitions[Range[14]] // Length // AbsoluteTiming

{1.1277, 135135}

$\endgroup$
2
$\begingroup$

This question kind of looks similar to 167488 IMO.

The answer here uses the same idea of the answer.

commPairs[list_] := Module[{perms},
   perms = 
    Table[(ConstantArray[Unique[], {2}]), Length[list]/2] // Flatten //
      Permutations;
   Keys@GatherBy[#, Last] & /@ (Thread[list -> #] & /@ perms) // 
    DeleteDuplicates
   ];

Test:

commPairs[Range@4]

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

commPairs[Range@6]

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

$\endgroup$
  • $\begingroup$ Unfortunately, generating all n! permutations in the intermediate terms instead of just the (n-1)!! needed ones makes this kind of slow. $\endgroup$ – Kagaratsch Jun 6 at 18:58
0
$\begingroup$

How is it that the comment by @ChristopherLamb is incorrect? Sets are order independent, so I would think this creates "commutative pairs."

set = Table[e[n], {n, 4}]

(* {e[1],e[2],e[3],e[4]} *)

Subsets[set, {2}]

(* {{e[1],e[2]},{e[1],e[3]},{e[1],e[4]},{e[2],e[3]},{e[2],e[4]},{e[3],e[4]}} *)
$\endgroup$
  • $\begingroup$ This output is missing a dimension in the list, which would partition this set of pairs into groups of pairs in which all elements show up exactly once. Also note that some edges will exist more than once within these groups when list dimension is larger than 4. $\endgroup$ – Kagaratsch Jun 3 at 21:39

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.