Leveling peaks in list

Question

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.}? — kglr, May 22 '12 at 08:12
... a simpler example: what should the function give for input {4, 10, 9, 8}? — kglr, May 22 '12 at 08:26

score 9 · Accepted Answer · edited May 28 '12 at 00:11

9

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}}

enter image description here

Edit

Answering John's comment. This works:

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.

edited May 28 '12 at 00:11

rm -rf

88,781
21
293
472

answered May 18 '12 at 22:57

Dr. belisarius

115,881
13
203
453

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
5

@John Please post all your requirements on your question – Dr. belisarius May 18 '12 at 23:05
@John Please see edit – Dr. belisarius May 18 '12 at 23:28
A problem occurred with your approach. Consider the following: data = {575, 1242, 667, 667, 500, 500, 500, 500};
Since a___ does not exist, the code does not work.
– John May 21 '12 at 14:59
@belisatius: I changed to mef's approach, as it does not show the problem which I described in my preceding comment. However, I prefer the way you tried to solve my problem. Maybe there is a way to customise your code, so that it works for any data? – John May 21 '12 at 16:18
@John See edit please – Dr. belisarius May 22 '12 at 01:35
2

@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 – Dr. belisarius May 28 '12 at 00:05
Only for completeness: I changed something in my code, which led to another layout of data: dataNew=Transpose[{Range[Length@data],data}]. I agree with belisarius, that his approach is the most simple/comprehensible one. Applying his approach on dataNew therefor is easy: dataNew //. {a___, {x_,b_}, {y_,c_}, {z_,d_}, e___} /; b < c > d :> {a, {x,Mean[{b, c}]}, {y,Mean[{b, c}]}, {z,d}, e} – John Jun 04 '12 at 17:35
I just discovered that there is one problem with your approach. Lets say you have data={10,0,0,0,10}. Then both, the first and the last value, are extrem values which I would like to level as described. I did not pay attention to this case when I asked my question. The problem I see, is that the approach must extend data to the left. (desired result: res={5,5,0,0,5,5}. Note: Length@res-Length@data=1) – John Nov 08 '12 at 18:09
@John But ... what is the condition for an endpoint to be considered a "peak"? Are you comparing it with its only neighbor? – Dr. belisarius Nov 08 '12 at 18:47
An extreme value is always to be levelled if its neighbour is lower (e.g. dataNoLevelling={1,5,5,5,1} -> (*resNoLevelling={1,5,5,5,1}*)and dataLevelling={100,5,5,5,100} -> (*resLevelling={50,50,5,5,52.5,52,5}*) – John Nov 08 '12 at 20:14
The following works but maybe there is a better approach: first = {left_, right_, rest___} /; left > right :> {left/2, left/2, right, rest}; sec = {rest___, left_, right_} /; right > left :> {rest, Mean[{left, right}], Mean[{left, right}]}; third = {a___, b_, c_, d_, e___} /; b < c > d :> {a, Mean[{b, c}], Mean[{b, c}], d, e};
(# //. first //. sec //. third) & @ data
– John Nov 09 '12 at 18:02
1

@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]] ? – Dr. belisarius Nov 09 '12 at 18:33
Almost. With {a___, b_, c_, d_, e___} instead of {a__, b_, c_, d_, e__} it works. (i.e. BlankNullSequence instead of BlankSequence) – John Nov 09 '12 at 21:06

Leonid Shifrin · Answer 2 · 2012-05-18T23:12:49.307

This is reasonably performant, but top-level:

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

ff[data_] := ff[{}, toLinkedList@data];
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]

score 3 · Answer 3 · answered May 19 '12 at 08:29

3

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
  ]

answered May 19 '12 at 08:29

mef

1,629
11
15

kglr · Answer 4 · 2012-05-22T07:43:04.730

3

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

edited May 22 '12 at 07:43

answered May 22 '12 at 06:39

kglr

394,356
18
477
896

The (Prepend[#, 0] - Append[#, 0]) & can be replaced with ListCorrelate[{1, -1}, #, {-1, 1}, 0] &, among other things... – J. M.'s missing motivation May 22 '12 at 06:45
@J.M. good point! Thanks! – kglr May 22 '12 at 06: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]; – J. M.'s missing motivation May 22 '12 at 06:58
Thank you again, @J.M.! Just added the fix and alternative specs for the selector array inside Pick that you suggested. – kglr May 22 '12 at 07:21

score 1 · Answer 5 · answered Dec 13 '23 at 00:08

1

Using SequenceReplace (new in 11.3)

list = {2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0};
SequenceReplace[list, {a_, b_, c_} /; a < b > c :> 
  Sequence[(a + b)/2, (a + b)/2, c]]

{2, 2, 7/2, 7/2, 3, 3, 9/2, 9/2, 1, 1, 1, 0}

answered Dec 13 '23 at 00:08

eldo

67,911
5
60
168

E. Chan-López · Answer 6 · 2023-12-13T05:25:38.113

Using ReplacePart, SequencePosition and SequenceCases:

list = {2, 2, 2, 5, 3, 3, 3, 6, 1, 1, 1, 0};
pos[l_List] := Map[List /@ Extract[Map[Range @@ # &, 
               SequencePosition[l, {a_, b_, c_} /; a < b > c]], 
               {All, #}] &, Range[2]]
patt[l_List] := Array[SequenceCases[#, {a_, b_, c_} /; a < b > c :> Mean[{a, b}]]
                &@l &, Length[pos[l]]]
reparray[l_List] := {pos[l], patt[l]};
rep[l_List] := Catenate@MapThread[Thread@Rule[#1, #2] &, reparray[l]]
ReplacePart[#, rep[#]] &@list
({2, 2, 7/2, 7/2, 3, 3, 9/2, 9/2, 1, 1, 1, 0})

E. Chan-López · Answer 7 · 2023-12-13T14:55:55.573

Here is a procedural version following @mef's idea, but using Reap and Sow:

 trimPeaks[data_] := Module[{l = data},
    Part[
            Reap[
                Do[
                    If[
                        Inequality[Part[l, i - 1],
                                Less,
                                l[[i]],
                                Greater,
                                Part[l, i + 1]
                            ],
                        Sow[Mean[{Part[l, i - 1], l[[i]]}]];
                        Part[l, {i - 1, i}] = Mean[{Part[l, i - 1], l[[i]]}];
                    ],
                    {i, 2, Length[l] - 1}
                ]
            ],
            2, 1
        ];
    l
   ];
trimPeaks[list]
({2, 2, 7/2, 7/2, 3, 3, 9/2, 9/2, 1, 1, 1, 0})

Leveling peaks in list

7 Answers7

Linked