5
$\begingroup$

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.

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

$\endgroup$
  • $\begingroup$ Thanks. Like my suggestion your approach is limited to two peaks. I would like Mathematica identify the number of peaks on its own. $\endgroup$ – John May 18 '12 at 23:00
  • 5
    $\begingroup$ @John Please post all your requirements on your question $\endgroup$ – Dr. belisarius May 18 '12 at 23:05
  • $\begingroup$ @John Please see edit $\endgroup$ – Dr. belisarius May 18 '12 at 23:28
  • 2
    $\begingroup$ @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 $\endgroup$ – Dr. belisarius May 28 '12 at 0:05
  • 1
    $\begingroup$ @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]] ? $\endgroup$ – Dr. belisarius Nov 9 '12 at 18:33
7
$\begingroup$

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]
$\endgroup$
3
$\begingroup$

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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