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

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ Do any pairs have the same element twice? If not, you count how many times each element occurs in the flattened list. $\endgroup$ Commented Oct 19, 2016 at 4:48
  • 1
    $\begingroup$ yes there could be pairs like that. and I like your idea, thanks. $\endgroup$ Commented Oct 19, 2016 at 5:31

12 Answers 12

Reset to default
8
$\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}
   }
*)
Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ This fails for $pairs = {{a, a}, {c, d}} $\endgroup$ Commented Oct 19, 2016 at 20:45
  • $\begingroup$ @mikado Whoops, I missed your comment under the question. Fixed. $\endgroup$ Commented Oct 19, 2016 at 21:10
6
$\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...

Improve this answer
$\endgroup$
3
  • 1
    $\begingroup$ This fails for listOfPairs = {{a, a}, {c, d}} $\endgroup$ Commented Oct 19, 2016 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$ Commented Oct 19, 2016 at 21:44
  • $\begingroup$ Comment to OP says that duplicates can occur $\endgroup$ Commented Oct 19, 2016 at 21:56
5
$\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}}

Improve this answer
$\endgroup$
5
$\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

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ This fails for dat = {{a, a}, {c, d}} $\endgroup$ Commented Oct 19, 2016 at 20:51
  • $\begingroup$ @mikado thank you . A stupid mistake by me. Appreciate you pointing it out. $\endgroup$ Commented Oct 19, 2016 at 23:11
4
$\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}}

Improve this answer
$\endgroup$
4
$\begingroup$

Using TakeList:

Clear["Global`*"];
data = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}, {z, z}, {i, 
    i}};

Transpose[{data,
   Not@*IntersectingQ @@@
    (Map[Union, #, {1}] & /@ 
      Map[Flatten[#, 
          1] &] /@ (TakeList[data, {{#}, {1, Length@data - 1}}] & /@ 
         Range@Length@data)
     )
   }
  ] // Grid

Result

enter image description here

Explanation

1- The TakeList step separates the tuple to be compared to the rest of the list.

2- These two lists per row are subjected to Union before IntersectingQ determines overlap.

3- The Transpose step is for visualization only.

Improve this answer
$\endgroup$
4
$\begingroup$

Another way using Table, Intersection and DeleteCases:

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

rule = Rule[x_, y_] :> If[Length[y] == 0, 
       {Sequence @@ x, True}, {Sequence @@ x, False}];

Thread@Rule[data, Map[Intersection[#[[1]], Flatten@#[[2]]] &, 
Table[{data[[m]], DeleteCases[data, data[[m]]]}, {m, 1, 
Length[data]}]]] /. rule // MatrixForm

enter image description here

Or more compact:

rule = {a_, b_} :> If[! IntersectingQ[a, b], 
{Sequence @@ a, True}, {Sequence @@ a, False}]

Table[{#[[m]], Flatten@DeleteCases[#, #[[m]]]}, {m, Length[#]}] &@data /. rule

enter image description here

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ Please run it with data = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}, {z, z}, {i, i}}; used by @eldo. $\endgroup$ Commented Sep 9, 2023 at 19:30
  • $\begingroup$ Thanks mate! I had to change to something more readable to get the correct result. :-) $\endgroup$ Commented Sep 9, 2023 at 20:26
4
$\begingroup$ 
flagDistinct = MapIndexed[{$v, $i} |-> {Splice @ $v, 
           ContainsNone[$v] @ Flatten @ Drop[#, $i]}] @ # &;

Example:

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

flagDistinct @ pairs // Column

enter image description here

Improve this answer
$\endgroup$
3
$\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}} *)

Improve this answer
$\endgroup$
3
$\begingroup$ 
pairs = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}, {z, z}, {i, i}};

dup = Cases[Rule[a_, b_] /; Length[b] > 1 :> a] @
  Normal @ PositionIndex @ Flatten @ Map[DeleteDuplicates] @ pairs

{a, d, i}

Transpose[{pairs, ContainsNone[#, dup] & /@ pairs}] // MatrixForm

enter image description here

Improve this answer
$\endgroup$
2
$\begingroup$ 
pairs = {{a, b}, {c, d}, {e, f}, {g, h}, {i, a}, {a, d}, {z, z}, {i, i}};

dup = Keys @ Select[# > 1 &] @ Counts @ Flatten @ ReplaceAll[pairs, {a_, a_} :> a]

{a, d, i}

AssociationThread[pairs, DisjointQ[dup, #] & /@ pairs] // Dataset

enter image description here

Improve this answer
$\endgroup$
1
$\begingroup$

A basic approach:

s = {{a, b},
   {c, d},
   {e, f},
   {g, h},
   {i, a},
   {a, d}};
sub = Subsets[s, {5}];
com = {Splice[Complement[s, #][[1]]], 
     Intersection[Union @@ #, Complement[s, #][[1]]] == {}} & /@ sub;
Column[Reverse[com]]

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.