# Creating a version of ParallelTable that parallelizes over all levels

Mathematica's ParallelTable (or any Parallel function based on iterators, like ParallelDo) only parallize the computation for the top level iterator (even with Method -> "FinestGrained"' set).

For example, with the following commands (on a system with at least 4 cores)

LaunchKernels[4];
ParallelTable[Pause[1], {i, 2}, {j, 2},    Method -> "FinestGrained"];// AbsoluteTiming
ParallelTable[Pause[1], {i, 1}, {j, 4}, Method -> "FinestGrained"]; // AbsoluteTiming
ParallelTable[Pause[1], {i, 4}, {j, 1},    Method -> "FinestGrained"]; // AbsoluteTiming


The first table will complete in about 2 seconds, the second in 4 and the last in 1. This behaviour has been discussed in previous questions for example:

One suggested work around is to work with a flattened table, which in many cases is appropriate. However sometimes this is not very appropriate. (Think for example about cases with dependent iterators producing non-rectangular arrays.) I want (to create) a version of ParallelTable that has the same syntax as Table, but parallelizes the computation at the finest possible (entry) level.

(My secret hope here is that there actually is an undocumented option of ParallelTable that actually does this.)

maybe something like this is useful, specify a permutation of the table iterators, then transpose the result back to get the original ordering:

 SetAttributes[ptab, HoldAll];
Options[ptab] = {perm -> Automatic};
ptab[exp_, itr : {_Symbol, __} .. , opt : OptionsPattern[]  ] :=
Module[{p = OptionValue[perm]},
If[p == Automatic, p = Range@Length@{itr}];
ParallelTable[ exp,
Evaluate[Sequence @@ Permute[{itr}, InversePermutation@p]]]~
Transpose~p]


Extended the example to three levels, and give the expression a result, to validate the transpose:

(a = ptab[Pause[1]; {i, j, k}, {i, 1}, {j, 1}, {k, 4}]) //
AbsoluteTiming // First


4.08

(b = ptab[Pause[1]; {i, j, k}, {i, 1}, {j, 1}, {k, 4}, perm->{3, 1, 2}]) //
AbsoluteTiming // First


1.02

a == b


True

• This still has the problem that it only parallelizes over one of the iterators. Moreover it won't work at all for non-rectangular arrays. Aug 15 '16 at 9:54
• it is the nature of parallel computing that you need to be smart about your implementation. Do you seriously think this such a bad answer to deserve a downvote? Aug 16 '16 at 12:41

I remembered I tried this in the past. This is the answer I came op with:

SetAttributes[PTable, HoldAll]
PTable[a_, it : {_Symbol, __} ..] :=
WaitAll@With[{vars = {it}[[All, 1]]},
Table[
ParallelSubmit[vars, a],
it
]
]


I recall that this did not behave satisfactory under certain conditions, but I can't seem to recreate those now. (It could version or platform related, I'll try to figure out that one later.)

* UPDATE *

I have managed to reproduce the issues this was causing me. It turns out this was being caused by a different issue specific to the calculation I was doing which was producing excessive overhead for each parallel task. Consequently, this issue (also present when using standard ParallelTable) was simply being exacerbated by the increase in number of parallel tasks.

Test cases (with significant computation time per entry) now indicate that PTable as implemented above is actually (marginally) faster than standard ParallelTable with Method-> "FinestGrained", even for 1D arrays (in which case it spawns the same parallel tasks).

• this would seem to "over do it", spawning parallel processes for every table entry. Jul 29 '16 at 12:32
• Why would that be "over doing it"? Parallizing over individual entries is exactly what I was asking for. (The application I have in mind has individual table entries that may take up to several minutes to evaluate.) Aug 15 '16 at 9:57
• obviously it depends on the application, if the overhead hit is not consequential then its fine. Aug 16 '16 at 12:31
• This sounds nice. Have you compared it with other workarounds like this in terms of speed? Jan 31 at 6:56

The following does that. It borrows on many contributions Creating a Block from a list of rules and How do I evaluate only one step of an expression?

SetAttributes[step, HoldAll]
step[expr_] :=
Module[{P}, P = (P = Return[#, TraceScan] &) &;
TraceScan[P, expr, TraceDepth -> 1]]

SetAttributes[ruleBlock, HoldAll]
ruleBlock[L_List, body_] :=
Block @@ Join[Apply[Set, Hold[L], {2}], Hold[body]]
ruleBlock[obj_, body_] := step[obj] /. _[x_] :> ruleBlock[x, body]

SetAttributes[myParallelTable, HoldFirst]
myParallelTable[stufftodo_, it : {_Symbol, _?ListQ} ..] :=
Module[{it2, rls, syms, its},
it2 = List[it];
syms = it2[[All, 1]];
its = it2[[All, 2]];
ParallelMap[(
rls = Map[Rule[#[[1]], #[[2]]] &, {syms, #}\[Transpose]];
ruleBlock[rls, stufftodo]
) &,
Tuples[its], Method -> "FinestGrained"
]
]


Check its behavior with, e.g.,

myParallelTable[
Pause[0.1 Mod[$$KernelID - 1, 2]]; Labeled[Framed[(i - 1) 4 + j],$$KernelID],
{i, Range[3]}, {j, Range[4]}
]
`