Multiplicative partition function

Question

I am trying to create a multiplicative partition function that would generate something like

f[12]
(*{{2, 2, 3}, {4, 3}, {6, 2}}*)
f[24]
(*{{2, 2, 2, 3}, {2, 2, 6}, {4, 2, 3}, {8, 3}, {12, 2}, {4, 6}}*)
f[48]
(*{{2, 2, 2, 2, 3}, {2, 2, 2, 6}, {4, 2, 2, 3}, {2, 2, 12}, {2, 3, 8}, {2, 4, 6}, 
{4, 4, 3}, {6, 8}, {4, 12}, {3, 16}, {2, 24}}*)

I have got as far as

n = 30;
i = FactorInteger[n];
r = Range[Length[i]];
Join[{f = Flatten[Map[Table[i[[#]][[1]], {x, 1, i[[#]][[2]]}] &, r]]},
Transpose[{d = DeleteDuplicates[f], Map[n/d[[#]] &, Range[Length[d]]]}]]

but it is turning out to be more complicated than I thought. Is there a more efficient way of tackling this?

Update

Have got a little further, but still missing some:

n = 48;
i = FactorInteger[n];
r = Range[Length[i]];
f = Flatten[Map[Table[i[[#]][[1]], {x, 1, i[[#]][[2]]}] &, r]];
p = Drop[Drop[DeleteDuplicates[Subsets[f]], 1], -1];
d = Split[Drop[Drop[Reverse[Divisors[n]], 1], -1]];
Drop[Map[Sort[Join[p[[#]], d[[#]]]] &, Range[Length[d]]], -1]

Answer 1

A slightly more compact form of belisarius's answer (differs in that factors are pooped out in descending order of maximum factor in a set):

f2[x_] := 
 DeleteDuplicates[Sort /@ Map[Times @@ # &, 
    SetPartitions[Flatten[ConstantArray @@@ FactorInteger[x]]], {2}]]

Tiny bit more efficient, but really in the noise - both are probably about as efficient as is reasonable: You'd have to prevent creation of duplicate subsets (for later multiplication) to improve much, and I'd venture doing that would eat more time than just using them and deleting dupes post-hoc...

As to your comment question: A001055

ClearAll[c, r, ds, n, a];

c[1, r_] := c[1, r] = 1;

c[n_, r_] := 
  c[n, r] = 
   Module[{ds, i}, ds = Select[Divisors[n], 1 < # <= r &]; 
    Sum[c[n/ds[[i]], ds[[i]]], {i, 1, Length[ds]}]];

a[n_] := c[n, n];

(* count *)
a[1000]

(* calculate and get length to verify *)
Length@f2[1000]

(*

31
31

*)

Vastly faster for large n than calculating fully...

Update: Poking around A162247

g[lst_, p_] := 
 Module[{t, i, j}, 
  Union[Flatten[
    Table[t = lst[[i]]; t[[j]] = p*t[[j]]; 
     Sort[t], {i, Length[lst]}, {j, Length[lst[[i]]]}], 1], 
   Table[Sort[Append[lst[[i]], p]], {i, Length[lst]}]]]; 

f[n_] := Module[{i, j, p, e, lst = {{}}}, {p, e} = 
   Transpose[FactorInteger[n]]; 
  Do[lst = g[lst, p[[i]]], {i, Length[p]}, {j, e[[i]]}]; lst];

f[12]

(* {{12}, {2, 6}, {3, 4}, {2, 2, 3}} *)

But much faster on larger numbers than f2 (but still not as fast as count-only...)

Answer 2

Here's another implementation that performs very similarly to ciao's f. It's a recursive approach using memoization. Maybe someone can see a clever way to speed this up some more...?

MultiplicativePartitions[1] := {{1}}
MultiplicativePartitions[x_] := MultiplicativePartitions[x] = 
  DeleteDuplicatesBy[
   If[PrimeQ[x],
    {{x}},
    Flatten[
     Prepend[
      Table[(Flatten[{#, x/i}] & /@ MultiplicativePartitions[i]), {i, 
        Divisors[x][[2 ;; -2]]}],
      {{x}}
      ],
     1]
    ],
   Sort
   ]

MultiplicativePartitions[12]

{{12}, {2, 6}, {3, 4}, {2, 2, 3}}

Calculation the multiplicative partitions of all numbers up to $n$ for $n = 10, 100, 1000, 10000, 50000$ (clearing the memoized values each time), the timings for this and ciao's f are very similar:

I don't hold out much hope for scaling my solution to $n \gg 10000$ as the scaling of Divisors is no better...!

Answer 3

I think I'm over-complicating it. Anyway:

<< Combinatorica`
f[x_] := DeleteDuplicates[
  Sort /@ Flatten[
    Apply[Times, (SetPartitions /@ 
       Flatten /@ 
        Tuples[Flatten[{#[[1]]^IntegerPartitions@#[[2]]} & /@ 
           FactorInteger[x], 1]]), {3}], 1]]}

f[24] // Column
(*
{24}
{3,8}
{4,6}
{2,12}
{2,3,4}
{2,2,6}
{2,2,2,3} 
*)