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.

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.

share|improve this question
    
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
add comment

4 Answers 4

up vote 7 down vote accepted
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.

share|improve this answer
    
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 –  belisarius May 18 '12 at 23:05
    
@John Please see edit –  belisarius May 18 '12 at 23:28
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 –  belisarius May 28 '12 at 0:05
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]] ? –  belisarius Nov 9 '12 at 18:33
show 9 more comments

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]
share|improve this answer
add comment

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
  ]
share|improve this answer
add comment
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])
share|improve this answer
    
The (Prepend[#, 0] - Append[#, 0]) & can be replaced with ListCorrelate[{1, -1}, #, {-1, 1}, 0] &, among other things... –  J. M. 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]; –  J. M. 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
add comment

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.