Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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!

share|improve this question
1  
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 Jul 13 at 7:05
2  
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 –  rasher Jul 13 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. –  nikie Jul 13 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. –  nikie Jul 13 at 8:35

3 Answers 3

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).

share|improve this answer
    
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. –  Bimmel Jul 13 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 –  ubpdqn Jul 13 at 9:23

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.

share|improve this answer

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?

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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