2
$\begingroup$

Here is a code I wrote that is supposed to give the length of list after some splitting and regrouping. But it is inefficient. Is there a way to rewrite in more professional and efficient way? I guess the procedural loop should be replaced with some functional command. Not sure how though, so as not to overload the memory.

NN=10^9;      
 ll = Range[12];
        k = 0; n = 7;
        AbsoluteTiming@(For[i = 1, i <= NN, i++,

            k += Length[
               Split[Sort[RandomSample[ll, n], Less], #1 - #2 == -1 &]];

            ];)
        k

Update:

Thanks a lot. I made a logical mistake in my code, it shouldn't randomize while iterating n for later calculation of the distribution with maximum number of subsets in the process of building up:

AbsoluteTiming@(s = 10^4; NN = 12;
  ll = Range[NN];

  t = Table[tt = RandomSample[ll]; 
    Table[Sort[Take[tt, j], Less], {j, NN}], {s}];


  t = Map[1 + Total[Unitize[Rest[#] - Most[#] - 1]] &, t, {2}];
  final = Map[Max, t];
  Mean[final] // N)

So basically it outputs the largest number of consecutively arranged subsets.

Is Patrick's fast answer applicable in this case too? How and why?

$\endgroup$
  • 2
    $\begingroup$ What is this code trying to calculate? $\endgroup$ – MarcoB Jul 20 '15 at 5:46
  • $\begingroup$ Welcome to Mathematica.SE! I hope you will become a regular contributor. To get started, 1) take the introductory Tour now, 2) when you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge, 3) remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign, and 4) give help too, by answering questions in your areas of expertise. $\endgroup$ – bbgodfrey Jul 20 '15 at 5:54
  • 1
    $\begingroup$ @bbgodfrey this a question out of ignorance. Do you have an automated or other way to place these welcome messages (which are very very useful)...I am sorry to be ignorant of this $\endgroup$ – ubpdqn Jul 20 '15 at 7:23
  • $\begingroup$ @ubpdqn If I recall correctly, there is a standard welcome message, but I use the one above, because it covers more and (I believe) in a better order. When I happen to see a new member question, I copy this message from my computer and paste it into a comment. I know of no automated way to do this. Too bad. $\endgroup$ – bbgodfrey Jul 20 '15 at 13:56
  • $\begingroup$ @bbgodfrey thank you for the information...will try to be as responsible myself in future:) $\endgroup$ – ubpdqn Jul 20 '15 at 13:59
8
$\begingroup$

The immediate improvement you wanted was the following, but of course it uses large amounts of memory:

NN = 10^9;
Total@Table[Length[Split[
 Sort[RandomSample[Range[12], 7], Less], #1 - #2 == -1 &]], {i, 1,
 NN}] // AbsoluteTiming

That is, using Table and Total (but it consumes all the memory of my 16GB RAM machine).

However, there are only 792 different subsets of length 7 drawn from Range[1,12]. Therefore, I can give you the exact mean of the estimator you have constructed:

NN = 10^9;
subs = Length@Split[#, #1 - #2 == -1 &] & /@ Subsets[Range[12], {7}];
Mean[subs]*NN

This takes basically no memory. Sorry that this doesn't really answer the general question, but it answers the specific.

$\endgroup$
  • 2
    $\begingroup$ Probably Subsets[Range[12], {7}] intead of Subsets[Range[12], 7] $\endgroup$ – Dr. belisarius Jul 20 '15 at 6:20
  • $\begingroup$ I assumed simulation the goal, if not, your latter is the way to do it barring OP detailing the goal and it lends itself to direct probabilistic calculations. +1 $\endgroup$ – ciao Jul 20 '15 at 6:59
  • $\begingroup$ Thanks, belisarius - fixed the typo. $\endgroup$ – Patrick Stevens Jul 20 '15 at 7:08
  • 1
    $\begingroup$ FWIW in this case the Table result, although it looks more satisfactory is only very marginally faster than the For loop (avoiding memory issues tested with smaller NN like 10^6 ). Ultimately it seems if you want to brute force crunch it out the procedural loop is the way to go. $\endgroup$ – george2079 Jul 20 '15 at 15:51
  • $\begingroup$ Thanks a lot. I made a logical mistake in my code, it shouldn't randomize while iterating i: AbsoluteTiming@(s = 10^4; NN = 12; ll = Range[NN]; t = Table[tt = RandomSample[ll]; Table[Sort[Take[tt, j], Less], {j, NN}], {s}]; t = Map[1 + Total[Unitize[Rest[#] - Most[#] - 1]] &, t, {2}]; final = Map[Max, t]; Mean[final] // N) So basically it outputs the largest number of consecutively arranged subsets. Is Patrick's fast answer applicable in this case too? $\endgroup$ – Al Guy Jul 22 '15 at 16:28
4
$\begingroup$

Exploiting @ciao efficient way of counting the length of splits ( I have upvoted his answer) allows exact calculation of expectation of split length for this setup. The 792 (Binomial[12,7]) cases make it tractable.

tally = Tally[
   6 - ((Tr@Unitize@Subtract[Differences@#, 1]) & /@ 
      Subsets[Range[12], {7}])];
tot = Total@tally[[All, 2]];
prob = ProbabilityDistribution[
  Piecewise[{#2/tot, u == #1} & @@@ tally], {u, 1, 6, 1}]
Expectation[z, z \[Distributed] prob]

yielding 7/2 which the simulations approach.

Noting there can not be length of split >6 given 7 elements and if all 6 elements chosen split seventh chosen must be within 1 of an element. The 6 cases of 6 split:

{{{1, 2}, {4}, {6}, {8}, {10}, {12}}, {{1}, {3, 
   4}, {6}, {8}, {10}, {12}}, {{1}, {3}, {5, 
   6}, {8}, {10}, {12}}, {{1}, {3}, {5}, {7, 
   8}, {10}, {12}}, {{1}, {3}, {5}, {7}, {9, 
   10}, {12}}, {{1}, {3}, {5}, {7}, {9}, {11, 12}}} 
$\endgroup$
  • $\begingroup$ Use of probability functions makes for smiles, +1. Of course, if the OP is after more than just this particular case, all of our solutions go bonkers (range 100 taken 30 at a time, anyone?). I'm on to something for those, assuming OP comments/updates post with more info. $\endgroup$ – ciao Jul 20 '15 at 8:47
4
$\begingroup$

Since you changed the question completely and rendered every answer posted and the effort involved moot, here's a method to compute the exact PMF and Mean for your new formulation with nearly nil memory requirements.

Since you've not responded to requests by me and others to clarify precisely what it is you're after, I don't plan on spending any time deriving the closed form for the exact distribution and mean as I did for the first round of your question - that was, while on the order of minutes, non-trivial, and the structure of the latest machinations seems considerably more fiendish, probably on the order of hours to figure it out or show it does not/might not exist. (And, lacking clarification, I wonder if it's really what you think it is/you're after).

In any case:

ClearAll[cnts, ge, base, perm, k, j, size]
size = 12;
ge = GroupElements[SymmetricGroup@size, {k}];
bins = Ceiling[size/2];
(cnts[#] = 0) & /@ Range@bins;
base = Range@size;
Do[
  perm = Permute[base, First@ge];
  cnts[Max[(1 + Total[Unitize@Subtract[Differences@#, 1]]) & /@ 
      Table[Sort[Take[perm, j]], {j, size}]]]++,
  {k, size!}];

dist = (cnts[#]) & /@ Range@bins/size!
mean = Tr[dist*Range@bins]

I'd suggest doing a run for some k less than size! to get some timings to extrapolate the total runtime before unleashing it for a complete run. You should be able to speed it further by

  1. Parallelize parts where appropriate.
  2. Take advantage of symmetry of results, cutting work by 1/2 and adjusting sums.
  3. Short-circuit the finding of maximums.

I'd venture a runtime of a handful of hours if all three are done correctly.

Barring that, or you don't care about precision, just use your RandomSample based estimator - the rare events for size 12 will be the cases where the maximum is 1, these occur ~0.00043% of the time, so calculate sufficient samples to get a reasonable representation of those and you'll get an OK estimate.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.