6
$\begingroup$

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.

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

3 Answers 3

4
$\begingroup$
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
$\endgroup$
2
  • $\begingroup$ 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! $\endgroup$
    – Trevor
    Commented Apr 9, 2015 at 20:37
  • 1
    $\begingroup$ @Trevor Come here more often and try to fight with questions people are asking. It's the best way to learn. :) $\endgroup$
    – Kuba
    Commented Apr 9, 2015 at 20:50
3
$\begingroup$
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 *)
$\endgroup$
2
  • $\begingroup$ 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.) $\endgroup$
    – Trevor
    Commented Apr 9, 2015 at 20:35
  • $\begingroup$ @Trevor, i updated with a fix for the issue. $\endgroup$
    – kglr
    Commented Apr 9, 2015 at 20:44
0
$\begingroup$
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}]

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