# Count all co-occurances of a pair of strings in a list of lists

I am trying to obtain a co-occurance matrix for pairs of names in a collection of groups of names.

So, I have a collection of letters in small groups, such as

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

I need to count the co-occurances of a pair of letters, such as {a,b}, in these groups.

So, in this case, {a,b} occur together in the list at part 1, 2 and 5, so a and b occur together 3 times.

I have

namelist = {{a, b, f}, {a, b, d, f}, {a, c, h}, {b, h}, {a, b, g}};
allnames = DeleteDuplicates[Flatten@namelist];
allpairs = Subsets[allnames, {2}];
countoccurances[x_] := Count[ContainsAll[#, x] & /@ names, True];
countoccurances[{a, b}]

which gives an output of

3

as expected. This is obviously very slow given the names list might contain 10,000 entries and so about 50 million pairs, each of which needs to be checked to obtain a co-occurance matrix. Is there are faster way to do this?

Pattern matching is not very fast. So I am not sure if pattern matching will serf your needs. You will have to try it out.

With the data:

namelist = {{a, b, f}, {a, b, d, f}, {a, c, h}, {b, h}, {a, b, g}};
allnames = DeleteDuplicates[Flatten@namelist];
allpairs = Subsets[allnames, {2}];

The count for every pair is:

Count[namelist, {___, Sequence @@ #, ___}] & /@ allpairs

{3, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0}

Not very fast, I suspect:

l={{a,b,f},{a,b,d,f},{a,c,h},{b,h},{a,b,g}};

SequenceCount[#,{a,b}]&/@l

Total[%]

(*
{1,1,0,0,1}

3
*)

Or, if speed is a major consideration, maybe:

Scan

Reap[Scan[Sow[SequenceCount[#,{a,b}]]&,l];,_,Total[#2]&][[2,1]]

(* 3 *)

Do

Reap[Do[Sow[SequenceCount[l[[i]], {a, b}]],{i, Length@l}],_, Total[#2]&][[2,1]]

(* 3 *)

Edit: I misunderstood the question. The two letters do not have to be adjacent, and order doesn't matter (ex {b,c,a} counts as having an {a,b} pair):

countOccurences[lst_, x_] := Total[SubsetCount[#, x] & /@ lst]

Partition nameList into runs of 2 adjacent elements (within the same element of nameList) and Flatten together into a single list:

namelist = {{a, b, f}, {a, b, d, f}, {a, c, h}, {b, h}, {a, b, g}}
pairs = Flatten[Partition[#, 2, 1] & /@ namelist, 1];
(*{{a, b}, {b, f}, {a, b}, {b, d}, {d, f}, {a, c}, {c, h}, {b, h}, {a,
b}, {b, g}}*)

and Count:

cts = Counts@pairs
<|{a, b} -> 3, {b, f} -> 1, {b, d} -> 1, {d, f} -> 1, {a, c} ->
1, {c, h} -> 1, {b, h} -> 1, {b, g} -> 1|>

making it a function:

ClearAll[countOccurances, pairs, cts]
countOccurances[lst_, letters_] := (
pairs = Flatten[Partition[#, 2, 1] & /@ lst, 1];
cts = Counts@pairs;
If[MemberQ[Keys@cts, letters], letters /. cts, 0]
)
• Thank you! Note, I think I need `pairs = Flatten[Subsets[#, {2}] & /@ namelist, 1]' as co-occurrence can occur even if pairs are not adjacent in one of the sublists.
– apg
Oct 11, 2023 at 18:02
• Oh ok sorry for the misunderstanding. Also does order matter? So would {b,c,a} count as having an occurence of {a,b}?
– ydd
Oct 11, 2023 at 20:07
• Yes, because they co-occur. Also no need for apology!
– apg
Oct 11, 2023 at 20:30
namelist = {{a, b, f}, {a, b, d, f}, {a, c, h}, {b, h}, {a, b, g}};

sub = Counts @ Apply[Join] @ Map[Subsets[#, {2}] &, namelist]

<|{a, b} -> 3, {a, f} -> 2, {b, f} -> 2, {a, d} -> 1, {b, d} -> 1, {d, f} -> 1, {a, c} -> 1, {a, h} -> 1, {c, h} -> 1, {b, h} -> 1, {a, g} -> 1, {b, g} -> 1|>

As Association sub permits easy and very fast queries:

1. Get one pair

sub[{b, f}]

2

sub[{x, x}]

Missing["KeyAbsent", {x, x}]

2. Get several pairs

KeyTake

KeyTake[{{a, a}, {a, b}, {a, c}, {a, d}}] @ sub

<|{a, b} -> 3, {a, c} -> 1, {a, d} -> 1|>

Lookup

Lookup[sub, {{a, a}, {a, b}, {a, c}, {a, d}}, Missing[]]

{Missing[], 3, 1, 1}

KeySelect

KeySelect[MatchQ[{a, _}]] @ sub

<|{a, b} -> 3, {a, f} -> 2, {a, d} -> 1, {a, c} -> 1, {a, h} -> 1, {a, g} -> 1|>

3. Timings

test = RandomChoice[Alphabet[], {10^5, 4}];

(sub = Counts @ Apply[Join] @ Map[Subsets[#, {2}] &, test]); //
RepeatedTiming // First

0.302131

sub // Short

sub[{"k", "u"}] // Timing

{0.000018, 891}

occuranceCount[lists_] :=
Count[lists, {OrderlessPatternSequence[## & @@ #, ___]}, All] &

Examples:

occuranceCount[namelist] @ {a, b}
3
occuranceCount[namelist] @ {b, a}
3
occuranceCount[namelist] @ {f , b}
2
occuranceCount[namelist] @ {a}
4

For occurance counts of 2-subsets we can define an association using occuranceCount and all pairs occuring in input lists:

pairOccuranceCounts[lists_] :=
Module[{pl = Union @ Apply[Join] @ Map[Subsets[#, {2}] &] @ lists},

pairOccuranceCounts[namelist]
<|{a, b} -> 3, {a, c} -> 1, {a, d} -> 1, {a, f} -> 2,
{a, g} -> 1, {a, h} -> 1, {b, d} -> 1, {b, f} -> 2,
{b, g} -> 1, {b, h} -> 1, {c, h} -> 1, {d, f} -> 1|>
Replace[_Missing -> 0] @* pairOccuranceCounts[namelist] /@
{{a, h}, {a, g}, {a, f}, {c, h}}
{1, 1, 2, 1, 0}

Another way using Most and Rest:

AdjacentPairs[list_] /; VectorQ[list] := Transpose[{Most[list], Rest[list]}]