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)?

Improve this question
$\endgroup$
7
  • $\begingroup$ l // ({#, #} & /* Tuples /* DeleteDuplicatesBy[Intersection]) should work. $\endgroup$
    – Shredderroy
    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$
    – David G. Stork
    Commented May 25, 2022 at 18:38
  • 2
    $\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

Reset to default
18
$\begingroup$ 
GroupTheory`Tools`Multisets[{a, b, c}, 2]

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

Improve this answer
$\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]
Improve this answer
$\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}}

Improve this answer
$\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
Improve this answer
$\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}}}*)
Improve this answer
$\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}}

Improve this answer
$\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}}
Improve this answer
$\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

Improve this answer
$\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!).

Improve this answer
$\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}}

Improve this answer
$\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}} *)
Improve this answer
$\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}}

Improve this answer
$\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.