Is there a function to generate “subsets” allowing duplicates?

Question

1. I allow them to be chosen more than once (e.g. allow {1,1}).

   (A subset means every element is chosen once or less)

2. Also I neglect the order (e.g. {1,2} is the same as {2,1}).

   (In other word, I need either {1,2} or {2,1}, not both.)

---

Let's say the set s = {a, b}. (whose Length is $n$)

• Subsets gives {{}, {a}, {b}, {a, b}}. (length: $2^n$)

• Tuples[s, n] gives {{a, a}, {a, b}, {b, a}, {b, b}}. (length: $n^n$)

• Permutations gives {{a, b}, {b, a}}. (length: $n!$)

• What I want is {{}, {a}, {b}, {a,a}, {a,b}, {b,b}}.

  There's no {b,a}. (Besides, it's OK to generate {b,a} instead of {a,b})

  (length: I can't work out the exact formula now, but I guess it's between $2^n$ and $n^n$)

---

I didn't find anything identical, but I know that I can make Tuples from $0$ to $n$, then DeleteDuplicatesBy[Sort]. However it's kind of silly, as most of the tuples will be deleted.

Full code: Table[Tuples[s, i], {i, 0, n}] // Flatten[#, 1] & // DeleteDuplicatesBy[Sort]

Is there a neat way to do that?

Answer 1

You want an increasing sequence. https://mathematica.stackexchange.com/a/235768/72111

That is, for $$1\leq a_1 \leq a_2\leq \cdots \leq a_{n}\leq m$$

We set $$b_k=a_k+k$$ then $$2\leq b_1< b_2<\cdots<b_n\leq m+n$$ It means that $(b_1,b_2,\cdots,b_n)$ is the $n$ subsets of Range[2,m+n]

m = 5;
n = 3;
list = Subsets[Range[2, m + n], {n}]
result = Subtract[#, Range[n]] & /@ list
{a,b,c,d,e}[[#]] & /@ result

{{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, a, e}, {a, b, b}, {a, b, c}, {a, b, d}, {a, b, e}, {a, c, c}, {a, c, d}, {a, c, e}, {a, d, d}, {a, d, e}, {a, e, e}, {b, b, b}, {b, b, c}, {b, b, d}, {b, b, e}, {b, c, c}, {b, c, d}, {b, c, e}, {b, d, d}, {b, d, e}, {b, e, e}, {c, c, c}, {c, c, d}, {c, c, e}, {c, d, d}, {c, d, e}, {c, e, e}, {d, d, d}, {d, d, e}, {d, e, e}, {e, e, e}}

Answer 2

I will use the answer by @cvgmt to get a handle on the number of elements in the list of "subsets".

Setting m == n and ignoring the alphabetical symbols, here are the lengths for the $n = 0, \ldots, 12$:

Length /@
  Table[
    Table[
      Subtract[#, Range[i]] & /@ Subsets[Range[2, 2 i], {i}],
      {i, 0, n}
    ] // Flatten[#, 1] &,
    {n, 0, 12}
  ]
(* {1, 2, 5, 15, 50, 176, 638, 2354, 8789, 33099, 125477, 478193, 1830271} *)

This sequence is identified as A024718 by Sequence Machine at sequencedb.net. The associated formula for the $n$-th term is

(1/2)*(1 + Sum[Binomial[2*k, k], {k, 0, n}])
(* 1/2 (1 - I/Sqrt[3] - 
   Binomial[2 (1 + n), 1 + n] * Hypergeometric2F1[1, 3/2 + n, 2 + n, 4]) *)

Answer 3

ascendingPositions = Position[Nest[Range, Range @ #, # - 1], _,  Heads -> False] &;

subsetsWithDupes = Extract[#, Map[List] @ ascendingPositions @ Length @ #] &;

Examples:

subsetsWithDupes[{a, b}]

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

subsetsWithDupes[{a, b, c}]

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

subsetsWithDupes[{a, b, c, d}]

Count[Nest[Range, Range@#, # - 1], _, All] & /@ Range[12]

{2, 6, 20, 70, 252, 924, 3432, 12870, 48620, 184756, 705432, 2704156}

FindSequenceFunction[%, n]

 Binomial[2 n, n]