Removing duplicates between sublists

I want do delete from each sublist those elements which are contained in one or more of the other sublists. The surviving elements must maintain their original order of appearance.

list = {{6, 6, 4, 1, 7}, {1, 1}, {3, 1, 7, 2, 3, 7}, {-1}};


Expected result:

{{6, 6, 4}, {}, {3, 2, 3}, {-1}}


UniqueElements, released with with V 13.1, came to my mind,

UniqueElements[list]


{{6, 4}, {}, {3, 2}, {-1}}

but it also removes duplicates inside the sublists, and I didn't find a presentable way to overcome this.

How could a functional solution look like?

8 Answers

Something along these lines maybe?

MapThread[Cases[#1, Alternatives @@ #2] &, {list, UniqueElements[list]}]


Or

MapIndexed[Select[#1, Function[{x}, FreeQ[Delete[list, #2], x]]] &, list]


Or

Nevermind, @kglr beat me to the DeleteCases strategy.

• Acceptance is for the MapThread-solution - and thanks to everybody
– eldo
Commented Sep 16, 2023 at 15:03
uniqueToParentList =
MapIndexed[DeleteCases[Alternatives @@ Flatten @ Drop[list, #2]] @ # &];

uniqueToParentList @ list

{{6, 6, 4}, {}, {3, 2, 3}, {-1}}

uniqueToParentList2 = MapIndexed[DeleteElements[#, Flatten@Drop[list, #2]] &]

uniqueToParentList2 @ list

{{6, 6, 4}, {}, {3, 2, 3}, {-1}}


Probably much more mathematica-like ways to do this. I think using MemberQ as a test could be slow but I am not sure on this.

l = Length@list;
uE = UniqueElements[list];

Table[Select[list[[i]], MemberQ[uE[[i]], #] == True &], {i, l}]
(*{{6, 6, 4}, {}, {3, 2, 3}, {-1}}*)


Clear["Global*"];
list = {{6, 6, 4, 1, 7}, {1, 1}, {3, 1, 7, 2, 3, 7}, {-1}};

sf[k_List, excl_List] := Select[k, FreeQ[excl, #] &]

sf @@@ ({Flatten@First@#, Union @@ Last@#} & /@
Table[TakeDrop[list, {i, i}], {i, Length@list}])


Using ReplaceList:

ReplaceList[list, {g___, x_, h___} :> sf @@ {x, Union @@ {g, h}}]


Result

{{6, 6, 4}, {}, {3, 2, 3}, {-1}}

f = x |-> Select[First@x, FreeQ[Flatten@Rest@x, #] &];
f[RotateLeft[list, #]] & /@ Range[0, Length@list - 1]
(*{{6, 6, 4}, {}, {3, 2, 3}, {-1}}*)

MapApply[DeleteElements[#1,Flatten[{##2}]]&]@NestList[RotateLeft,
#,Length@#-1]&@list

(* {{6,6,4},{},{3,2,3},{-1}}


or

MapApply[DeleteElements[Catenate@#1,Flatten@#2]&]@Function[x,
TakeDrop[x,{#}]&/@Range@Length@x]@list

(* {{6,6,4},{},{3,2,3},{-1}} *)


First, you can use Subsets, Intersection and DeleteDuplicates to find all excluded numbers, accordingly with your particular condition:

f = DeleteDuplicates[Sequence @@@ Map[Intersection[#[[1]],
#[[2]]] &, Subsets[#, {2}]]] &;


Finally, using ReplacePart:

ReplacePart[#, Position[#, Alternatives @@ f@#] &@# -> Nothing] &@list

(*{{6, 6, 4}, {}, {3, 2, 3}, {-1}}*)


A variant of 1066's answer

list = {{6, 6, 4, 1, 7}, {1, 1}, {3, 1, 7, 2, 3, 7}, {-1}};

MapApply[DeleteElements[#1, Union[##2]] &] @
Table[RotateLeft[list, n], {n, 0, Length[list] - 1}]
`

{{6, 6, 4}, {}, {3, 2, 3}, {-1}}