# Need an efficient way to do this list manipulation

Lets say i have two lists with me as given below:

l1 = {4, 6, 8, 9, 10, 12};

l2 = {2, 3, 4, 5, 6, 7};


Now i have a function S2P(details irrelevant) which takes one argument and spits out a list.

S2P[a_] := DeleteDuplicates[Apply[Times,Partition[Flatten[IntegerPartitions[a, {2}]], 2], {1}]]


Now i want to feed S2P the elements of l2 and find which elements of l2 gives an output that is a subset of l1.

For e.g

S2P[5]
(*{4, 6}*)

S2P[7]
(*{6, 10, 12}*)


These are the only two elements of l2 for which the output from S2P is a subset of l1 and im finding them like this:

t1[n_] := Module[{l3, res, len},
l3 = S2P[l2[[n]]];
len = Length[l3];
res = Count[
Flatten[Table[{l3[[i]]} == {l1[[#]]} & /@ Range[Length[l1]], {i,1,len}]],True];
If[res == len, Sow[l2[[n]]]]];

DeleteCases[t1[#] & /@ Range[Length[l2]], Null]
(*{5, 7}*)


Can someone show me how to do this more efficiently for large data. Below i have shown the actual function l1 and l2 where n can go upto 1000.

f4 = #~Extract~SparseArray[Unitize[#2 - 1]]["NonzeroPositions"] & @@
Transpose@Tally@# &; (* to keep only duplicates*)

l1[n_] :=
DeleteCases[f4[Flatten[Table[i*j, {i, 1, n}, {j, 1, n}]]], _?PrimeQ]

l2[n_] :=
DeleteDuplicates[Flatten[Table[i + j, {i, 1, n}, {j, 1, n}]]]

-
Please define "large data" -- how long is l1 specifically? Also, are these lists of fairly small integers as in the example? – Mr.Wizard Jul 29 '14 at 11:38
@Mr.Wizard I have included the working set – Hubble07 Jul 29 '14 at 11:54
Thanks. My method will not work for those; as it see it is important to include such things. – Mr.Wizard Jul 29 '14 at 11:59
I suspect that this problem is quite hard. Can you tell me more about the real S2P? It may be important to restrict the search domain as much as possible. – Mr.Wizard Jul 29 '14 at 12:02
@Mr.Wizard If i give you a positive integer n and tell you that n is a sum of two positive integer(a and b) then you are asked to give all possible products of a and b. S2P does this for any n – Hubble07 Jul 29 '14 at 12:21

With l1[n] and l2[n] defined as above,

Table[Cases[l2[n], q_Integer /; And @@ (MemberQ[l1[n], #] & /@ S2P[q])], {n, 64}]


takes 58 seconds and produces for n=64:

{5,7,9,10,11,13,15,16,17,19,21,23,25,27,28,29,31,33,35,36,37,39,40,41,43,45,47,49,51,52,53,
55,56,57,59,61,63,64,65,67}

-

Simplified you could use: (this simpler l1 is sorted unlike the original)

l1[n_] := DeleteCases[Union @@ Table[i*j, {i, 1, n}, {j, i + 1, n}], _?PrimeQ]
l2[n_] := Range[2, 2 n]
S2P[a_] := DeleteDuplicates[Times @@@ IntegerPartitions[a, {2}]]


V10 introduces SubsetQ

func[n_] := With[{u = l1[n]}, Select[l2[n], SubsetQ[u, S2P[#]] &]]

-

I use l1, l2, and S2P as defined by @Coolwater (you don't really have to Flatten and then Partition again when the original output of IntegerPartitions is already partitioned). I define my function twice to make it take 2 lists as arguments as well as any n as defined by l1[n], and l2[n].

seismaticaQ[lis1_List, lis2_List] :=
Pick[lis2, Complement[S2P[#], lis1] & /@ lis2, {}];
seismaticaQ[n_Integer] :=
Pick[l2[n], Complement[S2P[#], l1[n]] & /@ l2[n], {}];

seismaticaQ[{4, 6, 8, 9, 10, 12}, {2, 3, 4, 5, 6, 7}]
(* {5, 7} *)

seismaticaQ[64]
(* {5, 7, 9, 10, 11, 13, 15, 16, 17, 19, 21, 23, 25, 27, 28, 29, 31, 33, \
35, 36, 37, 39, 40, 41, 43, 45, 47, 49, 51, 52, 53, 55, 56, 57, 59, \
61, 63, 64, 65, 67} *)


Comparison with @Wouter's method (using MemberQ) and @Coolwater's method (using MMA 10's SubsetQ)

Clear[wouterQ, coolwaterQ]
wouterQ[n_Integer] :=
Cases[l2[n], q_Integer /; And @@ (MemberQ[l1[n], #] & /@ S2P[q])];
coolwaterQ[n_Integer] :=
With[{u = l1[n]}, Select[l2[n], SubsetQ[u, S2P[#]] &]];
ListLinePlot[
Table[{n, First[#[n] // AbsoluteTiming]}, {n, 1,
30}] & /@ {seismaticaQ, wouterQ, coolwaterQ},
PlotLegends -> {"seismaticaQ", "wouterQ", "coolwaterQ"},
PlotRange -> Full, AxesLabel -> {"n", "AbsoluteTiming"}]


-

I await more detail regarding your working set, but if l1 is not too long you might use this:

dsp = Dispatch @ Thread[Rest @ Subsets @ l1 -> True];

Pick[l2, S2P /@ l2 /. dsp]

{5, 7}


The same thing using Associations (v10):

asc = <|Thread[Rest @ Subsets @ l1 -> True]|>;

Pick[l2, Lookup[asc, S2P /@ l2, False]]

-