17
$\begingroup$

What is the fastest way to generate {{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}} from l={a,b,c}? I've tried

Flatten[Table[{l[[i]],l[[j]]},{i,Length@l},{j,i,Length@l}],1]

but is there a faster and perhaps more elegant way (maybe with Tuples)?

$\endgroup$
7
  • $\begingroup$ l // ({#, #} & /* Tuples /* DeleteDuplicatesBy[Intersection]) should work. $\endgroup$ Commented May 24, 2022 at 14:40
  • $\begingroup$ This is about 2.5 times as slow as my original attempt with Flatten. $\endgroup$
    – Thrash
    Commented May 24, 2022 at 15:11
  • 2
    $\begingroup$ there is the "hey, that's not what I meant!" way: {{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}}&[l]. seems blazingly fast. ;) $\endgroup$
    – thorimur
    Commented May 25, 2022 at 7:52
  • 1
    $\begingroup$ Just wondering: what does speed have to do with such a trivial and blindingly fast calculation? Why would anyone care? $\endgroup$ Commented May 25, 2022 at 18:38
  • 1
    $\begingroup$ It's a minimal example with three elements. Actually, I do such calculations/generations with about 10^5 elements. $\endgroup$
    – Thrash
    Commented May 26, 2022 at 21:19

12 Answers 12

17
$\begingroup$
GroupTheory`Tools`Multisets[{a, b, c}, 2]

{{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}}

$\endgroup$
1
  • 2
    $\begingroup$ So far the fastest method for my purposes and also very elegant! $\endgroup$
    – Thrash
    Commented May 26, 2022 at 22:08
22
$\begingroup$
Select[Tuples[{a,b,c},2],OrderedQ]
$\endgroup$
1
  • $\begingroup$ This is about twice as fast as my original attempt with Flatten, wonderful! $\endgroup$
    – Thrash
    Commented May 24, 2022 at 15:14
12
$\begingroup$

Another possibility is to use Pick:

Pick[
    Tuples[{a,b,c}, 2],
    Flatten @ UpperTriangularize @ ConstantArray[1, {3, 3}],
    1
]

{{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}

$\endgroup$
10
$\begingroup$

https://mathematica.stackexchange.com/a/235768/72111

m = 3;
n = 2;
list = Subsets[Range[2, m + n], {n}];
result = Subtract[#, Range[n]] & /@ list
Alphabet[][[1 ;; m]][[#]] & /@ result
  • Test the timming.
(m = 26;
  n = 6;
  list = Subsets[Range[2, m + n], {n}];
  result = Subtract[#, Range[n]] & /@ list;
  Alphabet[][[1 ;; m]][[#]] & /@ result) // AbsoluteTiming
  • compare with
Select[Tuples[Alphabet[], 6], OrderedQ] // AbsoluteTiming
$\endgroup$
3
  • $\begingroup$ This is about 26 times as slow as my original attempt with Flatten. $\endgroup$
    – Thrash
    Commented May 24, 2022 at 15:17
  • $\begingroup$ @Thrash Please compare with Select[Tuples[Range[26], 5], OrderedQ] // AbsoluteTiming and (m = 26; n = 5; list = Subsets[Range[2, m + n], {n}]; result = Subtract[#, Range[n]] & /@ list) // AbsoluteTiming $\endgroup$
    – cvgmt
    Commented May 24, 2022 at 15:23
  • $\begingroup$ I think your code is very fast for large n, but for my current purposes I need only the case n=2. Compare Select[Tuples[Alphabet[], 2], OrderedQ]; // RepeatedTiming with (m = 26; n = 2; list = Subsets[Range[2, m + n], {n}]; result = Subtract[#, Range[n]] & /@ list; Alphabet[][[1 ;; m]][[#]] & /@ result;) // RepeatedTiming. On my computer about 67 times as slow as the Select method. Thanks anyway, it could be useful one day! $\endgroup$
    – Thrash
    Commented May 24, 2022 at 15:46
10
$\begingroup$

Using Cases:

Cases[Tuples[{a, b, c}, 2], _?OrderedQ] // AbsoluteTiming
(*{0.0000291, {{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}}*)
$\endgroup$
10
$\begingroup$
Outer[List, {a,b,c},{a,b,c}] //
Flatten[#,1]& //
Select[OrderedQ]

{{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}

$\endgroup$
10
$\begingroup$

Using an inverse pairing function:

SetAttributes[toPair, Listable];
toPair[r_Integer?Positive] := With[{c = Quotient[NumberTheory`IntegerSqrt[8 r] + 1, 2]},
                                    {Quotient[c (3 - c), 2] + r - c, c}]

we can do the following:

list = {a, b, c};
list[[#]] & /@ SortBy[toPair[Range[Binomial[Length[list] + 1, 2]]], First]
   {{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}
$\endgroup$
10
$\begingroup$

(a) Subsets and Transpose

{Subsets[#,{2}],Transpose[{#,#}]}&@{a,b,c}//Catenate//Sort

(* {{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}} *) 

{Subsets[#,{2}],Transpose[{#,#}]}&@{a,b,c,d}//Catenate//Sort

(* {{a, a}, {a, b}, {a, c}, {a, d}, {b, b}, {b, c}, {b, d}, {c, c}, {c, d}, {d, d}} *) 

(b) Complement, Tuples and Subsets

Complement[Tuples[{a,b,c},2],Subsets[Reverse@{a,b,c},{2}]]

(* {{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}} *)

Complement[Tuples[{a,b,c,d},2],Subsets[Reverse@{a,b,c,d},{2}]]

(* {{a, a}, {a, b}, {a, c}, {a, d}, {b, b}, {b, c}, {b, d}, {c, c}, {c, d}, {d, d}} *)

// Complement conveniently sorts

(c) Distribute

Distribute[{l,l}, List,List, Select[{##},OrderedQ]&]

(* {{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}} *) 

Just for fun

Subsets and Transpose

subsets=Thread[Subsets[Range[20],{2}] -> 1];
transpose=Thread[Transpose[{Range[20],Range[20]}] -> 2];

ArrayPlot[SparseArray@Join[subsets,transpose], 
  Mesh-> True,
  ColorRules -> {1 -> Purple, 2 -> Green},
  ImageSize->200]

Array Plot of Tuples and Transpose

Tuples/Distribute

ArrayPlot[SparseArray@Thread[Tuples[Range[20],{2}]->1], 
  Mesh->True, 
  ColorRules -> {1 -> Blue},
  ImageSize->200]

ArrayPlot of Tuples

Subsets[list] and Subsets[Reverse@list]

subsets=Thread[Subsets[Range[20],{2}] -> 1];
subsetsReversed=Thread[Subsets[Reverse@Range[20],{2}] -> 2];

ArrayPlot[SparseArray@Join[subsets,subsetsReversed], Mesh-> True,ColorRules -> {1 -> Purple, 2 -> Violet },ImageSize->200]

Subsets and reversed subset plots

$\endgroup$
8
$\begingroup$
n = 2000;
alphabet = Range[n];(*or whatever you like*)
result = Transpose[{
   Join @@ MapIndexed[ConstantArray[#1, n + 1 - #2] &, alphabet],
   Join @@ Map[alphabet[[# ;;]] &, Range[n]]
   }];

Seems to be about twice as fast as Carl Woll's Pick method (which I really like!).

$\endgroup$
8
$\begingroup$

If the performance is important, try this

ClearAll[combinationsWithReplacement];

combinationsWithReplacement[A_?VectorQ, k_Integer] :=
  With[{m = Length@A + k - 1},
   Partition[Part[A, Flatten@(Developer`ToPackedArray@Subsets[Range@m, {k}] +
        ConstantArray[-Range[0, k - 1], Binomial[m, k]])], k]
   ];

combinationsWithReplacement[{a, b, c}, 2]
combinationsWithReplacement[Range[26], 7] // Dimensions // AbsoluteTiming

{{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}
{0.833452, {3365856, 7}}

$\endgroup$
3
$\begingroup$

A rip off from python's itertools:

ClearAll[combinations$with$replacement] ;
combinations$with$replacement[sequence_, r_] := Block[
    {n, indices, result, range, flag, i, j},
    n = Length[sequence] ;
    indices = ConstantArray[1, r] ;
    result = {sequence[[indices]]} ;
    range = Reverse[Range[r]] ;
    While[
        True,
        Do[
            j = i ;
            flag = True ;
            If[
                indices[[i]] != n,
                flag = False ;
                Break[] ;
            ],
            {i, range}
        ] ;
        If[flag, Return[result]] ;
        indices[[j;;]] = ConstantArray[indices[[j]] + 1, r - j + 1] ;
        result = Join[result, {sequence[[indices]]}]
    ] ;
] ;
combinations$with$replacement[{a, b, c}, 2]
(* {{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}} *)
$\endgroup$
3
$\begingroup$
x = {a, b, c};

Union @ Map[Sort] @ Apply[Join] @ Outer[List, x, x]

{{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}

$\endgroup$

Your Answer

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

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