# Leveling peaks in list

Consider the following:

data={2,2,2,5,3,3,3,6,1,1,1,0};
In[1]:=result=MyFunction@data
Out[1]:={2,2,3.5,3.5,3,3,4.5,4.5,1,1,1,0}


data[[{4,8}]] represent the peaks which I want to level via MyFunction as follows:

{a___,PrePeakValue1_,peak1_,b___,PrePeakValue2_,peak2_,c___}:>{a,Mean1,Mean1,b,Mean2,Mean2,c}


whereas Mean1=Mean@{PrePeakValue1,peak1} (i.e. Mean@{2,5}) and Mean2=Mean@{PrePeakValue2,peak2} (i.e. Mean@{3,6}).

I posted this question already some time ago, but Heike's approach has one disadvantage: neither it identifies and therefor nor levels the second peak. I think using LengthWhile migth be one reason why it won't work.

EDIT: data is just an example. I have other lists which may contain no, one or more than two peaks.

-
what is your desired output for the list {2, 2, 2, 5, 4, 3, 3, 6, 5, 1, 1, 0}? Is it {2, 2, 3.5, 3.5, 4, 3, 4.5, 4.5, 5, 1, 1, 0} or {2., 2., 3.5, 3.75, 3.75, 3., 4.5, 4.75, 4.75, 1., 1., 0.}? –  kguler May 22 '12 at 8:12
... a simpler example: what should the function give for input {4, 10, 9, 8}? –  kguler May 22 '12 at 8:26

data={2,2,2,5,3,3,3,6,1,1,1,0};
data //. {a__, b_, c_, d_, e__} /; b < c > d :> {a, Mean[{b, c}],  Mean[{b, c}], d, e}

(*
-> {2, 2, 7/2, 7/2, 3, 3, 9/2, 9/2, 1, 1, 1, 0}
*)


Test drive

data = {2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0, 2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0};
ListLinePlot[{data,
data //. {a__, b_, c_, d_, e__} /; b < c > d :> {a, Mean[{b, c}], Mean[{b, c}], d, e}}


Edit

data = {575, 1242, 667, 667, 500, 500, 500, 500};
data //. {a___, b_, c_, d_, e___} /; b < c > d :> {a, Mean[{b, c}], Mean[{b, c}], d, e}
(*
-> {1817/2, 1817/2, 667, 667, 500, 500, 500, 500}
*)


I just changed a__ for a___ and e__ for e___ , allowing both ends to be null.

-
Thanks. Like my suggestion your approach is limited to two peaks. I would like Mathematica identify the number of peaks on its own. –  John May 18 '12 at 23:00
@John Please see edit –  belisarius May 18 '12 at 23:28
@John NEVER accept a procedural approach as the better one in Mma. A functional or pattern matching style should always be better in performance (see LS's answer) or simplicity –  belisarius May 28 '12 at 0:05
@John (Join[{data[[2]]}, data, {data[[-2]]}] //. {a__, b_, c_, d_, e__} /; b < c > d :> {a, Mean[{b, c}], Mean[{b, c}], d, e})[[2 ;; -2]] ? –  belisarius Nov 9 '12 at 18:33

This is reasonably performant, but top-level:

Clear[ff,toLinkedList];
toLinkedList[l_List] := Fold[{#2, #1} &, {}, Reverse@l];

ff[accum_List, {x_, {y_, rest : {z_, _}}} /; y > x && y > z] :=
ff[{accum, {#, #} &[N@Mean[{x, y}]]}, rest];
ff[accum_List, {x_, rest_}] := ff[{accum, x}, rest];
ff[accum_List, {}] := Flatten[accum];


The usage is

ff[data]


This is rather ugly, but several times faster:

Clear[peakPositions];
peakPositions[data_] :=
Position[
First@Differences[
Clip[Differences@Partition[data, Length[data] - 2, 1], {-1, 1}]],
-2] + 1;

Clear[myFunction];
myFunction[data_] :=
Module[{d = data, pos},
pos = Flatten@Transpose[{# - 1, #}] &@peakPositions[data];
d[[pos]] = N@Flatten@Transpose[{#, #}] &@Total[Partition[d[[pos]], 2], {2}]/2;
d]


The usage is

myFunction[data]

-

Here's a procedural version:

trimPeaks[data_] :=
Module[{d = data},
Do[
If[
d[[i - 1]] < d[[i]] > d[[i + 1]],
d[[{i - 1, i}]] = Mean[d[[{i - 1, i}]]]
],
{i, 2, Length[d] - 1}];
d
]

-
ClearAll[localmaxpos, leveledpeaks];
localmaxpos[list_List] := Pick[Range@Length@list,
(Prepend[#, 0] - Append[#, 0]) &@(Sign@Differences@list), 2];
leveledpeaks[dt_List] :=  Module[{list = dt, pos = localmaxpos[dt]},
(list[[# - 1 ;; # ]] = {Mean[list[[# - 1 ;; #]]], Mean[list[[# - 1 ;; #]]]}) & /@ pos; list];
data = {2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0};
leveledpeaks[data]
(* ==> {2, 2, 7/2, 7/2, 3, 3, 9/2, 9/2, 1, 1, 1, 0}*)
leveledpeaks[{2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0}]
(* ==> {2, 2, 7/2, 7/2, 3, 3, 9/2, 9/2, 1, 1, 1, 0} *)


As J.M. noted in the comments, the selector array inside Pick[...]

(Prepend[#, 0] - Append[#, 0]) &@(Sign@Differences@list)


can be replaced with

ListCorrelate[{1, -1}, #, {-1, 1}, 0] &@(Sign@ListCorrelate[{-1, 1}, list])


or with

ListConvolve[{-1, 1}, #, {1, -1}, 0] &@(Sign@ListConvolve[{1, -1}, list])

-
The (Prepend[#, 0] - Append[#, 0]) & can be replaced with ListCorrelate[{1, -1}, #, {-1, 1}, 0] &, among other things... –  Guess who it is. May 22 '12 at 6:45
@J.M. good point! Thanks! –  kguler May 22 '12 at 6:47
As it stands, your current implementation of leveledpeaks[] chokes when given an explicit list; e.g. leveledpeaks[{2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0}]. It's easily fixed, though: leveledpeaks[da_] := Module[{data = da}, (data[[# - 1 ;; # + 1]] = Append[ConstantArray[Mean[data[[# - 1 ;; #]]], 2], data[[# + 1]]]) & /@ localmaxpos[data]; data]; –  Guess who it is. May 22 '12 at 6:58
Thank you again, @J.M.! Just added the fix and alternative specs for the selector array inside Pick that you suggested. –  kguler May 22 '12 at 7:21