11
$\begingroup$

Say you are given the following list:

list={{3, 2, 1}, {3, 4, 2}, {2, 4, 1}, {1, 4, 3}};

Two numbers $x,y$, not necessarily distinct, are neighbors if one of the sub-lists contains both of $x$ and $y$. In more precise mathematical language: let $S=\{A_1,A_2,\dots,A_n\}$ be a collection of $n$ sets, each containing integers between $1$ and $m$. Then $x$ and $y$ are neighbors if $\exists A_i:x,y\in A_i$.

I am looking for an efficient way of finding all the neighbors of each element. That is, let $S'=\{B_1,B_2,\dots,B_m\}$. Then $B_i$ contains all the neighbors of $i$. Note that $B_i$ may be empty if the integer $i$ does not appear in any of the sets in $S$. My current implementation is:

Union @@@Function[x, Select[list, MemberQ[#, x] &]] /@ Range@Max@list

(*{{1, 2, 3, 4}, {1, 2, 3, 4}, {1, 2, 3, 4}, {1, 2, 3, 4}}*)

However, it gets fairly slow on large lists. Is there a more efficient way of finding $S'$ in Mathematica?

$\endgroup$
0

10 Answers 10

10
$\begingroup$

Try the following. Note I assumed from OP that elements are non-zero integers. This could of course be adapted to other cases with appropriate mapping.

getmasks[listarg_] := 
  Reverse[Transpose[
     IntegerDigits[Fold[BitSet[#1, #2] &, 0, #] & /@ listarg, 2, 
      Max[listarg] + 1]]][[Min[listarg] + 1 ;; Max[listarg] + 1]];

getneighbors[listarg_, maskarg_, n_] := 
  Union @@ Pick[listarg, maskarg[[n - Min[listarg] + 1]], 1];

Used with some of the examples, and comparing to the memoized routines above, much faster even on the measly netbook I'm lounging with:

n = 1000; k = 500; j = 20;
list = DeleteDuplicates /@ RandomInteger[{1, n}, {k, j}];

ClearSystemCache[];
getNeighborsMemo[list, 1] // Timing

ClearSystemCache[];

Timing[masks = getmasks[list];
 getneighbors[list, masks, 1]]

Results:

{2.636417,{5,9,16,24,57,92,100,113,127,163,184,198,224,249,258,267,268,270,275,282,319,347,350,364,391,432,438,439,462,471,528,534,547,549,552,554,555,558,578,583,599,603,607,609,615,630,639,646,648,677,695,710,711,730,735,740,772,791,797,812,818,825,868,875,890,905,913,932,952,958,972,977,982}}

{0.093601,{1,5,9,16,24,57,92,100,113,127,163,184,198,224,249,258,267,268,270,275,282,319,347,350,364,391,432,438,439,462,471,528,534,547,549,552,554,555,558,578,583,599,603,607,609,615,630,639,646,648,677,695,710,711,730,735,740,772,791,797,812,818,825,868,875,890,905,913,932,952,958,972,977,982}}

Note that I include the element as its own 'neighbor', you can of course drop it as required.

With the masks, you can easily do things like quickly get at questions like 'how many lists does element $E1$ appear with element $E2$ as a neighbor?', etc. You'll probably want to add some error checking (no looking for elements out of range, etc.)

Note there is of course a trade-off using this kind of bit-mapping: you're somewhat restricted in cardinality of distinct elements, so you might have to massage/map/index things. Think of the above as a foundation to mold into your specific requirements.

Be sure to look at Mr.Wizard's refactored code below for examples of cleaned-up and enhanced versions of this, and the later part of my answer for the fastest I've come up with.

Here's a way that has no restrictions on element types/sizes/characteristics and is as fast as above for many cases, and not too shabby otherwise. It uses indexed variables and returns all the neighbors in one go:

ClearAll[neighbors]
ClearSystemCache[]

testlist = RandomInteger[{1, 5000}, {100, 50}];

Timing[

 (neighbors[#] = {}) & /@ Union[Flatten[testlist]];

 (neighborstgt = 
     Union[#]; (neighbors[#] = Union[neighbors[#], neighborstgt]) & /@
      neighborstgt) & /@ testlist;

 ]

(* time to generate ALL results*)
{0.343202,Null} 

(* show a result *)
neighbors[1]

{1,19,35,48,80,137,182,276,299,308,437,481,537,553,583,620,645,687,696,716,730,817,831,843,855,874,956,1055,1110,1160,1195,1220,1225,1267,1282,1292,1295,1324,1348,1359,1393,1401,1413,1485,1537,1698,1764,1767,1859,1868,1887,1954,2058,2147,2151,2232,2245,2266,2303,2305,2373,2396,2428,2545,2558,2575,2590,2698,2714,2853,2951,2958,2974,2989,3088,3144,3185,3290,3535,3700,3710,3713,3741,3759,3800,3867,3881,3908,4022,4070,4152,4159,4343,4472,4518,4570,4589,4867}

Or for random alphabetic 'names', e.g.:

ClearAll[neighbors]
ClearSystemCache[]

testlist = Table[RandomSample[CharacterRange["a", "z"], 10], {100}];

Timing[

 (neighbors[#] = {}) & /@ Union[Flatten[testlist]];

 (neighborstgt = 
     Union[#]; (neighbors[#] = Union[neighbors[#], neighborstgt]) & /@
      neighborstgt) & /@ testlist;

 ]

(* show a result *)
neighbors["a"]

{0.078001,Null}
{a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z}

After fiddling with the idea some more, here's an all-in-one function to do this:

getNeighbors[listarg_, eles_: False] := 
  Block[{uniques, map, digits, lu, la},
   If[eles =!= False, 
    Return[Union @@ 
      Select[DeleteDuplicates /@ listarg, MemberQ[#, eles] &]]];
   la = DeleteDuplicates /@ listarg;
   uniques = Union @@ la;
   lu = Length[uniques];
   map = Total[
     la /. Dispatch[Thread[uniques -> 2^Range[0, lu - 1]]], {2}];
   digits = IntegerDigits[map, 2, lu] // Transpose;
   Transpose[{uniques, 
     Pick[uniques, IntegerDigits[#, 2, lu] // Reverse, 
        1] & /@ (BitOr @@ Pick[map, #, 1] & /@ (digits) // 
        Reverse)}]];

Passed a list in the form of the OP's query, it returns all of the neighbor information in one go, as a list of lists each with an element as entry 1 and a list of neighbors. This function in not limited to integers:

In[366]:= getNeighbors[{{1,2,3},{a,b,v},{2,3,4},{b,c,c,d}}]
Out[366]= {{1,{1,2,3}},{2,{1,2,3,4}},{3,{1,2,3,4}},{4,{2,3,4}},{a,{a,b,v}},{b,{a,b,c,d,v}},{c,{b,c,d}},{d,{b,c,d}},{v,{a,b,v}}}

Note that as before I include the element as its own neighbor. If passed the optional second argument of a specific element, it uses a quick method to return the single result set.

Performance wise, this is comparable to the initial version with small cardinality sets, but far outstrips it when the numbers go up, e.g. with the following example of 1000 possible elements in 1000 sublists it is far faster than the already fast initial version (the original is outstripped by a factor of 68 in this example):

testarg = RandomInteger[{1000, 1999}, {1000, 1000}];

ClearSystemCache[]

{to1, dummy} = Timing[masks = getmasks3[testarg];]
{to2, dummy} = Timing[oldres =  getneighbors[testarg, masks, #] & /@ Union @@ testarg;]

ClearSystemCache[]
{tn1, dummy} = Timing[newres = getNeighbors[testarg];]
tn2 = 0;

(* check results match *)
oldres == newres[[All, 2]]

(* speedup *)
(to1 + to2)/(tn1 + tn2)



{3.822024, Null}

{512.572486, Null}

{7.644049, Null}

True

67.55510

N.B.: these timings are from my netbook (goofing with this at a cigar lounge ;-] ), so either should be pretty quick on any 'real' machine.

Some timings as requested by Mr. Wizard. Do note again - these are on a netbook, so 'real' machines should be fine with pretty much any of the methods. Also, this is just a quick & dirty timing test, so any pointers on more proper MM benchmarking appreciated.

Result columns are element range, sublist count and size, time for getNeighbors above, neighborsBitmask, and the sow/reap methods respectively, a check that results match, and speed ratios vs getNeighbors for the neighborsBitmask and sow/reap.

Scan[
(testarg=RandomInteger[#[[1]],#[[2]]];

ClearSystemCache[];
t1=First[(res1=getNeighbors[testarg];)//Timing];

ClearSystemCache[];
t2=First[(res2=neighborsBitmask[testarg];)//Timing];

ClearSystemCache[];
t3=First[(res3=Sort@Last@Reap[Sow[#,#]&~Scan~testarg,_,{#,Union@@#2}&];)//Timing];

Print[#[[1]],"  ",#[[2]],"  ",Round[t1,.001]," ",Round[t2,.001],"  ",Round[t3,.001],"  ",res1==res2==res3,"  ",t2/t1,"  ",t3/t1];)&,

{{{100,200},{20,30}},{{200,400},{30,40}},{{1,1000},{50,50}},{{1,1000},{100,100}},{{1,1000},{200,100}},{{1,1000},{100,200}},{{1000,3000},{300,300}}}
];

ele. range   sub #/Size  GN      NB      S/R   Check    Ratios

{100,200}     {20,30}   0.016   0.094   0.016  True  6.000    1.000
{200,400}     {30,40}   0.062   0.218   0.047  True  3.5000   0.7500
{1,1000}      {50,50}   0.14    0.671   0.156  True  4.7778   1.1111
{1,1000}     {100,100}  0.296   4.259   1.139  True  14.3684  3.8421
{1,1000}     {200,100}  0.374   8.861   2.371  True  23.6667  6.3333
{1,1000}     {100,200}  0.406  16.084   4.789  True  39.6538  11.8077
{1000,3000}  {300,300}  1.622 113.943  45.334  True  70.2308  27.9423

After spending a few more minutes pondering this interesting challenge, yet another alternative that has some advantages. If we know the sublists are 'dense' with neighbors we can beat one of the expensive parts of the problem - the union of sub-results - since we can know something that MM cannot infer - there's a limit to how many distinct neighbors any element can have. By short-circuiting the union, significant time savings can be had:

Clear[test,max,list,arg,findN];
(*test={{1,2,3},{2,3,4},{4,5,6}}*)
test=RandomInteger[{1,100},{50000,200}];
test=DeleteDuplicates/@test;


(* Define it *)
(* call with list, element to find neighbors, and cardinality of elements *)

findN[list_,arg_,max_]:=Catch[Fold[If[Length[#]==max,Throw[#1],
      If[MemberQ[#2,arg],Union[##],#1]]&,{},list]];

(* query a singlet *)
ressingle=With[{lst=test,maxx=Length[Union@@test]},findN[lst,4,maxx]];//Timing

(* get all *)
resall=With[{lst=test,maxx=Length[Union@@test]},findN[lst,#,maxx]&/@
           Range[1,maxx]];//Timing

(* get singlet using bitmap *)
resGNSingle=getNeighbors[test,4];//Timing

(*get all using bitmap *)
resGNAll=getNeighbors[test];//Timing

(* compare results *)
ressingle==resGNSingle
resGNAll[[All,2]]==resall

(* findN singlet *)
{4.773631,Null}

(* findN all *)
{16.208504,Null}

(* bitmask singlet *)
{5.803237,Null}

(* bitmask all *)
{42.806674,Null}

(* results comparison check *)
True
True

As can be seen, with 50,000 sublists of 200 length each and 100 possible distinct random elements, this is nearly three times faster than the bitmap. Reminder - these timings were again on a netbook - I expect order(s) of magnitude faster when I get back to my workstations.

I'm pondering some other tricks - stay tuned!

Here's a quick-n-dirty method using sparse arrays. It's quite quick, competitive with the bitmap method, sometimes quite a bit faster, other times not, as expected from the trade-offs made for different methods. It is considerably more memory efficient, of course, needing only 5-10% of the overall memory compared to the bitmap method.

(* test list *)
test=DeleteDuplicates/@RandomPrime[{10000,100000},{500,100}];

(* make array *)
sa=With[{tmp=Flatten[MapIndexed[Transpose[{#1,ConstantArray[First[#2],Length[#1]]}]&,test],1]},
    SparseArray[tmp->ConstantArray[True,Length[tmp]]]];//Timing


(* get single element's neighbors*)
lookfor=1;

resal=Union@@test[[PropertyValue[sa,AdjacencyLists][[lookfor]]]];//Timing
res2=getNeighbors[test,lookfor];//Timing

(* check singlet results match *)
res2==resal

(* get all *)
resalAll=Transpose[{Union@@test,Union@@@(test[[#]]&/@
DeleteCases[PropertyValue[sa,AdjacencyLists],{}])}];//Timing

res2=getNeighbors[test];//Timing

(* check results match *)
resalAll==res2
Out[900]= {0.140401,Null}
Out[902]= {0.015600,Null}
Out[903]= {0.078001,Null}
Out[904]= True
Out[905]= {1.341609,Null}
Out[906]= {3.619223,Null}
Out[907]= True

If non-integer list values are used, the above rules-based mapping to numbers can be used with this.

$\endgroup$
15
  • $\begingroup$ Thanks! This is indeed quite fast. Would you care to explain how it works? $\endgroup$
    – E.O.
    Dec 30, 2013 at 8:51
  • $\begingroup$ @E.O. Surely: getmasks simply takes the list and for each sublist generates a bitmap where a set bit corresponds to presence of that integer. Taking that list of bitmaps (one per sublist), transposing it gives you a list of bitmaps representing the position(s) of the sublist(s) each integer occupies. Doing this apart = multiple lookups need not redo this. getneighbors takes the desired element as argument and indexes into the bitmap list to get the sublists where the element resides, unioning to complete the task. I've sped it up a bit, will post update after goofing more. Hope that helped. $\endgroup$
    – ciao
    Dec 30, 2013 at 10:26
  • $\begingroup$ Thanks for the explanation! It'll take some time to digest, but it works quite well :-) $\endgroup$
    – E.O.
    Dec 30, 2013 at 10:35
  • $\begingroup$ @E.O. - happy to explain more if needed, ran out of comment! Also, I removed my (probably invalid) assumption that the elements started with 1. Not a good assumption. So, as is, any non-negative integer range should be fine. Again, if you need more clarification feel free to ask. $\endgroup$
    – ciao
    Dec 30, 2013 at 12:40
  • $\begingroup$ Nice method. Note however that you don't need BitSet[#1, #2] & -- merely BitSet will do. $\endgroup$
    – Mr.Wizard
    Dec 30, 2013 at 14:12
6
$\begingroup$

You seem to have already used a fairly standard and very reasonable approach. An alternate way to do this (I haven't tested it for performance) is to use the graph theory functions. For instance, by creating the adjacency matrix from your list, you can get the neighbours:

adj = list /. l : {__Integer} :> Map[# -> 1 &, Permutations[l, {2}]] // 
     Flatten // SparseArray // Normal;
With[{g = AdjacencyGraph@adj}, AdjacencyList[g, #] & /@ VertexList@g] 
(* {{2, 3, 4}, {1, 3, 4}, {1, 2, 4}, {1, 2, 3}} *)
$\endgroup$
2
  • $\begingroup$ Is this supposed to run for any sub-lists length? For example for SeedRandom[42]; n = 1000; k = 300; j = 10; list = DeleteDuplicates /@ RandomInteger[{1, n}, {k, j}]; I can't reconcile your result with Leonid's or mine. $\endgroup$ Dec 30, 2013 at 6:04
  • $\begingroup$ @belisarius Thanks. I realize where the mistake is; I've fixed it now. $\endgroup$
    – rm -rf
    Dec 30, 2013 at 18:05
4
$\begingroup$

This seems to be a version of a connectivity problem. Taking the function listToGraph from here:

ClearAll[listToGraph];
listToGraph[list_List] := 
  Graph@Union[
    Sort /@ Flatten[
      Apply[UndirectedEdge, (Partition[#1, 2, 1] &) /@ list, {2}]]];

we can then define the function you look for as

getNeighbors[list_List, elem_]:= 
   AdjacencyList[listToGraph[Flatten[Subsets[#, {2}] & /@ list, 1]], elem]

so that, for example,

getNeighbors[list,1]

(* {2, 3, 4} *)

If you need to use this for many different elements, it may make sense to memoize the graph constructed for a given list. Here is a version which does that:

ClearAll[graph, getNeighborsMemo];
graph[list_List] := graph[list] = 
    listToGraph[Flatten[Subsets[#, {2}] & /@ list, 1]];
getNeighborsMemo[list_List, elem_] := AdjacencyList[graph[list], elem];

You use this as before, but now the auxiliary graph function will store the resulting graph, for all subsequent calls to getNeighborsMemo.

$\endgroup$
2
  • $\begingroup$ Lol, I didn't see your answer! I also used the graph theory functions, although my approach is a little different from yours. $\endgroup$
    – rm -rf
    Dec 30, 2013 at 1:59
  • $\begingroup$ @rm-rf Indeed, similar, but not quite the same implementation. It would be interesting to compare performance, but I can't spend more time on this now. $\endgroup$ Dec 30, 2013 at 2:01
4
$\begingroup$

Here is a method using Sow and Reap that I think is clean, flexible, and efficient. It is especially applicable if you are only interested in the neighbors of a subset of elements, and it natively works with arbitrary list elements. Here is the basic form:

sets = {{3, 7}, {2, 7}, {5, 7}, {3, 2, 6}, {2, 5}, {6, 9, 7}, {3, 6}, {1, 4}}

Sort @ Last @ Reap[Sow[#, #] & ~Scan~ sets, _, {#, Union @@ #2} &] // Column
{1, {1,4}}
{2, {2,3,5,6,7}}
{3, {2,3,6,7}}
{4, {1,4}}
{5, {2,5,7}}
{6, {2,3,6,7,9}}
{7, {2,3,5,6,7,9}}
{9, {6,7,9}}

The same operation on strings:

charsets = Map[FromCharacterCode, 96 + sets, {2}];

Sort @ Last @ Reap[Sow[#, #] & ~Scan~ charsets, _, {#, Union @@ #2} &] // Column
{a, {a,d}}
{b, {b,c,e,f,g}}
{c, {b,c,f,g}}
{d, {a,d}}
{e, {b,e,g}}
{f, {b,c,f,g,i}}
{g, {b,c,e,f,g,i}}
{i, {f,g,i}}

Gathering only the neighbors of 1,3,9; the third argument of Reap is changed to give only the neighbors since 1, 3, 9 can be assumed by position:

Last @ Reap[Sow[#, #] & ~Scan~ sets, {1, 3, 9}, Sequence @@ Union @@ #2 &] // Column
{1,4}
{2,3,6,7}
{6,7,9}

I hope this illustrates the flexibility of this approach. Here is an attempt to bundle this method in a versatile function:

neighbors[sets : {__List}] :=
 Sort @ Last @ Reap[Sow[#, #] & ~Scan~ sets, _, {#, Union @@ #2} &]

neighbors[sets : {__List}, patt_] :=
 Last @ Reap[Sow[#, #] & ~Scan~ sets, patt, Sequence @@ Union @@ #2 &]

Usage:

neighbors[sets] // Column
neighbors[sets, {1, 3, 9, foo}] // Column
{1,{1,4}}
{2,{2,3,5,6,7}}
{3,{2,3,6,7}}
{4,{1,4}}
{5,{2,5,7}}
{6,{2,3,6,7,9}}
{7,{2,3,5,6,7,9}}
{9,{6,7,9}}

{1,4}
{2,3,6,7}
{6,7,9}
{}

Note that when foo was included, which is not present in the set, {} is returned.

Performance

Timing function:

SetAttributes[timeAvg, HoldFirst]
timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

Timings for all neighbors of a large set, using the function from my other answer:

SeedRandom[1]
sets = DeleteDuplicates /@ RandomInteger[9999, {1500, 7}];

neighbors[sets] // timeAvg

With[{masks = myMasks[sets]}, myNeighbors[sets, masks, #] & /@ Union @@ sets] // timeAvg

0.02936

3.759

And with counting neighbors for only a small selection of elements:

neighbors[sets, RandomPrime[9999, 10]] // timeAvg
0.01312

It is worth noting that this method may consume a large amount of memory in the case where there is heavy duplication of links, where sublists are long, and when all (or many) neighbors are being counted. This is because elements are sown repeatedly, then duplicates are removed with Union afterward. A look at what is gathered before the Union operation:

SeedRandom[1]
sets = DeleteDuplicates /@ RandomInteger[9, {4, 15}]
{{1, 4, 0, 7, 8, 6, 5}, {1, 3, 2, 6, 0, 4, 5},
 {5, 3, 0, 2, 9, 1}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}
Reap[Sow[#, #] & ~Scan~ sets][[2]]

{{{1, 4, 0, 7, 8, 6, 5}, {1, 3, 2, 6, 0, 4, 5}, {5, 3, 0, 2, 9, 1}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 4, 0, 7, 8, 6, 5}, {1, 3, 2, 6, 0, 4, 5}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 4, 0, 7, 8, 6, 5}, {1, 3, 2, 6, 0, 4, 5}, {5, 3, 0, 2, 9, 1}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 4, 0, 7, 8, 6, 5}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 4, 0, 7, 8, 6, 5}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 4, 0, 7, 8, 6, 5}, {1, 3, 2, 6, 0, 4, 5}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 4, 0, 7, 8, 6, 5}, {1, 3, 2, 6, 0, 4, 5}, {5, 3, 0, 2, 9, 1}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{1, 3, 2, 6, 0, 4, 5}, {5, 3, 0, 2, 9, 1}}, {{1, 3, 2, 6, 0, 4, 5}, {5, 3, 0, 2, 9, 1}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}, {{5, 3, 0, 2, 9, 1}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}}

Obviously this is memory inefficient. Reap is smart enough to only collect elements for tags which will be used, so this problem is ameliorated by collecting neighbors for a limited number of elements:

Reap[Sow[#, #] & ~Scan~ sets, {3, 7}][[2]]
{{{{1, 3, 2, 6, 0, 4, 5}, {5, 3, 0, 2, 9, 1}}},
 {{{1, 4, 0, 7, 8, 6, 5}, {4, 1, 5, 2, 7, 9, 8, 0, 6}}}}

Nevertheless you may want to consider another approach for very long lists. I am working on another solution using rasher's highly space efficient bitmask format but it is not yet complete.

$\endgroup$
5
  • $\begingroup$ This is brilliant! It's a shame I can't accept two answers.. $\endgroup$
    – E.O.
    Jan 1, 2014 at 2:36
  • $\begingroup$ @E.O. I'm glad you like it. :-) I added some important notes regarding performance. $\endgroup$
    – Mr.Wizard
    Jan 1, 2014 at 3:03
  • $\begingroup$ Nice! I've updated my original answer with a pretty quick all-at-once method that also allows arbitrary (i.e. not just integers) elements. $\endgroup$
    – ciao
    Jan 1, 2014 at 6:40
  • $\begingroup$ @rasher Great; let me take a look. $\endgroup$
    – Mr.Wizard
    Jan 1, 2014 at 6:46
  • $\begingroup$ Now I understand Reap and Sow tag structure and Reap 3th and 4th argument.. tks $\endgroup$
    – Murta
    Jan 4, 2014 at 14:42
4
$\begingroup$

This is a refactoring of rasher's method because I don't think a bit-mask approach can be beaten. It is improved especially for the case where elements are not numbered from a low value. It is not optimized for cases where there is an extreme spread in element values or extended to non-integer elements; those cases would be best handled by replacing elements with sequential natural numbers beforehand.

My code:

myMasks[sets_] := Min @ sets /. min_ :>
   {min, IntegerDigits[Fold[BitSet, 0, #] & /@ (sets - min), 2, Max[sets] - min + 1] //
     Transpose // Reverse}

myNeighbors[sets_, {min_, masks_}, n_] := Union @@ Pick[sets, masks[[n - min + 1]], 1]

Timing function:

SetAttributes[timeAvg, HoldFirst]

timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

Elements starting from 2:

SeedRandom[1]
sets = RandomPrime[1000, {200, 4}];

With[{masks = getmasks[sets]}, getneighbors[sets, masks, #] & /@ Union @@ sets] // timeAvg
With[{masks = myMasks[sets]}, myNeighbors[sets, masks, #] & /@ Union @@ sets]   // timeAvg
0.004872

0.003624

About one third faster in the base case. Now with elements starting from 15,013:

SeedRandom[1]
sets = RandomPrime[{15000, 17000}, {200, 4}];

With[{masks = getmasks[sets]}, getneighbors[sets, masks, #] & /@ Union @@ sets] // timeAvg
With[{masks = myMasks[sets]}, myNeighbors[sets, masks, #] & /@ Union @@ sets]   // timeAvg
0.01808

0.00512

More than 3.5X faster in the target case.


Here is a different version also based on bitmasks. It is not a refactoring of other code, but it falls into the same category so I am including it here. I could not get the performance to be competitive with the Sow and Reap method I posted in a separate answer, but I am including it here with the hope that it may inspire someone else in writing a better solution. Note that the old SparseArray properties trick is used because Pick in v7 is slower; it may be equally fast and cleaner to use Pick in later versions.

neighborsBitmask[sets : {__List}] :=
  Module[{unique, n, rls, extract, array},
    unique = Union @@ sets;
    n = Length @ unique + 1;
    rls = Dispatch @ Thread[Reverse[unique] -> Range[n - 1]];
    extract = unique[[SparseArray[#] @ "AdjacencyLists"]] &;
    array = ConstantArray[0, n - 1];
    Do[array[[x]] = Fold[BitSet, array[[x]], #], {x, #}] & /@ (sets /. rls);
    {unique, extract @ IntegerDigits[#, 2, n] & /@ Reverse @ array}\[Transpose]
  ]
$\endgroup$
1
  • $\begingroup$ Nice! This has the same set of tweaks to performance I alluded to in my comment to E.O., and about the same magnitude of performance boost. I shall link here from my answer! +1 $\endgroup$
    – ciao
    Dec 30, 2013 at 21:27
3
$\begingroup$
SeedRandom[42];
list = RandomInteger[{1, 20}, {30, 3}];
Function[{elem}, {elem, Union @@ Select[list, MemberQ[#, elem] &]}][#] & /@ (Union @@ list)

Or

SeedRandom[42];
list = RandomInteger[{1, 20}, {30, 3}];
s = Function[{elem}, {elem, Union @@ (Pick[list, #] &@(MemberQ[#, elem] & /@ list))}][#] & /@ 
                                                                                    (Union @@ list)

Edit

I like this one, but it's way slower:

SeedRandom[42];
list = RandomInteger[{1, 20}, {30, 3}];
df[x_, y_] := If[Cases[list, {___, x, ___, y, ___} | {___, y, ___, x, ___}] != {}, 1, 2, 2]
f = Nearest[Union @@ list, DistanceFunction -> (df[#1, #2] &)]
{#, f@#} & /@ (Union @@ list)
$\endgroup$
2
$\begingroup$

Not so compact but works OK on large input :

n = 4; list = {{3, 2, 1}, {3, 4, 2}, {2, 4, 1}, {1, 4, 3}};

(* generate all pairs of neighbours implied by list *)
pairs = Flatten[Permutations[#, {2}] & /@ list, 1];
(* pairs contains many duplicates but cleaning it up takes longer *)
s = ConstantArray[{}, n];
While[pairs != {},
  p = First@pairs;
  AppendTo[s[[First@p]], Last@p];
  AppendTo[s[[Last@p]], First@p];
  pairs = Rest[pairs];];
(* cleanup *)
Sort /@ DeleteDuplicates /@ s

For a longer input:

n = 20; k = 30; j = 3;
list = DeleteDuplicates /@ RandomInteger[{1, n}, {k, j}];
(* 0.003493 sec *)

and

n = 1000; k = 300; j = 10;
list = DeleteDuplicates /@ RandomInteger[{1, n}, {k, j}];
(* 2.618397 sec *)
$\endgroup$
2
$\begingroup$

Yet another..

({#[[1, 1]], Union@Flatten@Take[#, All, {2}]}) & /@ 
     GatherBy[
      Flatten[{#, Reverse@#} & /@ 
           Union@Flatten[Sort /@ Subsets[#, {2}] & /@ list, 1], 1], #[[1]] &]
$\endgroup$
1
$\begingroup$

Such a nice challenge, thought I'd contribute, even though I'm a bit late:

Borrowing Mr.Wizard's data...

sets={{"c","g"},{"b","g"},{"e","g"},{"c","b","f"},{"b","e"},{"f","i","g"},{"c","f"},{"a","d"}};

Edit: I find this variant very straightforward and easy to understand (although this is of course a matter of judgment). However, it is far less efficient than Mr.Wizard's approach.

Code

elements=Union@@sets;
p[el_]:= p[el]={el,Position[sets,el][[All,1]]}
neighbors2[el_]:={el,Union@@Extract[sets,List/@p[el][[2]]]}

Analysis

Step 1: Get the elements

elements

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


Step 2: Find the sets each element belongs to

p[element] finds all the sets an element is a member of. Memoization is used to eliminate redundant calculations of p.

Which sets is an element a member of?

p/@elements

{{"a", {8}}, {"b", {2, 4, 5}}, {"c", {1, 4, 7}}, {"d", {8}}, {"e", {3, 5}}, {"f", {4, 6, 7}}, {"g", {1, 2, 3, 6}}, {"i", {6}}}


Step 3: Find the neighbors of each element

neighbors[element] returns element's neighbors by getting all of the elements in the sets to which element belongs.

Who are the neighbors of f?

neighbors["f"]

{"f", {"b", "c", "f", "g", "i"}}

Who are the neighbors of each element?

neighbors/@elements//Column

neighbors

$\endgroup$
3
  • $\begingroup$ I get errors when I try to run this; e.g. Part::partw: Part 2 of {8} does not exist. >> $\endgroup$
    – Mr.Wizard
    Jan 1, 2014 at 7:44
  • $\begingroup$ Ditto: "Intersection::normal: Nonatomic expression expected at position 1 in 2[Intersection]2", returns empty sets. Neat idea though, I'm guessing a typo. $\endgroup$
    – ciao
    Jan 1, 2014 at 8:19
  • $\begingroup$ Thanks for the catch. I fixed it (in a prior edit) but then found a more direct way to solve the problem, using the same general logic. See above. $\endgroup$
    – DavidC
    Jan 1, 2014 at 14:47
1
$\begingroup$

Here is my suggestion, storing in DownValues:

ClearAll@getNeighbors
getNeighbors[list_]:=Module[{addPair,id,elements},

    elements=DeleteDuplicates@Flatten@list;
    Scan[(id[#]={})&,elements];
    addPair[a_,b_]:=id[a]=DeleteDuplicates@Join[id[a],{b}];
    Scan[addPair@@@Permutations[#,{2}]&,list];
    SortBy[{#,id@#}&/@elements,First]
]

list={{1,4},{9,11,4},{8,9,7},{5,11,12},{2,7,23},{22}};
getNeighbors[list]//Column
{1,{4}}
{2,{7,23}}
{4,{1,9,11}}
{5,{11,12}}
{7,{2,8,9,23}}
{8,{7,9}}
{9,{4,7,8,11}}
{11,{4,5,9,12}}
{12,{5,11}}
{22,{}}
{23,{2,7}}

Using Association

Playing with Association, I tried this (very inefficient) code:

ClearAll@getNeighborsAss
getNeighborsAss[list_]:=Module[{addPair,ass},

    ass=Association[#-> {}&/@DeleteDuplicates@Flatten@list];
    addPair[a_,b_]:=ass=Combine[{ass,<|a-> {b}|>},Join@@##&];
    Scan[addPair@@@Permutations[#,{2}]&,list];
    ass
]

list={{1,4},{9,11,4},{8,9,7},{5,11,12},{2,7,23},{22}};
getNeighborsAss[list]
<|1 -> {4}, 4 -> {1, 9, 11}, 9 -> {11, 4, 8, 7}, 11 -> {9, 4, 5, 12}, 
 8 -> {9, 7}, 7 -> {8, 9, 2, 23}, 5 -> {11, 12}, 12 -> {5, 11}, 
 2 -> {7, 23}, 23 -> {2, 7}, 22 -> {}|>
$\endgroup$
1
  • $\begingroup$ I made this Association code using Version 10 (beta). I think that it's no problem because RPi has it. If some Wolfram people disagree, I remove it. $\endgroup$
    – Murta
    Jan 4, 2014 at 16:52

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.