8
$\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$
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$
    – mikado
    Oct 19, 2016 at 4:48
  • 1
    $\begingroup$ yes there could be pairs like that. and I like your idea, thanks. $\endgroup$
    – Suite401
    Oct 19, 2016 at 5:31

10 Answers 10

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$
2
  • 1
    $\begingroup$ This fails for $pairs = {{a, a}, {c, d}} $\endgroup$
    – mikado
    Oct 19, 2016 at 20:45
  • $\begingroup$ @mikado Whoops, I missed your comment under the question. Fixed. $\endgroup$
    – WReach
    Oct 19, 2016 at 21:10
5
$\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$
3
  • 1
    $\begingroup$ This fails for listOfPairs = {{a, a}, {c, d}} $\endgroup$
    – mikado
    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$
    – ciao
    Oct 19, 2016 at 21:44
  • $\begingroup$ Comment to OP says that duplicates can occur $\endgroup$
    – mikado
    Oct 19, 2016 at 21:56
4
$\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$
4
$\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$
2
  • 1
    $\begingroup$ This fails for dat = {{a, a}, {c, d}} $\endgroup$
    – mikado
    Oct 19, 2016 at 20:51
  • $\begingroup$ @mikado thank you . A stupid mistake by me. Appreciate you pointing it out. $\endgroup$
    – ubpdqn
    Oct 19, 2016 at 23:11
3
$\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$
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$
2
$\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

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

$\endgroup$
2
$\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

$\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$
    – Syed
    Sep 9, 2023 at 19:30
  • $\begingroup$ Thanks mate! I had to change to something more readable to get the correct result. :-) $\endgroup$ Sep 9, 2023 at 20:26
2
$\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

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