# Elegant way to partition list to be faster than ParallelTable (using ParallelSubmit), or some alternative?

Suppose you have a function

fun[x_] := (Pause[.05*x]; x^2);


of which you know that its evaluation time increases with its argument - in this case obviously linearly. Consider the following piece of code:

ClearAll["Global*"];
CloseKernels[];
list = Range[1, 12];
listparallel1 = Partition[list, 3];
listparallel2 = {{1, 5, 12}, {2, 6, 11}, {3, 7, 10}, {4, 8, 9}};
f11 := (Table[fun[i], {i, listparallel1[]}]);
f21 := (Table[fun[i], {i, listparallel1[]}]);
f31 := (Table[fun[i], {i, listparallel1[]}]);
f41 := (Table[fun[i], {i, listparallel1[]}]);
f12 := (Table[fun[i], {i, listparallel2[]}]);
f22 := (Table[fun[i], {i, listparallel2[]}]);
f32 := (Table[fun[i], {i, listparallel2[]}]);
f42 := (Table[fun[i], {i, listparallel2[]}]);


Now compare timings:

LaunchKernels;
DistributeDefinitions[f11, f21, f31, f41, f12, f22, f32, f42];
res1 = Table[fun[i], {i, list}]; // AbsoluteTiming
(* 3.905648 *)
res2 = ParallelTable[fun[i], {i, list}]; // AbsoluteTiming
(* 1.670125 *)
AbsoluteTiming[
res3tmp = {ParallelSubmit[f11], ParallelSubmit[f21],
ParallelSubmit[f31], ParallelSubmit[f41]};
res3 = Flatten@WaitAll[res3tmp];]
(* 1.674126 *)
AbsoluteTiming[
res4tmp = {ParallelSubmit[f12], ParallelSubmit[f22],
ParallelSubmit[f32], ParallelSubmit[f42]};
res4 = Flatten@WaitAll[res4tmp];]
(* 1.068721 *)


We see, ParallelTable already does a goodish job, but since it does not have the insight into the function as we do, this can be optimized via ParallelSubmit. Since runtime increases with elements in list, it is natural to partition the list as done in listparallel2 and clearly, timings for res4 are much better than for the ParallelTable version res2.

My question is, what is an elegant way to partition list into the form of listparallel2 such that I provide a number of sublists n (here, n=4) and it then fills the first sublist starting with first and last element of list, going on to the second sublist with second and second to last element of list and so on.

Alternatively, how can one determine the optimal distribution of jobs to parallel kernels?

## Update

Unfortunately, the first method in the answer by @unlikely leads to kernel crash on my machine for sufficiently large problems (see this question). Since I am using Mathematica 10.0.1 I cannot use the second method in unlikely's answer because RepeatedTiming and EchoFunction are not available. So, even if it is not the most optimal way - I am again interested in a customized Partition like function, that brings list into the form of listparallel2.

• RepeatedTiming and EchoFunction are just for benchmarking. You can remove all these calls and the following //Last. You can also use the sub/optimal partitioning as of my second answer. Feb 25, 2016 at 16:24
• @unlikely Thanks for all your effort! I actually believe that I did that, but it returned an empty list. Will try again later when I have access to my computer again and report back . Feb 25, 2016 at 17:05

It's a common jobs-to-resources assignment problem.

Suppose you have $n$ jobs (long running) to be distributed across $m$ resources working in parrallel and each job $i$ takes a time $c_i$ to be completed. Define the following decision variables:

• $x_{i,j} \in \{0,1\}$ and it's $1$ if the job $i$ is assigned to resource $j$
• $y_j \ge 0$ is the total time required for the resource $j$ complete his work (the definition/use of these variables is not mandatory)
• $z \ge 0$ is the whole time required to complete all jobs

Obviously you have some constraints:

• $\sum_{j=1}^m x_{i,j} = 1$ for all $i=1,\ldots,n$ because each job must be assigned to exactly one resource
• $y_j = \sum_{i=1}^n c_i x_{i,j}$ for all $j=1,\ldots,m$
• $z \ge y_j$ for all $j=1,\ldots,m$ because $z = \max_j y_j$

Now your objective function is $z$ (to be minimized).

This can be done with LinearProgramming:

n = 12;
m = 4;
costs = Range@n/2 // N;

vars = Flatten@{
Array[x, {n, m}],
Array[y, m],
z
};

constraints = Flatten@{
Table[Sum[x[i, j], {j, m}] == 1, {i, n}],
Table[y[j] == Sum[x[i, j] costs[[i]], {i, n}], {j, m}],
Table[z >= y[j], {j, m}]
};

bm = CoefficientArrays[Equal @@@ constraints, vars];
solution = LinearProgramming[
Last@CoefficientArrays[z, vars],
bm[],
Transpose@{-bm[],
constraints[[All, 0]] /. {Equal -> 0, GreaterEqual -> 1}},
vars /. {_x -> {0, 1}, (_y | z) -> {0, \[Infinity]}},
vars /. {_x -> Integers, (_y | z) -> Reals}
];

Cases[Pick[vars, solution, 1], x[ij__] :> {ij}];
GroupBy[%, Last -> First] // Values // SortBy[First]


{{1, 3, 6, 10}, {2, 4, 12}, {5, 7, 8}, {9, 11}}

that tell you the optimal distribution of the jobs across the resources.

Indeed with this approach the time required to complete the work is:

Pick[solution, vars, z]


{10.}

listparallel2 = {{1, 5, 12}, {2, 6, 11}, {3, 7, 10}, {4, 8, 9}};
Plus @@@ (listparallel2/2) // Max


21/2

Obviously the whole optimization process takes times, and for short jobs is not necessary.

You can also use the simple Minimize to get the another optimal result

n = 12; m = 4; c = Range@n/2 // N;
solution = Minimize[{z, {
Table[Sum[x[i, j], {j, m}] == 1, {i, n}],
Table[Sum[c[[i]] x[i, j], {i, n}] <= z, {j, m}],

Table[{x[i, j] \[Element] Integers, 0 <= x[i, j] <= 1}, {i,
n}, {j, m}]
}},
Flatten@{Array[x, {n, m}], z}
] // RepeatedTiming // EchoFunction["Timing:", First] //
Last // EchoFunction["Optimal value:", First] // Last;
GroupBy[Cases[solution, (x[ij__] -> 1) :> {ij}],
Last -> First] // Values


Optimal value: 10.

{{1, 2, 3, 4, 10}, {5, 6, 7}, {8, 12}, {9, 11}}

• Many thanks! This seems to be a really nice approach. Would you mind elaborating a little bit on what your constraints represent? I would like to fully understand this approach using LinearProgramming Feb 22, 2016 at 18:54
• @Lukas I added an introduction. You can also check my answrs to the follwoing questions: mathematica.stackexchange.com/questions/47211/… and mathematica.stackexchange.com/questions/107859/… because I used LinearProgramming Feb 22, 2016 at 19:46
• Thanks alot! This goes beyond what I imagined and excellently answers my question. Now that you have explained the constraints it is all clear. Also thanks for further references, will take a look. Feb 22, 2016 at 19:49
• @Lukas Thank you, although I do not know if it responds to your initial question as this optimization deserves to be made for long jobs Feb 22, 2016 at 20:37
• I agree, it does not 100% answer the question as it is formulated because I ask for some way to Partition. Yet, my actual problem is some sort of a Table with many elements where timings scale linearly with big slope. Your approach is way better than the approximation I asked for in these cases. I extended the question a little Feb 22, 2016 at 20:46

If you can accept a sub optimal partitioning, you can also apply the following strategy:

n = 12; m = 4;
j = Range@n;
c = j/2;

jd = Fold[
MapAt[Append[#2], #, Ordering[Total[#[[All, All, 2]], {2}], 1]] &,
Table[{{0, 0}}, m],
Transpose@{j, c} // SortBy[Minus@*Last]
][[All, 2 ;; -1]];

jd[[All, All, 1]]
Max@Total[jd[[All, All, 2]], {2}]
`

{{12, 5, 4}, {11, 6, 3}, {10, 7, 2}, {9, 8, 1}}

21/2

• Thanks! Although this is not optimal, it at least yields solutions reliably without crashing kernel... Feb 25, 2016 at 21:32