# Fast way of re-ordering list

I have a list which at each iteration of my algorithm is being modified. What I want to do is to find the elements that satisfy certain criterion (below it's simply being above the neighborhood average by 20%) and then moving each of these elements to the right until it bumps on the first element greater than itself. The order in which they are movied is not important. Below I wrote a few liner to output a boolean array indicating elements satisfying the criterion.

I am not sure how to proceed from here in an efficient manner. This will be done thousands of times (thousands of list generations). I can of course write loops but there should be a more efficient way to do this task.

(*I am just generating a sample list d. The actual algorithm produces a list like that*)
d = Sort @ RandomVariate[UniformDistribution[], 100];
i = RandomInteger[{1, Length[d]}, 10];
(*Mutating random elements*)
d[[i]] = RandomVariate[UniformDistribution[], Length[i]];
dm = ArrayFilter[(Max[#] - Mean[#])/Mean[#] &, d, 2 ];


An example: initial list = $$\{111,122, 133, 135, 166\}$$, mutated list = $$\{150, 149, 133,130, 166\}$$. After operation: $$\{ 133,130,149, 150,166\}$$ or $$\{ 133,130, 150,149, 166\}$$.

It seems that it is a sorting problem but with a sorting criterion depending upon some function of the neighborhood of the point.

Update

Following up on the discussion with @kglr below, I wrote a code which does the job, but it is very slow (takes about a minute for 1000 element list). To make it reasonable, it should be faster by at least two orders of magnitude. Any suggestions for improvement?

mean[x_, k_, elp_] := Module[{},
Which[elp < k + 1, Return[Mean[x[[;; 2 k + 1]]]],

elp > Length[x] - k, Return[Mean[x[[-(2 k + 1) ;;]]]],

True, Return[Mean[x[[elp - k ;; elp + k]]]]]
];

rebalance[y_, k_, \[Sigma]_, t_: 1] :=
Module[{x = N@y, elp, l, val, m, above, below, all, fp, choicePos,
moveon, leftSide, rightSide},

(*Randomly chosing elements*)
l = Length[x];
(*Selecting positions of elements satisfying above criterion*)
above =
Flatten@Position[
Greater, {x, \[Sigma] t + Map[mean[x, k, #] &, Range[l]]}],
True];
below =
Flatten@Position[
Less, { x, -\[Sigma] t + Map[mean[x, k, #] &, Range[l]]}],
True] ;
all = Join[above, below];

If[Length[all] == 0, Return[x]];

moveon = True;
While[moveon == True ,
choicePos = RandomInteger[{1, Length[all]}];
elp = all[[choicePos]];
all = Drop[all, {choicePos}];
val = x[[elp]];
m = mean[x, k, elp];
(*Print["choice = ",elp,"  value = ", val, " mean = ",m];*)

If[Length[all] == 0, Return[x]];

Which[val > \[Sigma] t + m,
(*Case when elements need to move right*)
(*First position of the occurence*)
rightSide = x[[elp + 1 ;;]];
fp = First@FirstPosition[rightSide, tt_ /; tt > val , {0}];
(*Print[fp];*)
Which[Length[rightSide] == 0, moveon == True,

(*Preventing repetition of the number to stall the algorithm*)
rightSide[[1]] == val, moveon = True,

fp > 1, x = Drop[x, {elp}]; x = Insert[x, val, fp + elp - 1];
moveon = False,

fp == 1, moveon = True,

True,
If[val >= Max[rightSide], x = Drop[x, {elp}];
x = Insert[x, val, l]; moveon = False]
],

(*Considering case when the element needs to move left*)
val < m - \[Sigma] t,
leftSide = Reverse[x[[;; elp - 1]]];
fp = First@ FirstPosition[leftSide, tt_ /; tt < val, { 0}];
(*Print[fp];*)
Which[Length[leftSide] == 0, moveon = True,

(*Preventing repetition of the number to stall the algorithm*)
leftSide[[1]] == val, moveon = True,

fp > 1, x = Drop[x, {elp}]; x = Insert[x, val, elp - fp + 1];
moveon = False,

fp == 1, moveon = True,

True,
If[val <= Min[leftSide], x = Drop[x, {elp}];
x = Insert[x, val, 1]; moveon = False]
],

(*In case no change happens, then moving on to the next element*)

True, moveon = True
]
];
x
];

initiallist = N@RandomInteger[200, 1000];
\[Sigma] = 2;
Print@AbsoluteTiming[
finallist =
FixedPoint[rebalance[#, 2, \[Sigma], 3] &, initiallist];];
ListLinePlot[{initiallist, finallist},
PlotLegends -> {"initiallist", "finallist"},
PlotStyle -> {Blue, Red}]

• Question is ambiguous. Please provide details on the desired outcome. For example "...moving each of these elements to the right until it bumps on the first element greater than itself..." - what if the next element to be moved "bumps on" some element that meets the criteria where some prior element to be moved "bumps on" that same element. Is it to be treated like a pseudo "fixed-point" where the first element to be moved is moved, and that result is treated as the new list starting with the original second element to be moved, or.... what? Some concrete examples will be useful here. – ciao Mar 28 at 0:53
• @ciao Because it is just a reshuffling to maintain statistics reasonable, it doesn't matter the order in which the elements are moved. If two elements bump on the same element they can be placed in arbitrary order next to it. – Al Guy Mar 28 at 12:31

Update: An alternative way that perhaps better fits OP's requirements:

ClearAll[sReplace, fP2, fPL2]
sReplace = SequenceReplace[a : {__} /; Max[a]/Mean[a] > 1 + # && Length[a] == #2 :>
Sequence @@ Append[DeleteCases[a, Max[a]], Max[a]]] &;

fP2 = FixedPoint[sReplace @ ##2, #] &;

fPL2 = FixedPointList[sReplace @ ##2, #] &;


For the simple example list in OP both fP and fP2 give the same result:

fP2[mutatedlist, .05, 3] == fP[mutatedlist, .05]


True

fPL2[mutatedlist, .05, 3] == fPL[mutatedlist, .05]


True

In general the outputs are quite different:

ListLinePlot[{initiallist, fP2[initiallist, .2, 3]},
PlotLegends -> {"initiallist", "fP2[initiallist, .2, 3]"}]


frames2 = Table[ListLinePlot[{initiallist, i}], {i, fPL2[initiallist, .2, 3]}];
Export["anim2.gif", frames2, "DisplayDurations" ->1]


Perhaps a combination of SequenceReplace and FixedPoint as follows?

ClearAll[fP, fPL]
fP = FixedPoint[SequenceReplace[{a_, b_, c_} /;
a/Mean[{a, b, c}] > 1 + #2 && a > c :> Sequence[b, c, a]], #] &;
fPL = FixedPointList[SequenceReplace[{a_, b_, c_} /;
a/Mean[{a, b, c}] > 1 + #2 && a > c :> Sequence[b, c, a]], #] &;


Examples:

mutatedlist = {150, 149, 133, 130, 166};
t = .05;

fP[mutatedlist, t]

 {133, 130, 150, 149, 166}

fPL[mutatedlist, t]

 {{150, 149, 133, 130, 166}, {150, 133, 130, 149, 166}, {133, 130, 150,
149, 166}, {133, 130, 150, 149, 166}}

SeedRandom[1]
initiallist = RandomInteger[200, 40];
ListLinePlot[{initiallist , fP[initiallist , .2]},
PlotLegends -> {"initiallist", "fP[initiallist, .2]"}]


frames = Table[ListLinePlot[{initiallist, i}], {i, fPL[initiallist, .2]}];
Export["anim.gif", frames, "DisplayDurations" -> .2]


• This is great, thanks, @kglr! – Al Guy Mar 28 at 22:11
• What if the sequence length is not 3 but some number k which is an input? – Al Guy Mar 29 at 0:59
• @AlGuy, please see the update. – kglr Mar 29 at 1:43
• Thanks! It's a little surprising that the first big peak at 6 isn't moved to the right. – Al Guy Mar 29 at 14:22
• The documentation on SequenceReplace states: "On each sequence, it tries in turn each of the transformation rules that were specified. If any of the rules apply, it replaces the sequence, then continues to go through the list, starting at the element position after the end of the sequence. ". This means for k=3, it tries elements {1,2,3} and then elements {4,5,6}. But my understanding is that after {1,2,3} it should try {2,3,4} for the FixedPoint to operate correctly. I think that's why we see these spikes. I was wondering how this can be implemented. – Al Guy Mar 29 at 20:58