4
$\begingroup$

I have a list, say {10,9,8,7,2,3,5,4,3,2,1}

What I want to achieve is to delete the elements that are not in decreasing order recursively. Namely, the output should be {10,9,8,7,5,4,3,2,1}, which deletes {2,3} in the list.

I am seeking some elegant and efficient way to do so. Naively, I have thought about these methods:

  1. Using a loop and starting from the first element, compare the current element with the next element. Remove the current if current < next, and move the pointer to the previous element. Do it recursively until the next is smaller than the current. Clearly, this is a procedural programming which is not preferable in Mathematica.

  2. Using Nest[]. First do Difference[list] and remove all the positive elements. Update list and do it recursively until the Difference[list] are all negative.

  3. Using Nest[] and find the minimal peaks in the list, delete the peak step by step.

All these methods use loops or Nest and hence are not very efficient. I am wondering if there is a built-in function that can do this efficiently.

$\endgroup$
  • $\begingroup$ I don't think that there is a built-in method for this specific task. But this one is reasonably simple, isn't it? FixedPoint[Delete[#, Position[Differences[#], _?Positive]] &, #] &? $\endgroup$ – Henrik Schumacher May 24 '18 at 17:47
  • $\begingroup$ Well, this seems faster than loop or nest. $\endgroup$ – Jake Pan May 24 '18 at 17:58
  • $\begingroup$ @JakePan - what would you like the output for a list like {10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1} to be? $\endgroup$ – Jason B. May 24 '18 at 18:02
  • $\begingroup$ @JasonB. Should be {12, 8, 7, 5, 4, 3, 2, 1} $\endgroup$ – Jake Pan May 24 '18 at 18:13
3
$\begingroup$
list = {10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1};
list //. {a___, b_, c_, d___} /; c > b -> {a, c, d}
(* {12, 8, 7, 5, 4, 3, 2, 1} *)
FixedPoint[Pick[#, Append[UnitStep[Differences[#]], 0], 0] &, list]
(* same output, slightly faster *)
Reverse@DeleteDuplicates[Reverse@list, Greater]
(* same output, slightly faster *)

Also, (a comment by Henrik Schumacher),

FixedPoint[Delete[#, Position[Differences[#], _?Positive]] &, #] &@list
(* same output *)

and (a comment by chuy)

list //. {x___, PatternSequence[a_, b_] /; (a < b), y___} :> {x, b, y}
(* same output *)
$\endgroup$
  • $\begingroup$ ReplaceRepeated[{x___, PatternSequence[a_, b_] /; (a < b) , y___} :> {x, b, y}]@list as well. $\endgroup$ – chuy May 24 '18 at 19:10
5
$\begingroup$

It looks like you want the longest descending sequence starting with the max value. I think the following will do what you want:

descendingSequence[list_] := LongestOrderedSequence[
    list[[First @ Ordering[list,-1] ;; ]],
    Greater
]

Examples:

descendingSequence[{10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1}]
descendingSequence[{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1}]

{10, 9, 8, 7, 5, 4, 3, 2, 1}

{12, 8, 7, 5, 4, 3, 2, 1}

$\endgroup$
  • $\begingroup$ Although you're probably right and the OP might actually really want something related to the LIS, that is not quite what is described in the original question. For example, take {10, 9, 8, 7, 6, 7, 8, 7, 6, 7} Then your solution yields {10,9,8,7,6} whereas the original procedure gives {10,9,8,8,7,7} . Note that this is not solved simply changing Greater -> GreaterEqual, which would then yield {10,9,8,7,7,7,7} $\endgroup$ – Fidel I. Schaposnik Jun 8 '18 at 14:46
2
$\begingroup$
f1 = FixedPoint[SequenceReplace[#, {a_, b_} /; Less[a, b] :> b] &, #] &;

And a faster variation of AccidentalFourierTransform's second method:

f2 = Reverse @ DeleteDuplicates[FoldList[Max, Reverse @ #]]&;

f1[{10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1}]

{10, 9, 8, 7, 5, 4, 3, 2, 1}

f1[{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1}]

{12, 8, 7, 5, 4, 3, 2, 1}

f1[{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 15, 2, 1, 20}]

{20}

f1 @ # == f2 @ # & /@ 
{{10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1}, 
{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1} ,
{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 15, 2, 1,20} }

{True, True, True}

Note: Carl's method both produces longer lists and is faster than any of the methods posted so far (except AccidentalFourierTransform's first method).

$\endgroup$
  • $\begingroup$ Crazy man....... $\endgroup$ – yode Jun 2 '18 at 4:21
  • $\begingroup$ thank you @yode:) $\endgroup$ – kglr Jun 2 '18 at 4:24
  • $\begingroup$ i tried with a 30000 element long list. Carl's method was the first to complete the task (up to 1 order of magnitude faster than accidental's FixedPoint[Pick[]]method) $\endgroup$ – Alucard Jun 3 '18 at 15:45
  • $\begingroup$ @Alucard, it seems that it depends on how much variation there is in the input list. With SeedRandom[1]; lst1=RandomSample[Range[30000]]; First/@{RepeatedTiming[fixedPointPick[lst1];], RepeatedTiming[descendingSequence[lst1];]} I get {0.0015, 0.038}, The results are similar with lst2 = RandomInteger[100000,30000]. With lst3 = RandomInteger[100,30000]; the timings are reversed: {0.0014, 0.00015}. $\endgroup$ – kglr Jun 5 '18 at 11:30
0
$\begingroup$
FixedPoint[Delete[#, Position[ListConvolve[{-1, 1}, #], _?(# <= 0 &)]] &, list]
$\endgroup$

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.