A faster way for replacing subsets of an ordered list conditioned on the elements in that subset

Question

I have a list $\ell$ of ordered subsets of $1,\dots,n$ with a maximum length, e.g. for $n = 4$ with maximum length 3 this list is of the form

{{}, {1}, {2}, {3}, {4}, {1,2}, {1,3}, {1,4}, {2,3}, {2,4}, {3,4}, {1,2,3}, {1,2,4}, {1,3,4}, {2,3,4}}

Given a number $m \leq n$ and a subset $s \subseteq \{1,\dots,n\}$ I want to efficiently replace the elements of this list $\ell$, based on the following conditions:

• if neither $m$ nor one of the numbers in $s$ is in the element replace the element by 5
• if $m$ is in the element but not one of the numbers in $s$ replace by 4
• if one or more of the numbers in $s$ but not $m$ is in the element replace by 3
• if both $m$ and one or more of the numbers in $s$ is in the element replace by 2

For the example given above and $m = 3, s = \{1,2\}$ this would result in a list:

{5, 3, 3, 4, 5, 3, 2, 3, 2, 3, 4, 2, 3, 2, 2}

My code below works and gives the right output, but I was wondering if someone might know a faster to do this? Any hint/help is welcome!

Input:

powerset = Subsets[Range[4], 3];
number1 = 3;
numbers2 = {1, 2};

Code:

vector = {MemberQ[#, number1], Length[Intersection[#, numbers2]]} & /@ powerset; 
rules = {{False, 0} -> 5, {True, 0} -> 4, {False, _} -> 3, {True, _} -> 2}; 
vector =  Fold[Replace[#1, #2, {1}] &, vector, rules]

Note: on the given example my code is not that slow, but it slows down when the input given is e.g.

powerset = Subsets[Range[200], 3];

and I want it to work faster for these larger instances.

Answer 1

This is a quick-n-dirty, but it's ~6X faster on large tests.

doit[n_, ml_, m_, s_] := Module[{ss, lss, r, z, none, nos},
   ss = ReplacePart[ConstantArray[1, n], 
     Thread[Append[s, m] -> Prime[Range[Length[s] + 1]]]];
   ss = Subsets[ss, ml];
   lss = Length@ss;
   r = Range@lss;
   ss = PadRight[ss, {lss, Length@Last@ss}, 1];
   z = ConstantArray[2, lss];
   z[[none = Pick[r, ss, ConstantArray[1, ml]]]] = 5;
   r = Complement[r, none];
   ss[[r]] = Times @@@ ss[[r]];
   z[[nos = Pick[r, ss[[r]], Prime[Length[s] + 1]]]] = 4;
   r = Complement[r, nos];
   z[[Pick[r, Divisible[ss[[r]], Prime[Length[s] + 1]], False]]] = 3;
   z];

Usage:

doit[n,ml,m,s]

where n,ml,m,s are your $n$, $maximum$ $length$, $m$ and $s$

E.g.,for an n of 500, maximum subset size of 3, m of 3 and s of {1, 2, 10, 20, 40, 50} :

doit[500,3,3,{1, 2, 10, 20, 40, 50}]

I have some other ideas, will update when/if time permits.

This is roughly comparable in speed, much shorter & simpler:

doit3[n_, ml_, m_, s_] :=
 Subtract[5, 
  BitOr @@@ 
   Subsets[ReplacePart[ConstantArray[0, n], 
     Thread[Append[s, m] -> Append[ConstantArray[2, Length@s], 1]]], 
    ml]];

Now, if we are working with static $n$ and $maxlen$ for some set of queries, we can benefit from some precomputation.

pgen[n_, ml_] := 
  PositionIndex@Flatten@PadLeft[Subsets[Range@n, ml]] // 
   Table[Quotient[#[x], ml, 1] + 1, {x, n}] &;

query[pgenout_, n_, ml_, m_, s_] := 
  Module[{ss = Union @@ pgenout[[s]], ms = pgenout[[m]], 
    res = ConstantArray[5, Tr[Binomial[n, Range[0, ml]]]]},
   
   res[[Complement[ms, ss]]] = 4;
   res[[Complement[ss, ms]]] = 3;
   res[[Intersection[ss, ms]]] = 2;
   res];

for the previous example, this is used by first precomupting some data:

pout=pgen[500,3];

followed by any number of queries with differing $m$ and $s$:

result=query[pout,3,3,{1, 2, 10, 20, 40, 50}];

By $n$ of 700 this is nearly three orders of magnitude faster than the OP code: