Fastest way to generate {{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}} from {a,b,c}

Question

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

l // ({#, #} & /* Tuples /* DeleteDuplicatesBy[Intersection]) should work. — Shredderroy, May 24 '22 at 14:40
This is about 2.5 times as slow as my original attempt with Flatten. — Thrash, May 24 '22 at 15:11
ResourceFunction["SelectTuples"][l, 2, OrderedQ] slow but elegant. — AsukaMinato, May 24 '22 at 20:38
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. ;) — thorimur, May 25 '22 at 07:52
Just wondering: what does speed have to do with such a trivial and blindingly fast calculation? Why would anyone care? — David G. Stork, May 25 '22 at 18:38
It's a minimal example with three elements. Actually, I do such calculations/generations with about 10^5 elements. — Thrash, May 26 '22 at 21:19

score 21 · Answer 1 · answered May 24 '22 at 14:52

21

Select[Tuples[{a,b,c},2],OrderedQ]

answered May 24 '22 at 14:52

lericr

27,668
1
18
64

This is about twice as fast as my original attempt with Flatten, wonderful! – Thrash May 24 '22 at 15:14

score 16 · Accepted Answer · answered May 26 '22 at 01:41

16

GroupTheory`Tools`Multisets[{a, b, c}, 2]

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

answered May 26 '22 at 01:41

yode

26,686
4
62
167

2

So far the fastest method for my purposes and also very elegant! – Thrash May 26 '22 at 22:08

score 12 · Answer 3 · answered May 24 '22 at 17:27

12

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}}

answered May 24 '22 at 17:27

Carl Woll

130,679
6
243
355

score 10 · Answer 4 · answered May 24 '22 at 21:34

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}}

cvgmt · Answer 5 · 2022-05-24T15:35:23.630

9

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

edited May 24 '22 at 15:35

answered May 24 '22 at 14:59

cvgmt

72,231
4
75
133

This is about 26 times as slow as my original attempt with Flatten. – Thrash May 24 '22 at 15:17
@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 – cvgmt May 24 '22 at 15:23
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! – Thrash May 24 '22 at 15:46

user1066 · Answer 6 · 2022-05-26T23:31:08.567

(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]

Tuples/Distribute

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

`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]

score 8 · Answer 7 · answered May 24 '22 at 17:32

8

Using Cases:

Cases[Tuples[{a, b, c}, 2], _?OrderedQ] // AbsoluteTiming
(*{0.0000291, {{a, a}, {a, b}, {a, c}, {b, b}, {b, c}, {c, c}}}*)

answered May 24 '22 at 17:32

E. Chan-López

23,117
3
21
44

AsukaMinato · Answer 8 · 2022-05-24T20:34:28.847

8

Outer[List, {a,b,c},{a,b,c}] //
Flatten[#,1]& //
Select[OrderedQ]

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

edited May 24 '22 at 20:34

answered May 24 '22 at 20:28

AsukaMinato

9,758
1
14
40

score 8 · Answer 9 · answered May 25 '22 at 15:28

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}}

score 7 · Answer 10 · answered May 25 '22 at 07:04

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!).

score 3 · Answer 11 · answered May 27 '22 at 10:17

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}} *)

Fastest way to generate {{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}} from {a,b,c}

11 Answers11

Just for fun

Subsets and Transpose

Tuples/Distribute

`Subsets[list]` and `Subsets[Reverse@list]`

Linked

Fastest way to generate {{a,a},{a,b},{a,c},{b,b},{b,c},{c,c}} from {a,b,c}

11 Answers11

Just for fun

Subsets and Transpose

Tuples/Distribute

Subsets[list] and Subsets[Reverse@list]

Linked

`Subsets[list]` and `Subsets[Reverse@list]`