6
$\begingroup$

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?

$\endgroup$
0

6 Answers 6

4
$\begingroup$

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}
$\endgroup$
4
$\begingroup$

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 *)
$\endgroup$
4
$\begingroup$

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]
  )
$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$
    – apg
    Oct 11, 2023 at 18:02
  • $\begingroup$ Oh ok sorry for the misunderstanding. Also does order matter? So would {b,c,a} count as having an occurence of {a,b}? $\endgroup$
    – ydd
    Oct 11, 2023 at 20:07
  • $\begingroup$ Yes, because they co-occur. Also no need for apology! $\endgroup$
    – apg
    Oct 11, 2023 at 20:30
3
$\begingroup$
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

enter image description here

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

{0.000018, 891}

$\endgroup$
3
$\begingroup$
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}, 
  AssociationThread[pl, Map[occuranceCount[lists]] @ pl]]

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

Another way using Most and Rest:

AdjacentPairs[list_] /; VectorQ[list] := Transpose[{Most[list], Rest[list]}]
AdjacentPairs[list_] /; ListQ[list] := AdjacentPairs /@ list;
CountOccurances[list_, key_] := Extract[Counts[Flatten[AdjacentPairs[list], 1]], Key[key]];

lst = {{a, b, f}, {a, b, d, f}, {a, c, h}, {b, h}, {a, b, g}};
CountOccurances[lst, {a, b}]
(*3*)
$\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.