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?
$\endgroup$
5
  • 1
    $\begingroup$ Why does DeleteAbove[{8,8},3] give the empty set? $\endgroup$
    – user1066
    Sep 26, 2023 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, 2023 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, 2023 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, 2023 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$ Sep 28, 2023 at 12:12

8 Answers 8

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} *) 
$\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}
$\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, 2023 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}}

$\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}]
$\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*)
$\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"}
$\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}
$\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"}
$\endgroup$

Your Answer

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

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