15
$\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$ May 24 at 14:40
  • $\begingroup$ This is about 2.5 times as slow as my original attempt with Flatten. $\endgroup$
    – Thrash
    May 24 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
    May 25 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$ May 25 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
    May 26 at 21:19

11 Answers 11

14
$\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
    May 26 at 22:08
21
$\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
    May 24 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$

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$
9
$\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
    May 24 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
    May 24 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
    May 24 at 15:46
8
$\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$
8
$\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$
8
$\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$
7
$\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$
6
$\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$
2
$\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$

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.