4
$\begingroup$

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?
Improve this question
$\endgroup$
5
  • 1
    $\begingroup$ Why does DeleteAbove[{8,8},3] give the empty set? $\endgroup$
    – user1066
    Sep 26 at 9:38
  • $\begingroup$ 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'. $\endgroup$
    – eldo
    Sep 26 at 9:49
  • 1
    $\begingroup$ But if 8 only occurs twice in the list, and you want to delete above 3 occurrences, surely the output should be {8,8}? $\endgroup$
    – user1066
    Sep 26 at 9:53
  • $\begingroup$ 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. $\endgroup$
    – eldo
    Sep 26 at 9:59
  • $\begingroup$ @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) $\endgroup$
    – infinitezero
    Sep 28 at 12:12

8 Answers 8

Reset to default
4
$\begingroup$ 
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} *)
Improve this answer
$\endgroup$
5
$\begingroup$ 
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}
Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ 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. $\endgroup$
    – Searke
    Sep 29 at 15:03
3
$\begingroup$ 
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}}

Improve this answer
$\endgroup$
3
$\begingroup$ 
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}]
Improve this answer
$\endgroup$
2
$\begingroup$

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*)
Improve this answer
$\endgroup$
2
$\begingroup$ 
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"}
Improve this answer
$\endgroup$
2
$\begingroup$ 
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}
Improve this answer
$\endgroup$
1
$\begingroup$ 
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"}
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.