2
$\begingroup$

I'll try to make a basic example of my problem with $n$ being an array of elements, ex. $\{1,2,2,3,3,3\}$:

If i have a sum which needs a computed value i would like to compute it beforehand and store it in a variable (ex. $k$). When calculating the sum, $k$ is not $i_{max}$ but $\{i_1,i_2,...\}$:

f[{_}] = 2.;
f[n_] := f[n] = (
   k = Union[Select[n, # > 1 &]];
   f[Drop[n, 1]]
     + If[k == {}, 0., 
        Sum[Count[n, i]
         *f[Join[DeleteCases[n, i, 1, 1], i - 1]], {i, k}]])

f[{1, 2, 2, 3, 3, 3}]
Out=1368.

But this output is not what i intended to generate and i assume it's because a recursive step is computed every time it is encountered, overwriting $k$ every time.

The correct computation would be:

g[{_}] = 2.;
g[n_] := g[n] = (
   g[Drop[n, 1]]
     + If[Union[Select[n, # > 1 &]] == {}, 0., 
        Sum[Count[n, i]
         *g[Join[DeleteCases[n, i, 1, 1], i - 1]], {i, Union[Select[n, # > 1 &]]}]])

g[{1, 2, 2, 3, 3, 3}]
Out=2640.

The computation of the function $f$ is however much faster then $g$, so i'm wondering if it's possible to first gather all recursions needed before computing them, so computing $k$ once in each recursion would be enough.

Edit: I decided to upload my original code as it is not too complex. The goal is to compute a theoretical distribution for Runs-up-and-down:

edit[r_, del_, add_] := edit[r, del, add] = 
  If[Min[Count[r, #1] - #2 & @@@ Tally[del]] < 0, {}, 
    Sort[Join[Fold[DeleteCases[##, 1, 1] &, r, del], add]]]

h[{}] = 0.;
h[{_}] = 2.;
h[r_] := h[r] = (
   2*h[edit[r, {1}, {}]]
    + If[Union[Select[r, # > 1 &]] == {}, 0., 
     Sum[(Count[r, i - 1] + 1)*h[edit[r, {i}, {i - 1}]], {i, 
       Union[Select[r, # > 1 &]]}]]
    + Sum[(Count[r, i + j] + 1)*h[edit[r, {1, i, j}, {i + j}]], {i, 
      Union[r]}, {j, Union[r]}])

n = 31; 
dist = Flatten[
List /@ Plus @@@ 
  Map[h, GatherBy[Sort /@ IntegerPartitions[n - 1], 
    Length], {2}]]/n! // AbsoluteTiming

The computation takes about 25 seconds on my (slow) Notebook. By storing Union[Select[r, # > 1 &]] and Union[r] into variables, the computation only took 17 seconds but delivered wrong results.

$\endgroup$
2
$\begingroup$

Use With to replace only explicit appearances of k in the right-hand-side, preventing the changing values of k from contaminating the stack.

f[{_}] = 2.;

f[n_] := f[n] =
  With[
   {k = Union[Select[n, # > 1 &]]},
   f[Drop[n, 1]] + 
    If[k == {}, 0., Sum[Count[n, i]*f[Join[DeleteCases[n, i, 1, 1], i - 1]], {i, k}]]
  ]

f[{1, 2, 2, 3, 3, 3}]
2640.
$\endgroup$
  • $\begingroup$ I tried using with but the computation speed seems similar in my original code. As an example it took about 17 seconds by changing the code to something like my (wrong) function f, about 25 seconds with function g and about 24 seconds using with. Maybe i should post my original code as it isn't too complicated. $\endgroup$ – kon Mar 25 '15 at 11:58
  • $\begingroup$ @kon I'll take a look at it. $\endgroup$ – Mr.Wizard Mar 25 '15 at 13:30
  • $\begingroup$ @kon It would appear that the vast majority of the time is spent on edit, so optimizing h is unlikely to be of much help unless it can be made to call edit less. Since you got the wrong output I suggest that the apparent improvement you saw was not due to greater efficiency but simply fewer calls to edit. I shall continue to play with this but I shall focus on edit. $\endgroup$ – Mr.Wizard Mar 25 '15 at 13:45
  • $\begingroup$ the edit function is a result of the help i got here $\endgroup$ – kon Mar 25 '15 at 13:49
  • $\begingroup$ @kon Unless I misread it that question appears to be a duplicate. There are faster ways to approach this. I'll get back to you after some moderator custodial work. $\endgroup$ – Mr.Wizard Mar 25 '15 at 13:53

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.