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

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.

• What are the expected parameter ranges here (that is, how large of $n$ and cardinality of $s$ do you need/want to handle)? And I'm curious what this is for - is it just some exercise, or are you looking for some combinatorial result (and might this be an x-y problem in disguise)?
– ciao
Aug 7 '20 at 21:59
• It is not just an exercise, I am implementing a model that uses the weights of edges in a network. The edges are numbered $1,\dots,n$ and the weight of an edge is determined by a background process. The list $\ell$ contains the states of the background process, $m$ is the edge number for which the weight is determined and $s$ is the set of edges that affect the weight of $m$. These are often the attached edges, so $s$ is expected to be small (size not larger than 6 I would say). Aug 8 '20 at 12:51

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_] :=
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:

• Wow this is amazing, thank you so much! I especially like the use of BitOr, had never seen it before but it is so nice and fast! Aug 15 '20 at 12:39