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.