3
$\begingroup$

Subsets[Range[2000], {4}, {n}] would give the $s^{th}$ subset of the Subsets[Range[2000], {4}].
For example, Subsets[Range[2000], {4}, {10}] would give the subset {{1, 2, 3, 13}}.

Question: Can we do the reverse, given the subset {{1, 2, 3, 13}}, can we find the $10$?
The normal approach would be to generate all Subsets[Range[2000], {4}] and then find the position of {{1, 2, 3, 13}}, but this is not possible in this case as the number of subsets is too large.

list = {{{1}, {2, 3, 6, 7, 10}, {4, 5, 8, 9}}, {{1}, {2, 4, 5, 8, 
     9}, {3, 6, 7, 10}}, {{1}, {2, 3, 5, 8, 9}, {4, 6, 7, 
     10}}, {{1}, {2, 4, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8, 
     9}, {4, 5, 7, 10}}}; (* around 10 000 sublist in real data *)

Subsets[list, {2}, {10}] gives {{{{1}, {2, 4, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8, 9}, {4, 5, 7, 10}}}}.
How can I extract 10 from {{{{1}, {2, 4, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8, 9}, {4, 5, 7, 10}}}}?

$\endgroup$
5
  • $\begingroup$ You should be able to hard-code this, because Mathematica generates the list in Sorted order, provided the original list (Range[2000]) is in sorted order, which is to say, it changes the last element first as much as it can, then the third element, etc. Some sort of multinomial symbol perhaps should do this. $\endgroup$
    – march
    Commented May 14 at 15:18
  • $\begingroup$ Although, now that I think a little about it, that's going to be difficult due to the fact that we have to skip repetitions. $\endgroup$
    – march
    Commented May 14 at 15:30
  • $\begingroup$ You might be interested in oeis.org/A014311 . That specific sequence is the case where bit-weight is 3, but the idea generalizes. I haven't figured out yet if one can generate the sequence in an efficient manner, but if you could, then you might have a more performant solution. $\endgroup$
    – lericr
    Commented May 14 at 22:49
  • $\begingroup$ Might list contain duplicate members? $\endgroup$
    – Michael E2
    Commented May 28 at 16:51
  • $\begingroup$ @MichaelE2 no, there is no duplicate. $\endgroup$
    – internet
    Commented May 29 at 5:49

3 Answers 3

5
+200
$\begingroup$

You can use Combinatorica Package by evaluating (without "") "<<Combinatorica`".

Then use RankKSubset like so:

list = {{{1}, {2, 3, 6, 7, 10}, {4, 5, 8, 9}}, {{1}, {2, 4, 5, 8, 
     9}, {3, 6, 7, 10}}, {{1}, {2, 3, 5, 8, 9}, {4, 6, 7, 
     10}}, {{1}, {2, 4, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8, 
     9}, {4, 5, 7, 10}}};

RankKSubset[{{{1}, {2, 4, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8,
      9}, {4, 5, 7, 10}}}, list] + 1

10

It indexes from 0 so +1 is needed.

RankKSubset[{1, 2, 3, 13}, Range[2000]] + 1

10

RankKSubset[{1997, 1998, 1999, 2000}, Range[2000]] + 1

664668499500
$\endgroup$
4
  • $\begingroup$ I didn't make it clear in the post. The function is good but unfortunately it only works with KSubset. $\endgroup$
    – internet
    Commented May 29 at 6:18
  • 1
    $\begingroup$ @internet It works with your examples so I do not understand what you mean. $\endgroup$ Commented May 29 at 8:53
  • $\begingroup$ I think I misunderstood the mistake. Can we modify the ignore the order in any level of a list? For example RankKSubset[{{{1}, {2, 4, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8, 9}, {4, 5, 7, 10}}}, list] + 1 work but if I change the order of 2 and 4 in the second sublist RankKSubset[{{{1}, {4, 2, 6, 7, 10}, {3, 5, 8, 9}}, {{1}, {2, 3, 6, 8, 9}, {4, 5, 7, 10}}}, list] + 1 this give an error $\endgroup$
    – internet
    Commented May 29 at 10:56
  • 1
    $\begingroup$ @internet It gives error because the given list is not sub-list of the list. If you want to ignore order you have to sort each item of the list and each item of sub-list exactly the same way and then apply RankKSubset. $\endgroup$ Commented May 29 at 11:28
3
$\begingroup$

Here's an approach. I'm not 100% confident, but it seems to work on the test cases I've tried. Given a subset, we can turn it into a sort of mask that picks out elements from Range[size] for some size (2000 in your sample). So, for example for size 7, the subset {1,2,3,7} corresponds to {1,1,1,0,0,0,1}. Once we have that, we can determine how many shifts were required to get to that subset. I'm using "shift" to just mean going to the next mask in canonical order. So, in our case we must have had 3 shifts:

{1,1,1,1,0,0,0}
{1,1,1,0,1,0,0}
{1,1,1,0,0,1,0}
{1,1,1,0,0,0,1}

The next shift would produce

{1,1,0,1,1,0,0}

Okay, so how do we count shifts? Well, looking at the mask version of a subset, we can examine groups of 0s and 1s. Zeros at the beginning indicate many shifts, but how many? Well, the minimal number of shifts we need to do to get a certain number of leading zeros requires a sort of compound addition, akin to building up the triangular numbers. I don't really have words, so you'll just need to inspect the algorithm.

(* We can pass over leading ones and recurse to a smaller problem *)
CountShifts[range_, subsetSize_, {ones : {1 ..}, rest___}] := 
  CountShifts[range - Length@ones, subsetSize - Length@ones, {rest}];

(* A terminal case *)
CountShifts[_, 0, _] := 0;

(* A terminal case *)
CountShifts[_, 1, {zeros : {0 ..}, ___}] := Length@zeros;

(* The main algorithm *)
CountShifts[range_, subsetSize_, {zeros : {0 ..}, rest___}] := 
  Total[Take[Nest[Accumulate, ConstantArray[1, 1 + range - subsetSize], subsetSize - 1], -Length@zeros]] + 
    CountShifts[range - Length@zeros, subsetSize, {rest}]

The number of shifts is equivalent to a zero-based index, so to get our desired index we just need to add 1. Now we bundle this up into a function that starts by transforming the subset to its "mask" version and calling CountShifts.

SubsetToIndex[range_, subset_] :=
  1 + CountShifts[range, Length@subset, Split[ReplacePart[ConstantArray[0, range], List /@ subset -> 1]]]

Just a quick check:

SubsetToIndex[2000, {1, 2, 3, 13}]
(* 10 *)

Performance doesn't seem too bad--a few seconds for the 2000 range with subsets of size 1000--but I assume it'd bog down pretty quickly as we scale from there.

All of this assumes that we're taking subsets of lists like Range[number]--it won't work in the general case.

$\endgroup$
1
  • $\begingroup$ Thanks, I tried several cases and it works well. However, I'm interested a big more general cases with subsets (not range[number]). $\endgroup$
    – internet
    Commented May 15 at 6:15
2
$\begingroup$

Here is a not too clever solution. We may simply check all answers of Subsets[Range[2000], {4}, {i}] for i=1,2,...:

rev[s_] := 
 Do[If[s == Subsets[Range[2000], {4}, {i}][[1]], Return[i]], {i, 
   0.2  10^5}]
rev[{1, 2, 3, 13}]

10
$\endgroup$
1
  • $\begingroup$ Thanks, I thought about that, but it would probably not be possible (too long a time) with a large n. $\endgroup$
    – internet
    Commented May 14 at 8:19

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.