Delete sublist when sub-sublists contain same element

Question

Given

lis={{{a},{b,c,d}},{{a,b},{b,c}},{{b,c},{a,b,c}},{{b},{d}},{{a,b},{c,d}}}

I want to delete sublists which have one or more elements in common. So that I would get

{{{a},{b,c,d}},{{b},{d}},{{a,b},{c,d}}}

Is there a way without flattening Level 3 first?

user57467, could you clarify what would be the desired output for input list lis3 = {{{a, a}, {b, c, d}}, {{a, b}, {b, c}}};? — kglr, Jan 20 '20 at 19:35

score 11 · Accepted Answer · edited Jun 16 '20 at 09:23

`Select`+ `ContainsNone`

Select[Apply[ContainsNone]]@lis

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

`Pick` + `ContainsNone`:

Pick[#, ContainsNone @@@ #] & @ lis

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

`Cases` + `ContainsNone`

Cases[{a_, b_} /; ContainsNone[a, b]]@lis

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

`DeleteCases` + `ContainsAny`

DeleteCases[{a_, b_} /; ContainsAny[a, b]]@lis

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

`DeleteCases`

DeleteCases[{{___, a_, ___}, {___, a_, ___}}] @ lis

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

Note: If either element of the sublist pairs contains duplicates, as in

lis2 = {{{a, a}, {b, c, d}}, {{a, b}, {b, c}}, {{b, c}, {a, b, c}}, 
  {{b}, {d}}, {{a, b}, {c, d}}};

then

Select[Apply[ContainsNone]] @ lis2
Pick[#, ContainsNone @@@ #] & @ lis2
Cases[{a_, b_} /; ContainsNone[a, b]] @ lis2
DeleteCases[{a_, b_} /; ContainsAny[a, b]] @ lis2
DeleteCases[{{___, a_, ___}, {___, a_, ___}}] @ lis2

all give

{{{a, a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

while the methods proposed by @Nasser and @ThatGravityGuy

Cases[lis2, {x_, y_} /; Length@Union[x, y] == (Length[x] + Length[y]) :> {x, y}]
Select[lis2, DuplicateFreeQ@*Flatten]

both give

{{{b}, {d}}, {{a, b}, {c, d}}}

You just blew my head off! Great! – user57467 Jan 21 '20 at 04:55 — user57467, Jan 21 '20 at 04:55

score 10 · Answer 2 · answered Jan 20 '20 at 06:10

10

I am sure there are many ways to do this. One possible way is to take the union of both sublists, and check if its length is same as sum of length of both sublists. Since when making union, duplicates are automatically removed.

lis = {{{a}, {b,c,d}}, {{a,b}, {b,c}}, {{b,c},{a,b,c}}, {{b},{d}}, {{a,b}, {c,d}}};

Cases[lis, {x_, y_} /; Length@Union[x, y] == (Length[x] + Length[y]) :> {x, y}]

Mathematica graphics

answered Jan 20 '20 at 06:10

Nasser

143,286
11
154
359

Good explanation for your code! – user57467 Jan 20 '20 at 06:18

NonDairyNeutrino · Answer 3 · 2020-01-20T19:47:36.733

10

Another method with DuplicateFreeQ, where @* is shorthand/infix notation for Composition.

Select[lis, DuplicateFreeQ@*Flatten]

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

Another way of really doing the exact same thing is with Pick.

Pick[lis, DuplicateFreeQ@*Flatten /@ lis]

Basically, either method picks out the elements of lis such that DuplicateFreeQ@*Flatten[elem] == True.

edited Jan 20 '20 at 19:47

answered Jan 20 '20 at 07:33

NonDairyNeutrino

7,810
1
14
29

Could you explain the code, please? What is "@*"? – user57467 Jan 20 '20 at 11:38

score 6 · Answer 4 · edited Mar 31 '23 at 05:34

(1) Pick, IntersectingQ

lis//Pick[#,MapApply[IntersectingQ,#],False]&
(* {{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}} *)

(2) Pick, Intersection

Syed has pointed out (in a comment) that the following does not work:

Pick[lis,Intersection@@@lis,{}]
(* Pick::incomp: Expressions {{{a}, {b, c, d}}, {{a, b}, {b, c}}, 
  {{b, c}, {a, b, c}}, {{b}, {d}}, {{a, b}, {c, d}}} and {{}, {b}, {b, c}, 
  {}, {}} have incompatible shapes.*)

A great explanation of how Pick works has been posted by WReach, and tracePattern defined in that post illustrates the problem very nicely:

Pick[lis,Intersection@@@lis,tracePattern[{}]]
(*
  {{}, {b}, {b, c}, {}, {}} False
  {} True
  {b} False
  Pick::incomp: Expressions {{{a}, {b, c, d}}, {{a, b}, {b, c}},
  {{b, c}, {a, b, c}}, {{b}, {d}}, {{a, b}, {c, d}}} and {{}, {b},
  {b, c}, {}, {}} have incompatible shapes.
 *)

If at any stage, as Pick recursively scans, "the lengths of the expressions are not the same then the process is aborted with the Pick::incomp message".

Intersection@@@lis
(* {{}, {b}, {b, c}, {}, {}} *)

As {b} from the selector list does not match a pattern, the situation is reached where {b} (from sel) and {a,b} (from lis) do not have the same length, and the process aborts.

The following fails for the same reason:

 Pick[lis,(MapApply[Intersection]@lis),tracePattern[_?(#==={}&)]]
(*
{{}, {b}, {b, c}, {}, {}} False
  {} True
  {b} False
  Pick::incomp: Expressions {{{a}, {b, c, d}}, {{a, b}, {b, c}}, 
  {{b, c}, {a, b, c}}, {{b}, {d}}, {{a, b}, {c, d}}} and {{}, {b}, 
  {b, c}, {}, {}} have incompatible shapes.
*)

If {b} is included in the pattern given to Pick, then {{a,b}, {b,c}} from lis with be included in the list returned by Pick (this is unwanted behaviour, of course), but the "incompatible shapes" problem is circumvented (in this instance) and, as this problem does not arise in any subsequent (recursive) steps, Pick returns a result without an error message:

Pick[lis,Intersection@@@lis,tracePattern[{}| {b}]]
(*
{{}, {b}, {b, c}, {}, {}} False
  {} True
  {b} True
  {b, c} False
  b False
  c False
  {} True
  {} True
  {{{a}, {b, c, d}}, {{a, b}, {b, c}}, {}, {{b}, {d}}, {{a, b}, 
   {c, d}}}
*)

One possible work-around

lis[[Pick[Range@Length@lis,MapApply[Intersection]@lis,{}]]]
(* {{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}} *)

Just for fun:

lis[[Pick[Range@Length@lis,MapApply[Intersection]@lis,
  tracePattern[{}]]]]
(*
{{}, {b}, {b, c}, {}, {}} False
  {} True
  {b} False
  {b, c} False
  {} True
  {} True
  {{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}
*)

Could you please say why Pick[lis,Intersection@@@lis,{}] does not work? (comment reposted after answer update. Apologies, as I accidentally deleted it). Thanks for the explanation and answer update. — Syed, Mar 31 '23 at 02:56

E. Chan-López · Answer 5 · 2023-03-31T03:33:39.283

Another way to do this is to use DeleteElements with ContainsAny or IntersectingQ as follows:

lis = {{{a}, {b, c, d}}, {{a, b}, {b, c}}, {{b, c}, {a, b, 
     c}}, {{b}, {d}}, {{a, b}, {c, d}}};
res = {{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}};

Then:

DeleteElements[lis, {a_, b_} /; ContainsAny[a, b] :> {a, b}] === res
(*True*)
DeleteElements[lis, {a_List, b_List} /; IntersectingQ[a, b] :> {a, b}] === res
(*True*)

Or using ReplaceAll and something from one of @kglr's ways to do this:

lis /. {{___, a_, ___}, {___, a_, ___}} :> {a, a} /. {a_, b_} /; a == b :> Nothing
({{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}})

score 1 · Answer 6 · answered Feb 10 '24 at 00:07

1

list = 
 {{{a}, {b, c, d}}, {{a, b}, {b, c}}, {{b, c}, {a, b, c}}, 
  {{b}, {d}}, {{a, b}, {c, d}}};

Using function deconstruction

f[x_] /; Union[Last /@ Tally @ Flatten @ x] == {1} := x
f[_] := Nothing
f /@ list

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

answered Feb 10 '24 at 00:07

eldo

67,911
5
60
168

(+1) Nice solution using Tally, @eldo! – E. Chan-López Feb 10 '24 at 00:10

score 0 · Answer 7 · answered Feb 10 '24 at 01:10

Using DisjointQ:

Clear["Global`*"];
lis = {{{a}, {b, c, d}}, {{a, b}, {b, c}}, {{b, c}, {a, b, 
     c}}, {{b}, {d}}, {{a, b}, {c, d}}};
Pick[lis, Map[Apply[DisjointQ]][lis]]

or

Select[Apply[DisjointQ]][lis]

Result:

{{{a}, {b, c, d}}, {{b}, {d}}, {{a, b}, {c, d}}}

Delete sublist when sub-sublists contain same element

7 Answers7

Select+ ContainsNone

Pick + ContainsNone:

Cases + ContainsNone

DeleteCases + ContainsAny

DeleteCases

`Select`+ `ContainsNone`

`Pick` + `ContainsNone`:

`Cases` + `ContainsNone`

`DeleteCases` + `ContainsAny`

`DeleteCases`