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$
  • $\begingroup$ How large are the lists going to be? The existing answers will get slow on large list $\endgroup$ – ciao Apr 9 '15 at 20:54
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$
  • $\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 Apr 9 '15 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 Apr 9 '15 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$
  • $\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 Apr 9 '15 at 20:35
  • $\begingroup$ @Trevor, i updated with a fix for the issue. $\endgroup$ – kglr Apr 9 '15 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, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.