Peaks, plateaus and ledges

Question

I want to find the peaks, plateaus and ledges of an integer sequence, but all my attempts failed.

1. Example list

list = {0, 0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 4, 3, 3, 2, 2, 3, 2, 1, 1, 2, 2, 1};

2. Visualization of the problem

 plot = 
   {0, 0, 1, Callout[Style[2, Red], "ledge"], 2, 3, Style[4, Red], 4, 
   Callout[Style[5, Red], "plateau"], Style[5, Red], Style[5, Red], 
   4, 3, Style[3, Red], 2, 2, Callout[Style[3, Red], "peak"], 2, 1, 1, 
   Style[2, Red], Style[2, Red], 1};

ListPlot[plot, GridLines -> {None, Automatic}, Joined -> True]

3. Expected result

result = {0, 0, 1, {2}, 2, 3, {4}, 4, {5, 5, 5}, 4, {3}, 3, 2, 2, {3}, 2, 1, 1, {2, 2}, 1};

Answer 1

list = {0, 0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 4, 3, 3, 2, 2, 3, 2, 1, 1, 2, 2, 1};

Using SequencePosition with patterns that identify peaks, valleys and ledges:

Patterns

peakPattern = {a_, b_ , c_ } /; a < b > c;
plateauPattern = {a_, b_, b_ .., c_ } /; a < b > c;
valleyPattern = {a_, b_ , c_ } /; a > b < c;
strathPattern = {a_, b_, b_ .., c_ } /; a > b < c;
ascendingledgePattern = {a_, b_, b_ .., c_ } /; a < b < c;
descendingledgePattern = {a_, b_, b_ .., c_ } /; c < b < a;

patterns = {peakPattern, plateauPattern, ascendingledgePattern, 
   descendingledgePattern, valleyPattern, strathPattern};

Positions

ClearAll[pvlPositions]
pvlPositions[lst_] := Map[MapApply[Span @@ ({##} + {1, -1}) &]]@
   Map[SequencePosition[lst, #] &] @ patterns;

pvlPositions @ list

{{17 ;; 17},  
 {9 ;; 11, 21 ;; 22},   
 {4 ;; 5, 7 ;; 8},   
 {13 ;; 14},   
 {},   
 {15 ;; 16, 19 ;; 20}}

Annotations

We use the positions identified using pvlPositions with SubsetMap to add desired annotations and styling:

ClearAll[annotateF]

annotateF[lst_, {pos_, lbl_, lp_, clr_}] := 
  SubsetMap[x |-> MapAt[y |-> Callout[y, lbl], {lp}]@
     Map[z |-> Style[z, clr]]@x, lst, pos];

labels = {"peak", "plateau", "ledge", "ledge", "valley", "strath"};
colors = {Red, Orange, Gray, Gray, Blue, Green};
calloutpositions = {1, 1, 1, -1, -1, 1};

args = MapThread[Splice @ Thread[{##}] &] @
   {pvlPositions[list], labels, calloutpositions, colors};

lista = Fold[annotateF, list, args]

Show[ListPlot[lista, Joined -> True, ImageSize -> 900], ImageSize -> Large]

Answer 2

peaksValleysLedges[{{a_ ..}, m : {b_ ..}, {c_ ..}}] := Which[
 Length @ m > 1 && a < b < c, $ascendingLedge @ m, 
 Length @ m > 1 && c < b < a, $descendingLedge @ m, 
 Length @ m == 1 && a < b > c, $peak @ m,
 a < b > c , $plateau @ m, 
 Length @ m == 1 && a > b < c, $valley @ m, 
 a > b < c, $strath @ m, 
 True, Splice @ m]

We can use Split and BlockMap to identify and annotate peaks, valleys and ledges:

annotatePVL = Append[Splice @ Last @ #] @
   Prepend[Splice @ First @ #] @
   BlockMap[peaksValleysLedges, #, 3, 1] & @
   Split[#] &;
 

Example:

list = {0, 0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 4, 3, 3, 2, 2, 3, 2, 1, 1, 2, 2, 1};


annotatePVL @ list

Replace the expressions $* with desired functions to add call-outs and styles:

pvaldl = {$peak, $valley, $plateau, $strath, $ascendingLedge, $descendingLedge};

labels = Thread[pvaldl -> 
 {"peak", "valley", "plateau", "strath", "ledge", "ledge"}];

colors = {Red, Blue, Orange, Green, Gray, Cyan};

replacements = MapThread[# -> Function[x, Splice @ 
  MapAt[z |-> Callout[z, # /. labels], 
     Map[y |-> Style[y, #2]]@ x, 
     # /. {$peak | $ascendingLedge | $plateau |$strath -> {1}, _ -> {-1}}]]&] @
 {pvaldl, colors};

annotatePVL[list] /. replacements 

ListPlot[annotatePVL[list] /. replacements, 
 Joined -> True, ImageSize -> Large, PlotRangePadding -> Scaled[.1]]

ListPlot[annotatePVL[-list] /. replacements, 
 Joined -> True, ImageSize -> Large, PlotRangePadding -> Scaled[.1]]

Replace annotatePVL[list] in ListPlot[...] above with annotatePVL2[list], where

annotatePVL2 = BlockMap[peaksValleysLedges, #, 3, 1] & @
  Prepend[{#[[2, 1]]}] @ Append[{#[[-2, 1]]}] @ # & @ Split[#] &;

to get

Answer 3

The function "SequenceCases" will help here. To not only get the values, but also the positions, we expand the data by the positions:

list = {0, 0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 4, 3, 3, 2, 2, 3, 2, 1, 1, 2,
    2, 1};
d = Transpose[{Range[Length[list]], list}];

Now we can apply SequenceCases like:

plateaus =  SequenceCases[
  d, {{i_, x_}, {_, x_} .., {j_, x_}} -> {{i, x}, {j, x}}]

{{{9, 5}, {11, 5}}}

This means: there is a plateau from position 9 to 11 with value 5. Similar:

ledges =  SequenceCases[
  d, {{i_, x_}, {j_, x_}, {_, y_}} /; y > x -> {{i, x}, {j, x}}]

{{{1, 0}, {2, 0}}, {{4, 2}, {5, 2}}, {{7, 4}, {8, 4}}, {{15, 2}, {16, 
   2}}, {{19, 1}, {20, 1}}}

peaks = SequenceCases[
  d, {{_, x1_}, {i_, x2_}, {_, x3_}} /; (x2 > x1 && x2 > x3) -> {i, 
    x2}]

{{17, 3}}

Answer 4

• The idea is using the second orderDifference to calculus the three adjacent items to find the concave points.

Clear[list,boole,temp];
list = {0, 0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 4, 3, 3, 2, 2, 3, 2, 1, 1, 2,2, 1};
boole = Join[{False}, Negative@Differences[list, 2], {False}];
temp = MapThread[If[! #2, #1, List[#1]] &, {list, boole}];
result=SequenceReplace[{{x_}, a___, {x_}} /; a == x :> {x, a, x}]@temp

{0, 0, 1, {2}, 2, 3, {4}, 4, {5, 5, 5}, 4, 3, {3}, 2, 2, {3}, 2, 1, 1, {2, 2}, 1}

ListPlot[Flatten@Map[Style[#, Red] &, result, {2}], 
 Joined -> True]

• We test another data.

Clear["Global`*"];
list = {0, 0, 1, 1.1, 2, 2.2, 2.3, 4, 4.2, 5, 5, 5, 4.4, 3.2, 3, 2.1, 
   2, 2.8, 3, 2.5, 2, 1, 1, 2, 2, 1, 3, 2, 3, 2, 3, 2, 4, 2};
boole = Join[{False}, Negative@Differences[list, 2], {False}];
temp = MapThread[If[! #2, #1, List[#1]] &, {list, boole}];
result = 
 SequenceReplace[{{x_}, a___, {x_}} /; a == x :> {x, a, x}]@temp
ListPlot[Flatten@Map[Style[#, Red] &, result, {2}], Joined -> True]

{0, 0, {1}, 1.1, {2}, {2.2}, 2.3, {4}, 4.2, {5, 5, 5}, {4.4}, 3.2, {3}, 2.1, 2, {2.8}, {3}, 2.5, {2}, 1, 1, {2, 2}, 1, {3}, 2, {3}, 2, {3}, 2, {4}, 2}

Answer 5

State Machine Approach

I went about this in a classical fashion, e.g., parsing a list of values. One could see this as a state machine and we need to keep track of the states ascendingQ (movement so far has been upwards in general) and levelQ (currently we are neither ascending nor descending) as shown in the state chart below.

The transitions are almost exclusively triggered by the gradient of ascend which we will store as a list differences using Differences[list]. We will step through the list of gradients incrementing the counter i at the end of each transition-driven action (numbered arcs in the starte chart). The basic actions are given in the list below.

Whenever we mark an element or a list of candidates for ledges, plateaus or straths, we will store the corresponding elements from the list specified by the index values, i.e., l[[i]].

Implementation

The code below is now adapted to mark rising and falling ledges differently and it is rather straight forward to adapt it to whatever one needs.

list = {0, 0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 4, 3, 3, 2, 2, 3, 2, 1, 1, 2,
2, 1};

parseList[l_List] := Module[
  {
    differences = Differences @ l, 
    ledgeCandidates = {}, \
    parsedPoints,
    length = (Length @ l) - 1, 
    ascendingQ = False, 
    levelQ = False, 
    mark,
    labelFunc = Function[{elem, str}, Callout[ Style[ elem, Red], str, CalloutMarker -> "Circle"]]    
  }
  ,(* mark a list of points *)
  mark[arg_List, label_String] := With[
    {indices = Flatten @ arg},
    ledgeCandidates = {};
    Which[
      label == "RisingLedge", 
        {
          labelFunc[l[[First @ indices]], "Ledge"],
          l[[Rest @ indices]]
        },
      label == "FallingLedge",
        {
          l[[Most @ indices]],
         labelFunc[l[[Last @ indices]], "Ledge"]
        },
      True,
        labelFunc[l[[#]], label]& /@ indices
    ]
  ];
  (* mark a single point *)
  mark[arg_Integer, label_String] := labelFunc[l[[arg]], label];
  parsedPoints = Table[
    Which[
      (* levelQ and ascendingQ *)
      differences[[i]] > 0 && levelQ && ascendingQ,
      (
        levelQ = False;
        mark[ledgeCandidates, "RisingLedge"]
      )
      ,
      differences[[i]] < 0 && levelQ && ascendingQ,
      (
        levelQ = False;
        ascendingQ = False;
        mark[ledgeCandidates, "Plateau"]
      )
      ,(* levelQ and ¬ascendingQ *)
      differences[[i]] > 0 && levelQ && ¬ascendingQ,
      (
        levelQ = False;
        ascendingQ = True;
        mark[ledgeCandidates, "Strath"]
      )
      ,
      differences[[i]] < 0 && levelQ && ¬ascendingQ,
      (
        levelQ = False;
        mark[ledgeCandidates, "FallingLedge"]
      )
      ,
      differences[[i]] == 0 && levelQ
      ,
      (
        ledgeCandidates = {ledgeCandidates, {i, i + 1}};
        Nothing
      )
      ,(* ¬levelQ and ascendingQ *)
      differences[[i]] > 0 && ¬levelQ && ascendingQ,
        l[[i]]
      ,
      differences[[i]] < 0 && ¬levelQ && ascendingQ,
      (
        ascendingQ = False;
        mark[i, "Peak"]
      )
      ,(* ¬levelQ and ¬ascendingQ *)
      differences[[i]] > 0 && ¬levelQ && ¬ascendingQ,
      (
        ascendingQ = True;
        mark[i, "Valley"]
      )
      ,
      differences[[i]] < 0 && ¬levelQ && ¬ascendingQ,
        l[[i]]
      ,
      True, (* differences[[i]]==0 && ¬levelQ *)
      (
        levelQ = True;
        ledgeCandidates = {ledgeCandidates, {i, i + 1}};
        Nothing
      )
    ]
    ,
    {i, 1, length}
  ];
  (* Handle last section *) 
  parsedPoints = Flatten @ {
    parsedPoints
    ,
    Which[
      levelQ && ¬ascendingQ, mark[ledgeCandidates, "Strath"]
      ,
      levelQ && ascendingQ, mark[ledgeCandidates, "Plateau"]
      ,
      True, l[[length + 1]]
    ]
  }
]

parseList @ list // ListPlot[ #, Joined -> True, ImageSize -> Large, PlotRangePadding -> 0.5, PlotTheme -> "Detailed"]&

Requested List Output

Using pattern matching it is rather straight forward to come up with the requested list form for the output from parseList:

toListOutput = Function[ arg, arg //RightComposition[
    ReplaceAll[ Callout[val_Integer, ___]| Callout[ Style[ val_Integer,___],___]:> {val}],
    ReplaceRepeated[{a___,Longest[l:Repeated[{val_Integer}]], b___} :> {a, Flatten @ {l}, b}]
  ]
];

parseList @ list // toListOutput
(* {{0,0},1,{2},2,3,{4},4,{5,5,5,5},4,3,{3},{2,2},{3},2,{1,1},{2,2},1} *)

Performance Comparison

To test performance of different approaches, we will use a bigger list bigList. To fairly compare approaches we should compare the time it takes to come up with a result that is ready to be fed to a ListPlot or ListLinePlot.

SeedRandom["1234"];
bigList = NestList[ # + RandomInteger[{-1, 1}] &, 0, 1000 ];

RepeatedTiming[ parseList @ bigList; ]
(* {0.00395423, Null} *)

RepeatedTiming[ annotatePVL @ bigList /. replacements); ]
(* {0.0051159, Null} *)

RepeatedTiming[ pvlPositions @ bigList; ]
(* {5.83603, Null} not even ready for plotting *)

(* RepeatedTiming[ ... @ bigList; ] @vindobona's approach *)
(* {0.00395119, Null} *)

Answer 6

Assuming the adjacent elements differ only by 0 or 1:

list = {0,0,1,2,2,3,4,4,5,5,5,4,3,3,2,2,3,2,1,1,2,2,1};

Flatten@MapThread[#1 /@ #2 &, 
   {Join[{Identity}, 
     BlockMap[{Boole[Length@#[[2]] > 1], 
      Sign[Total[-Min@#[[2]] + MinMax[First /@ #]]]} &, Split[#], 3, 1] /. 
        Thread[
         Tuples[{{0, 1}, {-1, 0, 1}}] -> 
          Map[x |-> Callout[If[x != "", Style[#, Red], #], x] &
            , {"peak", "", "valley",  "plateau", "ledge", "strath"}]]
       , {Identity}]
      , Split[#]} &[list]
   ] // ListPlot[#, Joined -> True, ImageSize -> Large] &

Output