4
$\begingroup$

I want to create a list of n random integers from 1 to m, where all integers have to be at least a certain distance min apart (i.e. 3 integers out of Range[10], keeping a minimum distance of 2)

This is the module I created to fullfill that purpose:

StartGen[MinimalDistance_] := 
                    Module[{nCells, min,test,i,j,r},
                         min = MinimalDistance;

                          (*Just create a Random Sample from Range[m] if min=0 
                          is chosen*)
                          If[min == 0,
                            nCells = Sort[RandomSample[Range[m], n]];
                            Return[nCells]
                            ,
                            nCells = Table[0, n];
                            nCells[[1]] = RandomInteger[m];
                            i = 1; j = 1;

                            (*Only execute if n integers out of m actually can 
                            keep a minimum distance of min*) 
                            If[m/(n (min + 1)) >= 1,

                                While[i <= n,
                                  (*Generate random integers from Range[m] until one 
                                  fits with the already assigned Integers*)
                                  r = RandomInteger[m];
                                  test = True;
                                  Do[If[Abs[nCells[[j]] - r] <= min, 
                                        test = False; Break[], 
                                        test = True], {j, i}
                                     ];
                                  If[test == True, nCells[[i]] = r; i++, Null];
                                ];

                            nCells = Sort[nCells];
                            Return[nCells];
                            ,
                            Print["Impossible figuration for m n and min"];
                            ];
                        ];
                    ];

Now the performance problem this creates is quite obvious: If the number of possible integers m and the minimum distance min are too big, as the While loop goes on fewer and fewer generated integers will fit the requirements and it gets harder and harder to hit those few integers through generating random numbers out of Range[m]. (For me this module couldn't produce lists for n=100,m=1000,min=8.)

I think the solution to this problem lies in reducing the number of Integers to choose from as the calculation go on, i.e. eliminate integers that dont fit the requirements anymore.

I tried implementing this with some variants of the DeleteCases[] function but I always ended up just creating more iterative calculations that would worsen the performance once again.
Is there an elegant way to do this?

$\endgroup$
  • $\begingroup$ Your problem is that Length[Range[8, 1000, 2 8 - 1]] equals 67 which is less than 100. So that's just not always possible with n=100, m=1000, and min=8. $\endgroup$ – Henrik Schumacher Jul 10 at 21:25
5
$\begingroup$

Easiest solution is as follows: for a required minimum distance $d$ such that $|x_i - x_j| \ge d$ for all $1 \le i \ne j \le n$, select $y_1 < \ldots < y_n$ from $\{1, \ldots, m - (n-1)(d-1)\}$ without replacement and construct the sample $$x_i = y_i + (i-1)(d-1).$$ This is only possible if $m - (n-1)(d-1) \ge n$ or equivalently, $m > (n-1)d$.

The above can be implemented as

F[m_, n_, d_] := Sort[RandomSample[Range[m - (n - 1)(d - 1)], n]] + (Range[n] - 1)(d - 1)

and if a random permutation of the sorted sample is desired, simply take RandomSample of the output. No recursion is needed and no lengthy functions are used.

For example, if $m = 10$, $n = 4$, $d = 2$, there are $\binom{7}{4} = 35$ $4$-tuples from $\{1, \ldots, 10\}$ such that the minimum difference between elements is at least $2$. Then

ParallelTable[F[10, 4, 2], {10^6}] // Tally

simulates $10^6$ such random samples, and tallies the frequency of each outcome.

$\endgroup$
  • $\begingroup$ This was the approach I was going to post up. Clean implementation. $\endgroup$ – MikeY Jul 12 at 15:17
7
$\begingroup$
  1. Construct a random sample from Range[m] satisfying the minimum distance requirements taking into account the fact that if $x_k$ is selected at step $k$, the choices in step $k+1$ are restricted to the range from $x_k + d$ to $m - (n-k)d$ to be able to get $n-k$ additional elements in remaining steps satisfying the minimum distance constraint.
  2. Shuffle the list obtained in the first step

ClearAll[f]
f[m_, n_, d_] /; n d <= m :=  RandomSample @ Rest @ 
  FoldList[RandomChoice[Range[# + Boole[#2 > 1] d, m - (n - #2) d]] &, 1, Range[n]]

Examples:

Table[f[10, 3, 2], {5}]

{{8, 3, 6}, {6, 10, 8}, {8, 5, 10}, {8, 10, 6}, {10, 1, 4}}

Min[Differences@Sort@#] & /@ %

{2, 2, 2, 2, 3}

f[10, 4, 3]

f[10, 4, 3] (* impossible *)

f[1000, 100, 8]

{848, 808, 189, 776, 680, 824, 472, 728, 352, 976, 736, 544, 504, 936, 904, 408, 720, 400, 816, 448, 856, 560, 279, 336, 312, 512, 888, 928, 424, 944, 584, 480, 238, 552, 920, 568, 528, 600, 952, 304, 536, 688, 632, 712, 992, 592, 616, 221, 896, 456, 864, 344, 792, 744, 392, 624, 320, 984, 576, 206, 648, 960, 368, 840, 872, 376, 328, 752, 832, 24, 288, 640, 416, 1000, 760, 696, 520, 488, 672, 464, 249, 800, 968, 768, 664, 432, 384, 784, 271, 912, 296, 656, 704, 496, 608, 230, 880, 360, 257, 440}

Min @ Differences@ Sort @ %

8

res = f[10000000, 10000, 800]; // AbsoluteTiming // First

0.105936

Min @ Differences @ Sort @ res

800

Update: An alternative implementation using NestList:

ClearAll[f2]
f2[m_, n_, d_] /; n d <= m := Module[{k = 1}, RandomSample @ Rest @ 
  NestList[RandomChoice[Range[# + Boole[k++ > 1] d, m - (n - k) d]] &, 1, n]]
$\endgroup$
2
$\begingroup$

How about something like this - rather than picking random numbers until one satisfies the minimum distance criteria, pick the random number from a set that excludes disallowed values.

gen2[m_, n_, min_] := Module[{nCells, set},
  set = Range[m];
  nCells = RandomSample[set, 1];
  While[Length[nCells] < n && Length[set] > 0,
   set = Complement[set, 
     Range[nCells[[-1]] - min + 1, nCells[[-1]] + min - 1]];
   If[Length[set] < 1, Print["Couldn't pick ", n], 
    nCells = Join[nCells, RandomSample[set, 1]]];
   ];
  nCells]
Table[gen2[10, 3, 2], {10}] // Column
(*
{4,7,10}
{8,3,6}
{2,6,9}
{5,8,3}
{7,10,1}
{3,10,6}
{3,7,10}
{3,9,6}
{1,10,5}
{9,2,6} *)

As noted by Henrik Schumacher in the comments, n=100, m=1000, min=8 doesn't work most of the time (you get an empty set before you pick 100 numbers):

gen2[1000, 100, 8]
(*  
Couldn't pick 100
{599, 14, 526, 475, 52, 448, 791, 576, 196, 711, 941, 35, 211, 483, \
371, 401, 827, 354, 757, 547, 858, 86, 222, 336, 696, 913, 419, 386, \
812, 363, 982, 974, 563, 966, 665, 279, 955, 494, 243, 675, 151, 994, \
742, 5, 298, 438, 901, 316, 24, 627, 636, 873, 411, 684, 261, 516, \
107, 586, 138, 768, 508, 290, 650, 253, 850, 116, 73, 464, 173, 163, \
129, 94, 428, 346, 842, 609, 888, 306, 619, 181, 922, 44, 555, 931, \
231, 539, 327, 731, 776, 456, 799, 64, 722, 271} *)

But 7 is fine:

test = gen2[1000, 100, 7]
(*
{556, 966, 917, 863, 425, 155, 414, 504, 43, 82, 395, 196, 765, 701, \
55, 330, 935, 626, 337, 843, 511, 885, 441, 834, 756, 117, 572, 285, \
519, 17, 189, 658, 563, 817, 266, 727, 28, 854, 805, 747, 775, 210, \
997, 546, 138, 303, 608, 295, 900, 145, 718, 355, 176, 666, 130, 946, \
259, 102, 405, 795, 452, 649, 480, 591, 240, 363, 63, 641, 95, 694, \
493, 221, 536, 978, 633, 784, 739, 387, 871, 827, 675, 465, 10, 954, \
580, 599, 686, 878, 36, 1, 926, 373, 320, 529, 348, 248, 708, 893, \
311, 273} *)

Test the minimum distance between numbers:

stest = Sort[test];
Min[Table[stest[[i]] - stest[[i - 1]], {i, 2, Length[test]}]]
(* 7 *)
```
$\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.