-1
$\begingroup$

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!

$\endgroup$
4
  • 1
    $\begingroup$ 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? $\endgroup$
    – Kuba
    Commented Jul 13, 2014 at 7:05
  • 2
    $\begingroup$ 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 $\endgroup$
    – ciao
    Commented Jul 13, 2014 at 7:17
  • $\begingroup$ 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. $\endgroup$ Commented Jul 13, 2014 at 8:33
  • $\begingroup$ 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. $\endgroup$ Commented Jul 13, 2014 at 8:35

3 Answers 3

2
$\begingroup$

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]

enter image description here

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]

enter image description here

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

$\endgroup$
2
  • $\begingroup$ 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. $\endgroup$
    – Bimmel
    Commented Jul 13, 2014 at 9:18
  • $\begingroup$ @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 $\endgroup$
    – ubpdqn
    Commented Jul 13, 2014 at 9:23
2
$\begingroup$

Task: Minimize

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]

enter image description here

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.

$\endgroup$
0
$\begingroup$

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?

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.