17

I want to delete an array of elements from another one, DeleteCases seems to be an option, but the problem is that it deletes an element more than once if available, I do not want this. I want to delete any element as many times as available in second list.

For example DeleteCases[{1, 1, 2, 3}, Alternatives@@{1, 2}] gives {3}, which means it deleted 1 twice from the first array. I want the output to be {1, 3}. Is there any function other than DeleteCases which can do this?

Alexey Popkov
  • 61,809
  • 7
  • 149
  • 368
user49535
  • 1,225
  • 6
  • 9

9 Answers9

14

You can Fold the four-argument form of DeleteCases:

Fold[DeleteCases[##, 1, 1] &, {1, 1, 2, 3}, {1, 2}]

{1, 3}

Fold[DeleteCases[##, 1, 1] &, {3, 1, 1, 2, 1}, {1, 2}]

{3, 1, 1}

To handle arbitrary number of lists as input we can Fold twice:

ClearAll[unsortedMultiSetComplement]
unsortedMultiSetComplement = Fold[Fold[DeleteCases[##, 1, 1] &, ##] &, {##}] &;

Examples:

unsortedMultiSetComplement[{1, 1, 2, 3}, {1, 2}]

{1, 3}

unsortedMultiSetComplement[{3, 1, 1, 2, 1}, {1, 2}]

{3, 1, 1}

unsortedMultiSetComplement[{2, 3, 1, 1, 2, 5, 2, 2, 1}, {1, 2}, {2}]

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

unsortedMultiSetComplement[foo[c, a, c, a, a, b], foo[c, b], foo[b, b, a]]

foo[c, a, a]

unsortedMultiSetComplement[foo[c, a, c, a, a, b], bar[c, b], buz[b, b, a]]

foo[c, a, a]

kglr
  • 394,356
  • 18
  • 477
  • 896
10

Another option which is based on an update:

Since 13.1 we have a new built-in arrow in our quivers called DeleteElements

With the list of the OP

l={1, 1, 2, 3};

we simply write

DeleteElements[l, {1, 1} -> {1, 2}]

res

The above is simply telling Mathematica to remove up to one instance of 1 and up to one instance of 2 from the list l.

Edit: many thanks to @lericr

In this example, the command can be written using the shorter

DeleteElements[{1, 1, 2, 3}, 1 -> {1, 2}]
bmf
  • 15,157
  • 2
  • 26
  • 63
8

You can use the ResourceFunction MultisetComplement to do this:

ResourceFunction["MultisetComplement"][{1, 1, 2, 3}, {1, 2}]

{1, 3}

Carl Woll
  • 130,679
  • 6
  • 243
  • 355
5

Maybe it's worth mentionning that Replace and ReplaceAll does the replacement only once on the whole expression matching the pattern.

So one can do this kind of thing :

Replace[{1, 1, 2, 3}, {a___, 1, b___} -> {a, b}]

{1,2,3}

Notes :

  • the default level specification for Replace is {0}

  • "once on the whole expression matching the pattern" is intended to explain why Replace[{1, 1, 2, 3}, 1 -> Nothing, {1}]doesn't work.

andre314
  • 18,474
  • 1
  • 36
  • 69
  • Replace[{1, 1, 2, 3}, 1 -> Nothing, {1}] does work and returns {2, 3}, as expected. Probably you mean Replace[{1, 1, 2, 3}, 1 -> Nothing], where the pattern doesn't match (as expected). – Alexey Popkov Dec 23 '19 at 06:11
  • @AlexeyPopkov In my answer, I mean : "doesn't work" to solve OP's problem. I totally agree that Replace[{1,1,2,3},1-> Nothing] works as expected. I will rephrase my answer this evening. By the way I'm not satisfied with the expression "Once ... pattern". If someone has a better and non ambiguous phrasing, I'm interested (I remember that I found even the documentation from Wolfram not clear about the scope of the word "Once". It was many, many years ago...) – andre314 Dec 23 '19 at 06:52
  • It would be more correct to write "ReplaceAll apples a replacement rule only once on a (sub)expression matching the pattern, and never checks this (sub)expression for matching again." and remove mentioning of Replace from this statement, because Replace works differently: for example, check Replace[{{},{}},{___}->1,{0,-1}]. But I would remove this statement at all, because it isn't related to your answer. Regarding your answer, it is worth to say that Replace (unlike ReplaceList) returns only the result of the first possible match. – Alexey Popkov Dec 23 '19 at 07:14
  • It is also worth to mention that for expression patterns the default is Shortest instead of Longest. This is crucially important for your solution. – Alexey Popkov Dec 23 '19 at 07:19
5

You may use Tally with DeleteCases in Fold to only fold once per value.

Fold[DeleteCases[#1, First@#2, 1, Last@#2] &, {1, 1, 2, 3}, Tally@{1, 2}]

{1, 3}

Hope this helps.

Edmund
  • 42,267
  • 3
  • 51
  • 143
4

Using SubsetReplace:

SubsetReplace[{1, 1, 2, 3}, {1, 2} -> Nothing, 1]
(*{1, 3}*)
SubsetReplace[{3, 1, 1, 2, 1}, {1, 2} -> Nothing, 1]
(*{3, 1, 1}*)
SubsetReplace[{2, 3, 1, 1, 2, 5, 2, 2, 1}, {1, 2} -> Nothing, 1]
(*{3, 1, 2, 5, 2, 2, 1}*)

Or using SubsetPosition and Delete:

delElems[list_List, sublist_List] := 
Delete[list, Transpose@SubsetPosition[list, sublist, 1]]
(*Inspired by Syed's work*)

Examples:

delElems[{1, 1, 2, 3}, {1, 2}]
(*{1, 3}*)
delElems[{3, 1, 1, 2, 1}, {1, 2}]
(*{3, 1, 1}*)
delElems[{2, 3, 1, 1, 2, 5, 2, 2, 1}, {1, 2}]
(*{3, 1, 2, 5, 2, 2, 1}*)
delElems[{{-1, 0, 1, 0}, {0, 1, 0, 1}, {1, 0, 1, 0}, {0, 0, 0, 0}}, {{0, 0, 0, 0}}]
(*{{-1, 0, 1, 0}, {0, 1, 0, 1}, {1, 0, 1, 0}}*)
delElems[{b, c, a, a, b, e, b, b, a}, {a, b}]
(*{c, a, b, e, b, b, a}*)

Now there are ten ways to do it.

E. Chan-López
  • 23,117
  • 3
  • 21
  • 44
3

Another approach is to use explicit iterators in Condition:

Module[{n=1,k=1}, Replace[{1, 1, 2, 3, 2}, {1 :> Nothing/; n++ == 1, 2 :> Nothing/; k++ == 1},{1}]]

{1, 3, 2}
Alexey Popkov
  • 61,809
  • 7
  • 149
  • 368
3

Using Delete:

delElems[k_List, del_List] := 
 Delete[k, 
  Flatten[#, 1] &@(Position[k, First@#, 1, Last@#] & /@ Tally[del])
  ]

Usage:

delElems[{1, 1, 2, 3}, {1, 2}]

{1, 3}

delElems[{3, 1, 1, 2, 1}, {1, 2}]

{3, 1, 1}

delElems[{2, 3, 1, 1, 2, 5, 2, 2, 1}, {1, 2}]

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

Syed
  • 52,495
  • 4
  • 30
  • 85
2

use a counter solve this

cnt = {1,2} // Tally // Map[Apply[Rule]] // Association;
data = {1, 1, 2, 3};
Table[
  Which[
    KeyExistsQ[i][cnt] && cnt[i] > 0, cnt[i]--;, (*remove it*)
    KeyExistsQ[i][cnt] && cnt[i] === 0, Sow[i];, (*if needless to remove*)
    !KeyExistsQ[i][cnt], Sow[i];(*others*)
   ] 
 ,{i, data}
]//Reap//Last//First
AsukaMinato
  • 9,758
  • 1
  • 14
  • 40