# Peaks, plateaus and ledges

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

• +1 Good question but just to be finnicky: Shouldn't ledges and straths and plateaus be associated with a line segment rather than a point? (And thank you to @gwr for me learning a new word: strath.)
– JimB
Sep 21 at 18:25
• The expected result should be {0, 0, 1, {2}, 2, 3, {4}, 4, {5, 5, 5}, 4, 3, {3}, 2, 2, {3}, 2, 1, 1, {2, 2}, 1},that is, the intermediate results should be {5, 5, 5}, 4, 3, {3},see my answer. Sep 21 at 21:49
• (+1) I think your question is excellent, @eldo! The answers to your question have taught me a lot. Sep 21 at 22:28
• Why do you accept an answer as the solution that does not produce the "expected result" (e.g., ledges are single points not ranges and you also asked for a simple list output)?
– gwr
Sep 23 at 13:26
• In the expected result, you've marked the ledge after the 5, 5, 5 plateau incorrectly: you've marked the first 3 in the list of numbers (... {5, 5, 5}, 4, {3}, 3, ...), but the graph has the second 3 marked, so that segment of the list should be ... {5, 5, 5}, 4, 3, {3}, ... Sep 23 at 23:55

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

{pvlPositions[list], labels, calloutpositions, colors};

lista = Fold[annotateF, list, args]


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


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

{"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

• Is it possible for you to post a solution which is MMA V12.0 compatible ? Thanks Sep 24 at 16:18
• @SigisK, I don't have access to MMA V12.0. Is there any specific part of the code above that is triggering error messages or not giving the expected result in V12.0?
– kglr
Sep 24 at 16:46
• Yes I get error messages leading to no plots at all but I managed eventually to get wirth my MMA V12.0 the same results as you by replacing all your Splice by Sequence (had to add a Flattento your Annotate functions) and rewriting your "x |-> body" by the classical Function[x,body]. Sep 25 at 16:38

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

• Please try to turn this into the expected result of  {0, 0, 1, {2}, 2, 3, {4}, 4, {5, 5, 5}, 4, {3}, 3, 2, 2, {3}, 2, 1, 1, {2, 2}, 1}; I can't do it. The problem already starts with plateaus: There are two and not only one.
– eldo
Sep 21 at 8:21
• I only see one plateau consisting of 3 or more points. Further, you can put in a bit of effort yourself to change the output. Sep 21 at 8:48
• There is a plateau of two points at the right end of the curve. Since you are not able or unwilling to give the expected result and put the blame on me instead: Why don't you delete your "answer"?
– eldo
Sep 21 at 8:54
• 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}

### 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} *)

• Ok, a bit of tweaking (e.g., Table to directly produce parsedPoints instead of While with i++ and Reap/Sow, Flatten a nested list instead of using AppendTo) and the speed (before compilation) is where I thought it should be. :)
– gwr
Sep 22 at 18:32

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

{Join[{Identity},
BlockMap[{Boole[Length@#[[2]] > 1],
Sign[Total[-Min@#[[2]] + MinMax[First /@ #]]]} &, Split[#], 3, 1] /.
`