# Optimization Algorithm: ideas wanted

EDIT: Lets assume a random matrix:

m = RandomInteger[25, {5, 5}] // MatrixForm
m= {{8, 23, 1, 3, 19}, {25, 4, 21, 7, 15}, {5, 9, 17, 21, 12}, {10, 3, 5,15, 15}, {17, 15, 10, 16, 11}}


The wanted algorithm should do the following: Pick a random element from the given table and change the order of the matrixelements that small gaussian-like clusters are generated. The constraint is that either the row-wise or the coloumn-wise sum should remain constant upon swapping the elements.

Suggestions are very welcome!

• It seems that your are shuffling between columns too... Also, position of 11 and 10 has no sense to me. Could you make your wish more precise?
– Kuba
Commented Jul 13, 2014 at 7:05
• Wildly ambiguous question. That said, is something like the result of the following what you're after (m is the base matrix): tmp = (Sort /@ Transpose@m); With[{c = Ceiling[Length@tmp[[1]]/2]}, tmp[[All, c ;;]] = tmp[[All, -1 ;; c ;; -1]]]; tmp // Transpose
– ciao
Commented Jul 13, 2014 at 7:17
• As it's stated, I think the optimal solution is to move the max in each row to the middle of the row. That way, no value is more than 2 rows away from the maximum. Commented Jul 13, 2014 at 8:33
• If you want to improve your question, show us a function that would "grade" different solutions, i.e. that would add up some distances, values, whatever, and the solution that gets the highest (or lowest) grade is the optimum. Commented Jul 13, 2014 at 8:35

I apologize if I misunderstand your aim. Here is a first attempt.

m = {{8, 23, 1, 3, 19}, {25, 4, 21, 7, 15}, {5, 9, 17, 21, 12}, {10,
3, 5, 15, 15}, {17, 15, 10, 16, 11}};
fun[lst_] := Module[{st, lg, md, mx},
st = Sort[lst];
lg = Length[lst];
md = Floor[lg/2];
If[Mod[lg, 2] == 1,
Take[st, md]~Join~{Last@st}~Join~Reverse[Take[Most@st, -md]],
Take[st, md]~Join~{Last@st}~Join~Reverse[Take[Most@st, -(md - 1)]]
]]


Visualizing:

mg1 = BarChart3D[m, ChartLayout -> "Grid",
ViewPoint -> {5.03239650286209, -2.7440079512451665,
8.668644980704006}];
mg2 = BarChart3D[fun /@ Transpose[fun /@ m], ChartLayout -> "Grid",
ViewPoint -> {5.03239650286209, -2.7440079512451665,
8.668644980704006}];
GraphicsRow[{mg1, mg2}, ImageSize -> 600]


Testing on a larger set:

test = RandomInteger[{0, 10}, {30, 30}];
tg1 = BarChart3D[test, ChartLayout -> "Grid",
ViewPoint -> {5.03239650286209, -2.7440079512451665,
8.668644980704006}]
tg2 = BarChart3D[fun /@ Transpose[fun /@ test], ChartLayout -> "Grid",
ViewPoint -> {5.03239650286209, -2.7440079512451665,
8.668644980704006}]
eg2 = GraphicsRow[{tg1, tg2}, ImageSize -> 600]


May not be your aim (could have also used MatrixPlot for visualization).

• thanks your attempt. I think this is the right direction. But as stated (see edited question) in my question the total of the optimized list should be equal to the unoptimized. Commented Jul 13, 2014 at 9:18
• @Bimmel ok...I am sure there will be better approaches than my first attempt...will reread (if and) when I get a chance but look forward to other answers Commented Jul 13, 2014 at 9:23

Differences[m, {0, 1}]

those matrices under the constraint:

Total[m,{2}]==Total[moptimized,{2}]

First of all, that optimization objective doesn't make much sense: It's a matrix, not a scalar. So which value of the difference matrix should be optimized? The (possibly weighted) mean? The lowest or highest value? The median?

And it is probably not what you want, either. You can simply set:

mOpt = Transpose[Transpose[m] - x*Range[-2, 2]];
MatrixForm[mOpt]


Which decreases Differences[mOpt, {0, 1}] everywhere by x:

{{15 - x, -22 - x, 2 - x, 16 - x},
{-21 - x, 17 - x, -14 - x, 8 - x},
{4 - x, 8 - x, 4 - x, -9 - x},
{-7 - x, 2 - x, 10 - x, -x},
{-2 - x, -5 - x, 6 - x, -5 - x}}


without changing the row sums:

Total[m, {2}] == Total[mOpt, {2}]


True

So you can minimize the optimization objective indefinitely.

Normally I would use a comment, but I don't have this privilege now

Part[#, -{2, 1, 3, 4, 5}] &@Sort@# & /@ m // MatrixForm


Is this ok for you?