7
$\begingroup$

I have a list of pairs of observations:

{a,b}
{c,d}
{e,f}
{g,h}
{i,a}
{a,d}

I would like to flag each pair "True" if neither of its elements appear in any other pairs in the list, and "False" otherwise:

{a,b,False}
{c,d,False}
{e,f,True}
{g,h,True}
{i,a,False}
{a,d,False}

I have written inelegant code using 3 For loops that does this, but I am confident there is a better way of doing it.

$\endgroup$
  • $\begingroup$ Do any pairs have the same element twice? If not, you count how many times each element occurs in the flattened list. $\endgroup$ – mikado Oct 19 '16 at 4:48
  • $\begingroup$ yes there could be pairs like that. and I like your idea, thanks. $\endgroup$ – Suite401 Oct 19 '16 at 5:31
7
$\begingroup$

Given:

$pairs = { {a,b}, {c,d}, {e,f}, {g,h}, {i,a}, {a,d} };

We start by counting the occurrences of each element:

$counts = $pairs // Flatten // Counts

(* <| a -> 3, b -> 1, c -> 1 ,d -> 2, e -> 1, f -> 1, g -> 1, h -> 1, i -> 1 |> *)

... and then use those counts to assemble the result:

{#1, #2, $counts[#1] + $counts[#2] == 2} & @@@ $pairs

(* {{a,b,False},{c,d,False},{e,f,True},{g,h,True},{i,a,False},{a,d,False}} *)

Update

As noted in the question's comments (which I originally missed), there is the prospect that both elements of a pair could have the same value. In that case, we need to add Map[DeleteDuplicates] to the counting stage to ensure that each pair value is only counted as belonging to one pair:

$pairs = { {a,b}, {c,d}, {e,f}, {g,h}, {i,a}, {a,d}, {z,z}, {i,i} };

$counts = $pairs // Map[DeleteDuplicates] // Flatten // Counts

(* <| a->3, b->1, c->1, d->2, e->1, f->1, g->1, h->1, i->2, z->1|> *)

{#1, #2, $counts[#1] + $counts[#2] == 2} & @@@ $pairs

(* { {a,b,False},{c,d,False},{e,f,True},{g,h,True}
   , {i,a,False},{a,d,False},{z,z,True},{i,i,False}
   }
*)
$\endgroup$
  • $\begingroup$ This fails for $pairs = {{a, a}, {c, d}} $\endgroup$ – mikado Oct 19 '16 at 20:45
  • $\begingroup$ @mikado Whoops, I missed your comment under the question. Fixed. $\endgroup$ – WReach Oct 19 '16 at 21:10
4
$\begingroup$

Don't know if your lists are going to be large, but if so, the performance of this s/b decent:

mark = Module[{base = ArrayPad[#, {{0, 0}, {0, 1}}, True]},
    base[[Union @@ Cases[Ceiling[Values[PositionIndex[Flatten[#]]]/2], {_, __}], 3]] = False;
    base] &;

Usage:

result=mark@listOfPairs

Using:

junk = Array[x, 100000];
list = RandomChoice[junk, {100000, 2}];

to generate a test list of pairs, quite a bit quicker than answers so far. If lists are really large, comment, I've some other ideas...

$\endgroup$
  • $\begingroup$ This fails for listOfPairs = {{a, a}, {c, d}} $\endgroup$ – mikado Oct 19 '16 at 20:47
  • $\begingroup$ @mikado : so do the other answers, OP did not make clear how that's to be handled, simple change w/ nil performance impact "fixes" that, so when/if OP comments, I'll add it. $\endgroup$ – ciao Oct 19 '16 at 21:44
  • $\begingroup$ Comment to OP says that duplicates can occur $\endgroup$ – mikado Oct 19 '16 at 21:56
3
$\begingroup$
data = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}};

Table[
  {Sequence @@ data[[n]], ContainsNone[Flatten@Drop[data, {n}], data[[n]]]},
  {n, 1, Length[data]}
]

{{a, b, False}, {c, d, False}, {e, f, True}, {g, h, True}, {i, a, False}, {a, d, False}}

$\endgroup$
3
$\begingroup$

I thank @mikado for pointing out an error. I did not account for pairs such as {a,a}. I have read the comments in relation to this. I post just to correct.

func[x_, lst_] := Module[{c = 2},
  If[Length[Union[x]] == 1, c = 1];
  Length[Flatten[Intersection[#, x] & /@ lst]] == c]
pairs[lst_] := {##, func[{##}, lst]} & @@@ lst

Testing on:

dat0 = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}};
dat1 = {{a, a}, {c, d}};
dat2 = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}, {z, z}, {i, 
    i}};
Grid[{#, pairs[#]} & /@ {dat0, dat1, dat2}, Alignment -> Left, 
 Frame -> All]

enter image description here

$\endgroup$
  • $\begingroup$ This fails for dat = {{a, a}, {c, d}} $\endgroup$ – mikado Oct 19 '16 at 20:51
  • $\begingroup$ @mikado thank you . A stupid mistake by me. Appreciate you pointing it out. $\endgroup$ – ubpdqn Oct 19 '16 at 23:11
2
$\begingroup$

Someone will almost certainly have an even simpler way than this

pairs = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}};
Table[xx = pairs[[nn]]; Append[xx, Intersection[Flatten[
  Drop[pairs, {nn}]], xx] == {}], {nn, Length[pairs]}]

(* {{a,b,False}, {c,d,False}, {e,f,True}, {g,h,True}, {i,a,False}, {a,d,False}} *)

$\endgroup$
0
$\begingroup$

DisjointQ

pairs = { {a,b}, {c,d}, {e,f}, {g,h}, {i,a}, {a,d} };

Append[#, DisjointQ[Flatten @ Complement[pairs, {#}], #]]& /@ pairs

{{a, b, False}, {c, d, False}, {e, f, True}, {g, h, True}, {i, a, False}, {a, d, False}}

ConnectedComponents + TransitiveReductionGraph + RelationGraph + IntersectingQ

byitselfQ = Join @@ (If[Length @ # == 1, Thread[# -> True], Thread[ # -> False]]&/@  
 ConnectedComponents @ TransitiveReductionGraph[RelationGraph[IntersectingQ, #]])&;

byitselQ @ pairs

{{a, b} -> False, {i, a} -> False, {a, d} -> False, {c, d} -> False, {g, h} -> True, {e, f} -> True}

Organize into the desired form:

Append @@@ byitselQ[pairs]

{{a, b, False}, {i, a, False}, {a, d, False}, {c, d, False}, {g, h, True}, {e, f, True}}

If the order is important, you can use

rubeGoldbergF[l_]:= Append[#, #/. byitselQ[l]]& /@ l;
rubeGoldbergF @ pairs

{{a, b, False}, {c, d, False}, {e, f, True}, {g, h, True}, {i, a, False}, {a, d, False}}

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