Xjyuk

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?

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]]

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 *)
```