6
$\begingroup$

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?

$\endgroup$

8 Answers 8

6
$\begingroup$

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.

$\endgroup$
1
  • $\begingroup$ Acceptance is for the MapThread-solution - and thanks to everybody $\endgroup$
    – eldo
    Commented Sep 16, 2023 at 15:03
6
$\begingroup$
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}}
$\endgroup$
4
$\begingroup$

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}}*)

$\endgroup$
4
$\begingroup$
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}}

$\endgroup$
3
$\begingroup$
f = x |-> Select[First@x, FreeQ[Flatten@Rest@x, #] &];
f[RotateLeft[list, #]] & /@ Range[0, Length@list - 1]
(*{{6, 6, 4}, {}, {3, 2, 3}, {-1}}*)
$\endgroup$
3
$\begingroup$
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}} *)
$\endgroup$
2
$\begingroup$

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}}*)
$\endgroup$
2
$\begingroup$

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}}

$\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.