Mathematica: reconstruct an arbitrary nested list after Flatten

Question

What is the simplest way to map an arbitrarily funky nested list expr to a function unflatten so that expr==unflatten@@Flatten@expr?

Motivation: Compile can only handle full arrays (something I just learned -- but not from the error message), so the idea is to use unflatten together with a compiled version of the flattened expression:

fPrivate=Compile[{x,y},Evaluate@Flatten@expr];
f[x_?NumericQ,y_?NumericQ]:=unflatten@@fPrivate[x,y] 

Example of a solution to a less general problem: What I actually need to do is to calculate all the derivatives for a given multivariate function up to some order. For this case, I hack my way along like so:

expr=Table[D[x^2 y+y^3,{{x,y},k}],{k,0,2}];
unflatten=Module[{f,x,y,a,b,sslot,tt},
  tt=Table[D[f[x,y],{{x,y},k}],{k,0,2}] /. 
    {Derivative[a_,b_][_][__]-> x[a,b], f[__]-> x[0,0]};
  (Evaluate[tt/.MapIndexed[#1->sslot[#2[[1]]]&, 
            Flatten[tt]]/. sslot-> Slot]&) ] 

Out[1]= {x^2 y + y^3, {2 x y, x^2 + 3 y^2}, {{2 y, 2 x}, {2 x, 6 y}}}
Out[2]= {#1, {#2, #3}, {{#4, #5}, {#5, #7}}} &

This works, but it is neither elegant nor general.

Edit: Here is the "job security" version of the solution provided by aaz:

makeUnflatten[expr_List]:=Module[{i=1},
    Function@Evaluate@ReplaceAll[
        If[ListQ[#1],Map[#0,#1],i++]&@expr,
        i_Integer-> Slot[i]]]

It works a charm:

In[2]= makeUnflatten[expr]
Out[2]= {#1,{#2,#3},{{#4,#5},{#6,#7}}}&

Answer 1

You obviously need to save some information about list structure, because Flatten[{a,{b,c}}]==Flatten[{{a,b},c}].

If ArrayQ[expr], then the list structure is given by Dimensions[expr] and you can reconstruct it with Partition. E.g.

expr = {{a, b, c}, {d, e, f}};
dimensions = Dimensions[expr]

  {2,3}

unflatten = Fold[Partition, #1, Reverse[Drop[dimensions, 1]]]&;
expr == unflatten @ Flatten[expr]

(The Partition man page actually has a similar example called unflatten.)

---

If expr is not an array, you can try this:

expr = {a, {b, c}};
indexes = Module[{i=0}, If[ListQ[#1], Map[#0, #1], ++i]& @expr]

  {1, {2, 3}}

slots = indexes /. {i_Integer -> Slot[i]}

  {#1, {#2, #3}}

unflatten = Function[Release[slots]]

  {#1, {#2, #3}} &

expr == unflatten @@ Flatten[expr]

Answer 2

I am not sure what you are trying to do with Compile. It is used when you want to evaluate procedural or functional expressions very quickly on numerical values, so I don't think it is going to help here. If repeated calculations of D[f,...] are impeding your performance, you can precompute and store them with something like Table[d[k]=D[f,{{x,y},k}],{k,0,kk}];

Then just call d[k] to get the kth derivative.