# Comparing elements of a set and deleting elements based on a criterion

I have a function that has two inputs. The first input is a set of 2-element sets, and the second input is a single 2-element set. My function complements each 2-element set with the second 2-element set and gives me the outputs.

LQ[ls1_, ls2_]:=Table[Complement[ls1[[i]], ls2], {i, 1, Length[ls1]}]


As an example,

LQ[{{3, 4}, {4, 5}, {5, 6}, {1, 5}, {4, 6}, {2, 6}}, {1, 2}]


returns

{{3, 4}, {4, 5}, {5, 6}, {5}, {4, 6}, {6}}


This is precisely what I want, but the next step I can't figure out. I now need to delete from this set all the 2-element sets that share an element with any 1-element sets that are present. In particular, I need the above set to become

{{3,4},{5},{6}}


I've tried many things with little/no success. As a matter of fact, I don't even really need to know the final set, instead, I just need to know whether there are any 2-element sets remaining when the process is finished.

Any help would be appreciated. Thanks.

• How large are the lists going to be? The existing answers will get slow on large list
– ciao
Commented Apr 9, 2015 at 20:54

Composition[
With[{single = Alternatives @@ Cases[#, {x_} :> x]},
DeleteCases[#, x : {_, _} /; MemberQ[x, single]]] &
,
DeleteCases[#, Alternatives @@ #2, 2] &  (*this is LQ*)
][{{3, 4}, {4, 5}, {5, 6}, {1, 5}, {4, 6}, {2, 6}}, {1, 2}]

{{3, 4}, {5}, {6}}


or we can modify last function to only check if anything is left:

Composition[
With[{single = Alternatives @@ Cases[#, {x_} :> x]},
MemberQ[#, x : {_, _} /; FreeQ[x, single]]] &,
DeleteCases[#, Alternatives @@ #2, 2] &  (*this is LQ*)
][{{3, 4}, {4, 5}, {5, 6}, {1, 5}, {4, 6}, {2, 6}}, {1, 2}]

True

• This seems to work with my examples. Just one of these days, I'd like to write something that ends up looking at least a little bit like what some of you guys come up with. Thanks! Commented Apr 9, 2015 at 20:37
• @Trevor Come here more often and try to fight with questions people are asking. It's the best way to learn. :)
– Kuba
Commented Apr 9, 2015 at 20:50
ls3 = LQ[{{3, 4}, {4, 5}, {5, 6}, {1, 5}, {4, 6}, {2, 6}}, {1, 2}]
(* {{3, 4}, {4, 5}, {5, 6}, {5}, {4, 6}, {6}} *)

Join[Pick[#2, Function[{x}, FreeQ[x, Alternatives @@ Flatten[#]]] /@ #2], #] & @@
GatherBy[Sort@ls3, Length]
(* {{3, 4}, {5}, {6}} *)


or

Join[Select[#2, Function[{x}, FreeQ[x, Alternatives @@ Flatten[#1]]]], #1] & @@
GatherBy[Sort@ls3, Length]
(* {{3, 4}, {5}, {6}} *)


I just need to know whether there are any 2-element sets remaining when the process is finished

Or @@ Function[{x}, FreeQ[x, Alternatives @@ Flatten[#]]] /@ #2 & @@
GatherBy[Sort@ls3, Length]
(* True *)

• There are many commands in there that I've never used, so it would take me a while to parse it and process everything. However, when I change up the inputs, I do get something erroneous. In particular, if I change {1,2} to {3,5}, LQ gives {{4}, {4}, {6}, {1}, {4, 6}, {2, 6}} and the end result should delete the {4,6} and {2,6} because of the singleton {6}, but those don't get deleted (at least in the first two versions. I just saw the third version.) Commented Apr 9, 2015 at 20:35
• @Trevor, i updated with a fix for the issue.
– kglr
Commented Apr 9, 2015 at 20:44
f[u_, v_] := Complement[#, v] & /@ u
g[u_] := With[{d = GatherBy[u, Length@# == 1 &]},
{a, b} = d;
Pick[a, FreeQ[#, Alternatives @@ Flatten[b]] & /@ a]~Join~b]


So,

test = {{3, 4}, {4, 5}, {5, 6}, {1, 5}, {4, 6}, {2, 6}};
g[f[test, {1, 2}]]


gives:

{{3, 4}, {5}, {6}}


or

cf[u_, v_] := Composition[g, f[#, v] &][u]


so cf[test,{1,2}]