How to find longest monotonic sequence?

Question

I have a list, for example

list = {2, 1, 3, 5, 4, 6}

How to find longest ascending sequence of this list?

There are two meanings of this question:

1. Find the largest subset that $$ X_{i_1} < X_{i_2} < \ldots < X_{i_{n-1}} < X_{i_n} $$ where $$ i_1 < i_2 < \ldots < i_{n-1} < i_n $$

2. Find the largest subsequence that

   $$ X_i < X_{i+1} < \ldots < X_{j-1} < X_{j} $$

Answer 1

Question 1

LongestAscendingSequence was an undocumented in symbol in M10.1 and earlier, and has been removed as of M10.2+. In M10.2 the symbol LongestOrderedSequence was added, but it's functionality is slightly different. So, I thought it might be helpful to provide an answer to part 1 of this question that works in M10.2+.

The main difference between the two functions is that LongestAscendingSequence returned a strictly ascending sequence, while LongestOrderedSequence returns a non-descending sequence. In other words, LongestOrderedSequence includes duplicates, while LongestAscendingSequence did not. One possibility is to define a new LongestAscendingSequence using LongestCommonSequence:

LongestAscendingSequenceSlow[list_] := LongestCommonSequence[list, Union[list]]

However, this is rather slow:

list = RandomInteger[10^6, 10^6];
LongestAscendingSequenceSlow[list]; //AbsoluteTiming

{1.39408, Null}

On the other hand, it is possible to use LongestOrderedSequence to produce a much faster version:

LongestAscendingSequence[list_] := Which[
    Developer`PackedArrayQ[list, Real],
    LongestOrderedSequence[Transpose[{list, -1. Range @ Length @ list}]][[All, 1]],

    True,
    LongestOrderedSequence[Transpose[{list, - Range @ Length @ list}]][[All, 1]]
]

And here is a speed comparison:

r1 = LongestAscendingSequenceSlow[list]; //AbsoluteTiming
r2 = LongestAscendingSequence[list]; //AbsoluteTiming

Length @ r1 === Length @ r2

{1.40971, Null}

{0.098286, Null}

True

Question 2

Now, it is also possible to speed up the second question as follows:

longestAscendingSubsequence[list_] := With[
    {diff=SparseArray[Differences[-list]//UnitStep]},
    {nzp=Flatten @ diff["NonzeroPositions"]},
    {runs=Differences[nzp]},
    {ord=1+Length[runs]-First@Ordering[Reverse@runs,-1]},

    Take[list, nzp[[ord]] + {1, runs[[ord]]}]
]

(I used the new form of With above, although its syntax coloring is completely wrong). A comparison with longest1 and longest2 (I didn't compare @JacobAkkerboom's function because it is designed to work for integers):

SeedRandom[0];
list = RandomReal[NormalDistribution[], 1000000];

longest1[list] //AbsoluteTiming
longest2[list] //AbsoluteTiming
longestAscendingSubsequence[list] //AbsoluteTiming

{0.504056, {-2.34409, -1.21854, -0.951283, -0.873138, -0.744772, -0.157809, 0.380566, 1.36488, 1.65743}}

{0.096426, {-2.34409, -1.21854, -0.951283, -0.873138, -0.744772, -0.157809, 0.380566, 1.36488, 1.65743}}

{0.035699, {-2.34409, -1.21854, -0.951283, -0.873138, -0.744772, -0.157809, 0.380566, 1.36488, 1.65743}}

Finally, note that longest2 doesn't work correctly if there are duplicate points:

longest1[{1., 1., 1., 1., 2., 2., 2.}]
longest2[{1., 1., 1., 1., 2., 2., 2.}]
longestAscendingSubsequence[{1., 1., 1., 1., 2., 2., 2.}]

{1., 2.}

{1., 1., 1., 1., 2., 2., 2.}

{1., 2.}

Answer 2

1. There is an undocumented function LongestAscendingSequence

   LongestAscendingSequence[list]
   

   {1, 3, 4, 6}
   

   This was mentioned here and here in comments. I hope it will not be treated as a duplicate. I think Q&A-style on SE is more appropriate for this question.

2. For completeness I ask the second question. It seem to be much simpler but I can't find any simple function. My own answer:

   longest1[list_] := #[[Position[#, Max[#]][[1, 1]] &[Length /@ #]]] &@ Split[list, Less];
   longest2[list_] := list[[#2 - # ;; #2 &[Max[#], Position[#, Max[#]][[1, 1]]] &@
       FoldList[(#1 + #2) #2 &, 0, UnitStep@Differences[list]]]];
   
   longest1[list]
   longest2[list]
   

   {1, 3, 5}
   {1, 3, 5}
   

   longest2 is faster for big lists:

   RandomSeed[0];
   list = RandomReal[NormalDistribution[], 1000000];
   
   longest1[list] // AbsoluteTiming
   longest2[list] // AbsoluteTiming
   

   {0.925531, {-2.15449, -1.60199, -0.903194, -0.678062, -0.294706, 
      -0.270457, 0.219321, 0.677958, 1.07586}}
   {0.228277, {-2.15449, -1.60199, -0.903194, -0.678062, -0.294706, 
      -0.270457, 0.219321, 0.677958, 1.07586}}
   

Answer 3

Regarding question 2, there's simple algorithm finding longest sub-sequence, of elements with consecutive positions, in single pass over given list.

Function generator returning compiled functions, using this algorithm, can look like this:

compileLongestAscSubseq // ClearAll
compileLongestAscSubseq[
  {type_, rank_Integer /; rank >= 1},
  comparisonFunc : Except@OptionsPattern[] : Less,
  opts : OptionsPattern@Compile
] := Compile[{{list, type, rank}},
  Module[{start, end, bestStart, bestEnd, len, prev, curr},
    len = 0;
    start = end = bestStart = bestEnd = 1;
    prev = Compile`GetElement[list, 1];
    Do[
      curr = Compile`GetElement[list, i];
      If[comparisonFunc[prev, curr],
        end = i;
      (* else *),
        If[len < end - start,
          bestStart = start;
          bestEnd = end;
          len = bestEnd - bestStart;
        ];
        start = end = i
      ];
      prev = curr
      ,
      {i, 2, Length@list}
    ];
    If[len < end - start,
      bestStart = start;
      bestEnd = end
    ];
    Take[list, {bestStart, bestEnd}]
  ],
  opts
]

Let's compile functions taking one-dimensional arrays of integers and reals:

longestAscSubseqI1 = compileLongestAscSubseq[{_Integer, 1}, CompilationTarget -> "C", RuntimeOptions -> "Speed"];
longestAscSubseqR1 = compileLongestAscSubseq[{_Real, 1}, CompilationTarget -> "C", RuntimeOptions -> "Speed"];

Comparison with Jacob Akkerboom's longestAscendingSeq and Carl Woll's longestAscendingSubsequence on list of integers:

SeedRandom@0;
list = RandomInteger[10^6, 10^6];

(result1 = longestAscendingSeq@list) // MaxMemoryUsed // RepeatedTiming
(result2 = longestAscendingSubsequence@list) // MaxMemoryUsed // RepeatedTiming
(result3 = longestAscSubseqI1@list) // MaxMemoryUsed // RepeatedTiming
result1 === result2 === result3
(* {0.041, 16505016} *)
(* {0.051, 25128960} *)
(* {0.0038, 584} *)
(* True *)

longestAscSubseqI1 is over ten times faster and uses almost no additional memory.

Comparison with ybeltukov's longest1 and longest2 and Carl Woll's longestAscendingSubsequence on list of reals:

SeedRandom@0;
list = RandomReal[NormalDistribution[], 10^6];

(result1 = longest1@list) // MaxMemoryUsed // RepeatedTiming
(result2 = longest2@list) // MaxMemoryUsed // RepeatedTiming
(result3 = longestAscendingSubsequence@list) // MaxMemoryUsed // RepeatedTiming
(result4 = longestAscSubseqR1@list) // MaxMemoryUsed // RepeatedTiming
result1 === result2 === result3 === result4
(* {0.467, 79999584} *)
(* {0.12, 48000904} *)
(* {0.056, 25131104} *)
(* {0.0051, 608} *)
(* True *)

longestAscSubseqR1 is over ten times faster than longestAscendingSubsequence and uses almost no additional memory.

Answer 4

I suppose it is faster to put everything into one compiled function, but here is a solution using Compile.

cfu = Compile[
  {{ints, _Integer, 1}},
  Block[{prev, next, startSeq, bag},

   startSeq = ints[[1]];
   prev = startSeq;
   bag = Internal`Bag[{1}];
   Do[
    next = ints[[ii]];
    If[
     next < prev,
     Internal`StuffBag[bag, ii];
     ];
    prev = next
    ,
    {ii, 2, Length@ints}
    ];
   Internal`BagPart[bag, All]
   ]
  ,
  CompilationTarget -> "C"
  ]

longestAscendingSeq[list_] :=
 Module[{starts, diffs, maxDiff, maxDiffPos, longestStart},
  starts = cfu[list];
  diffs = Differences@starts;
  maxDiff = Max@diffs;
  maxDiffPos = Position[diffs, maxDiff][[1, 1]];
  longestStart = starts[[maxDiffPos]];
  list[[longestStart ;; longestStart + maxDiff - 1]]
  ]

This gives

longestAscendingSeq[list]

{1,3,5}