Delete list elements above a certain threshold

1. Problem statement

Going from right to left, I want do delete all elements after they have occured n times. The solution I found seems to work reliably, but is rather long and uses a function, DeleteElements, which was only introduced in V 13.1.

2. Current solution

DeleteAbove[lis_, n_] /; n >= Max @ Counts @ lis := {}

DeleteAbove[lis_, n_] :=
Module[{tal, del},
tal = Select[Tally @ lis, Last[#] > n &];
del = Rule @@ ReplaceAll[{a_, b_} :> {a - n, b}] @ Reverse @ Transpose @ tal;
Reverse @ DeleteElements[Reverse @ lis, del]]


3. Examples

list = {1, 5, 5, 2, 2, 6, 4, 2, 2, 5, 8, 8, 5, 5};

DeleteAbove[list, 3]


{1, 5, 5, 2, 2, 6, 4, 2, 5, 8, 8}

DeleteAbove[{2, 2, 1, 1, 1, 8, 1}, 2]


{2, 2, 1, 1, 8}

4. Questions

• How would a nicer / shorter solution look like?
• Can this problem be solved with one of the Sequence - functions?
• Why does DeleteAbove[{8,8},3] give the empty set? Sep 26, 2023 at 9:38
• In my solution, if n is equal or higher to Max@ Counts@lis you get many failure messages . Therefore the first definition of DeleteAbove . One could replace the empty set with a message like ' n exceeds maximum element count'.
– eldo
Sep 26, 2023 at 9:49
• But if 8 only occurs twice in the list, and you want to delete above 3 occurrences, surely the output should be {8,8}? Sep 26, 2023 at 9:53
• That's a mistake in my solution: DeleteAbove[{8, 8}, 3] should give {8,8} and not a bunch of error messages or the empty set.
– eldo
Sep 26, 2023 at 9:59
• @eldo in that case surely the definition should be DeleteAbove[lis_, n_] /; n >= Max @ Counts @ lis := lis. I.e. just return the list and do nothing (the identity operation) Sep 28, 2023 at 12:12

list = {1, 5, 5, 2, 2, 6, 4, 2, 2, 5, 8, 8, 5, 5};

list[[Values@(Take[#,UpTo[3]]&/@PositionIndex[list])//Flatten//Union]]

(* {1,5,5,2,2,6,4,2,5,8,8} *)

list2={2, 2, 1, 1, 1, 8, 1}

list2[[Values@(Take[#,UpTo[2]]&/@PositionIndex[list2])//Flatten//Union]]

(* {2,2,1,1,8} *)

ClearAll[takeUpTo]
takeUpTo = Module[{$$a},$$a[_] = 0; Map[x |-> If[++$a[x] > #2, Nothing, x]]@#] &;  Examples: takeUpTo[list, 3]  {1, 5, 5, 2, 2, 6, 4, 2, 5, 8, 8}  takeUpTo[{2, 2, 1, 1, 1, 8, 1}, 2]  {2, 2, 1, 1, 8}  • I love this. I've been programming this language for so long and stuff like this still blows my mind. I just wrote a utility where I used a clunky Association with default values for tracking counts and it never occurred to me to just instantiate a symbol like you did with$a here. Sep 29, 2023 at 15:03
Clear["Global*"];
DeleteAbove[k_List, n_Integer] := Module[{
pos = Position[
MapIndexed[Count[k[[1 ;; First@#2]], #1] &, k], _?(# <= n &)]
},
Extract[k, pos]
]

lists = {{1, 5, 5, 2, 2, 6, 4, 2, 2, 5, 8, 8, 5, 5}, {2, 2, 1, 1, 1,
8, 1}, {8, 8}};
lims = {3, 2, 3};

DeleteAbove @@@ Transpose[{lists, lims}]


{{1, 5, 5, 2, 2, 6, 4, 2, 5, 8, 8}, {2, 2, 1, 1, 8}, {8, 8}}

KeepUpTo[list_, count_] :=
DeleteCases[FoldPairList[KeepUpToStep[count], <||>, list], Null];
KeepUpToStep[n_][counts_, val_] :=
If[
Lookup[counts, val, 0] < n,
{val, Merge[{counts, <|val -> 1|>}, Total]},
{Null, counts}]


I'll call my attempt RemoveByOccurrences:

RemoveExcessOccurrences[list_, element_, maxOccurrences_] :=
Module[{count = 0}, DeleteCases[list, _?(If[# == element, count++; count > maxOccurrences,
False] &)]]

RemoveByOccurrences[list_, maxOccurrences_] :=
Module[{elementCounts, elementsToDelete},
elementCounts = Tally[list];
elementsToDelete = Select[elementCounts, #[[2]] > maxOccurrences &][[All, 1]];
Fold[RemoveExcessOccurrences[#1, #2, maxOccurrences] &, list, elementsToDelete]]


Testing RemoveByOcurrences:

list = {1, 5, 5, 2, 2, 6, 4, 2, 2, 5, 8, 8, 5, 5};
res = {1, 5, 5, 2, 2, 6, 4, 2, 5, 8, 8};
list2 = {2, 2, 1, 1, 1, 8, 1};
res2 = {2, 2, 1, 1, 8};
list3 = {2, 2, 1, 1, 1, 8, 1, 5, 3, 5, 5, 3, 5};
res3 = {2, 2, 1, 1, 8, 5, 3, 5, 3};

RemoveByOccurrences[list, 3] === res

(*True*)

RemoveByOccurrences[list2, 2] === res2

(*True*)

RemoveByOccurrences[list3, 2] === res3

(*True*)

ClearAll[deleteExcessiveDuplicates]

deleteExcessiveDuplicates = Module[{$$i},$$i[_] = 0; DeleteDuplicates[#, {w, z} |-> w == z && ++$i[w] > #2]] &;  Examples: deleteExcessiveDuplicates[list, 3]  {1, 5, 5, 2, 2, 6, 4, 8, 8}  deleteExcessiveDuplicates[Alphabet[][[{2, 2, 1, 1, 1, 8, 1}]], 2]  {"b", "b", "a", "a", "h"}  ClearAll[pickUpTo] pickUpTo = Module[{$$i, mask},$$i @_ = 0; mask = # /. Except[List | _List, x_] :> ++$i[x];
Pick[#, UnitStep[#2 - mask], 1]] &;


Examples:

pickUpTo[list, 3]

{1, 5, 5, 2, 2, 6, 4, 2, 5, 8, 8}

pickUpTo[{2, 2, 1, 1, 1, 8, 1}, 2]

{2, 2, 1, 1, 8}

ClearAll[dropExcessiveDuplicates]

dropExcessiveDuplicates = Module[{$$i},$$i[_] = 0;
ReplaceAll[Except[List | _List, x_] :> If[++\$i[x] > #2, Nothing, x]] @ #] &;


Examples:

dropExcessiveDuplicates[list, 3]

{1, 5, 5, 2, 2, 6, 4, 2, 5, 8, 8}

dropExcessiveDuplicates[Alphabet[][[{2, 2, 1, 1, 1, 8, 1}]], 2]

{"b", "b", "a", "a", "h"}
`