List manipulation with random elements under limiting conditions

Question

I have a function f1 that should output indexed sublist number in position 1, along with 2 other random choices from the initial list. The sublists must also not contain the same element more than once, and when flattened and sorted, should contain each member of the initial list 3 times exactly:

f1[l_List] := Flatten /@ Thread[{l, Partition[
  RandomSample[Flatten[Thread@Array[l &, 2], 1], 2*Length@l], 2]}];
f2[l_List] := With[{li = f1@l},
  {Tr[Length@DeleteDuplicates[#] & /@ li] == 3*Length@l, li}];

which I can force to work as desired with something like:

f3[l_List] := First[Select[f2[l] & /@ Range@Floor[Length@l^2], #[[1]] == True &]][[2]];

eg

f2[Range@4]
f2[Range@4]

might output

{False, {{1, 4, 1}, {2, 1, 3}, {3, 4, 2}, {4, 3, 2}}}
{True, {{1, 4, 2}, {2, 3, 4}, {3, 1, 2}, {4, 3, 1}}}

where part 2 of output 2 is desired output, whereas f3[Range@4] usually outputs as desired:

{{1, 4, 2}, {2, 3, 4}, {3, 1, 2}, {4, 3, 1}}

Basically, I need the output for both of the following tests to output sublists of length 3:

m = f1@Range@4;
Split@Sort@Flatten@m
DeleteDuplicates /@ m

the following output shows then that m in this case is not as desired:

{{1, 1, 1}, {2, 2, 2}, {3, 3, 3}, {4, 4, 4}}
{{1, 2}, {2, 1, 4}, {3, 4}, {4, 3, 1}}

I have tried approaching this with NestWhileList, but have come up short. But is there a better way?

Answer 1

You may use FoldPairList to return a sampled without replacement of the sample space as you progress through the list.

ClearAll[pickPair];
pickPair[sp_, val_] :=
 With[{pair =
    RandomSample[ Rule @@ Through@{Values, Keys}@Counts@DeleteCases[val]@sp, 2]},
  {
   Flatten@{val, pair},
   Delete[sp, FirstPosition[#]@sp& /@ pair]
   }
  ]

With list converted into the sample space s.

list = Range@4;
s = Flatten[Thread@Array[list &, 2], 1];

Then

SeedRandom[125]
pickPair[s, 1]

{{1, 4, 2}, {1, 1, 2, 3, 3, 4}}

pickPair does the following.

1. Removes the restricted value from the sample space.
2. Converts the sample space such any remaining items will not be picked twice.
3. Retains the probability density of each remaining item as in the sample space.

The requested index and its pair is returned alongside the remaining items in the sample space.

pickPair can be used with FoldPairList to obtain the list of indices and pairs.

FoldPairList[pickPair, s, list]

{{1, 4, 3}, {2, 1, 3}, {3, 4, 2}, {4, 1, 2}}

However, this result is a little unstable because it can, on occasion, run out of viable items for the last pair. For example if it selects {{1, 3, 2}, {2, 1, 4}, {3, 2, 1}} for positions 1 through 3 then the remaining sample space is {3, 4} for position 4. This is not valid since 4 will be removed for position 4.

The good news is that the specification of RandomSample in pickPair will fail in such cases and this can be used to restart the sample.

genSample[list_] :=
 Quiet@Check[
   FoldPairList[pickPair,
    Flatten[Thread@Array[list &, 2], 1],
    list],
   Echo@"restart";
   genSample[list]
   ]

genSample applies this logic of recursive restarting in the event that the sample experiences this issue.

SeedRandom[524]
genSample@list

» restart

» restart

» restart

{{1,4,2},{2,1,3},{3,2,4},{4,3,1}}

The Echo can be removed as it is only there to demonstrate the restarts.

Hope this helps.

Answer 2

This is an interesting problem, which I think deserves more than one vote. I took the liberty of generalising it to n by m matrices, where n > 1 (in your example n = 4) and 1 < m <= n (in your example m = 3). I also wanted to get an algorithm that couldn't go wrong and need to backtrack or start over.

The function

The function generatematrix takes as arguments n (the length of list = Range[n]) and m (the number of columns in the output matrix).

The basic concept is to create the output matrix row by row, while keeping track of how many more of each number are yet to be placed (in the imaginatively named yettoplace variable) and how many available positions there are (in the availablepos variable). Some numbers must be placed in all rows after a certain point to avoid running out of space.

generatematrix[n_, m_] := Module[{
   yettoplace = ConstantArray[m - 1, n],
   availablepos = ConstantArray[n - 1, n],
   unfinished = Range[n],
   mustplace, placeinrow},

  SortBy[Table[
    mustplace = 
     Select[unfinished, 
      availablepos[[#]] - yettoplace[[#]] == 0 && # != i &];
    placeinrow = RandomSample[
      Join[mustplace,
       RandomSample[
        Select[unfinished, # != i && ! MemberQ[mustplace, #] &], 
        m - 1 - Length[mustplace]]
       ], m - 1];
    yettoplace[[placeinrow]]--;
    unfinished = Select[unfinished, yettoplace[[#]] > 0 &];
    availablepos[[unfinished]]--;
    availablepos[[i]]++;
    Join[{i}, placeinrow],
    {i, RandomSample[Range[n], n]}], First]
  ]

This is clearly not optimized for speed and/or golfed, but its memory footprint seems pretty minimal for large lists.

Examples

To check that the returned matrices are valid (according to the criteria in the question) define

validate[matrix_] := 
 With[{n = Length[matrix], m = Length[matrix[[1]]]}, 
  Length /@ Split@Sort@Flatten@matrix == 
   Length /@ DeleteDuplicates /@ matrix == ConstantArray[m, n]]

Then

mat = generatematrix[4, 3]
validate[mat]

(* {{1, 3, 2},
    {2, 4, 1},
    {3, 4, 1},
    {4, 2, 3}} 

True *)

or

mat = generatematrix[9, 9]
validate[mat]

(* {{1, 7, 4, 9, 8, 2, 5, 3, 6}, 
    {2, 4, 6, 5, 9, 3, 7, 1, 8}, 
    {3, 5, 6, 7, 8, 2, 9, 1, 4}, 
    {4, 2, 6, 3, 1, 5, 9, 7, 8}, 
    {5, 8, 9, 2, 3, 6, 4, 7, 1}, 
    {6, 7, 4, 5, 1, 8, 3, 2, 9}, 
    {7, 2, 6, 3, 8, 5, 9, 1, 4}, 
    {8, 7, 4, 1, 5, 3, 2, 9, 6}, 
    {9, 5, 3, 2, 6, 4, 1, 7, 8}}

True *)

To illustrate its robustness, try it on 10,000 random integer pairs {n, m}.

nmlist = {#, RandomInteger[{2, #}]} & /@ RandomInteger[{2, 10}, 10000];
And @@ validate /@ (generatematrix @@@ nmlist)

(* True *)

(Of course, this doesn't prove it can't fail, but I've never seen it do so and suspect it can't.)

Statistics

The OP doesn't make specify much about the statistical properties of the algorithm, but out of curiosity I wanted to check the distributions of the numbers. Generating 10,000 4 by 3 matrices and plotting the occurrences of each number in each position (other than the first position of each row), it turns out that the distribution is pretty uniform (thanks, in large part, to randomizing the order that the rows are taken in).

matrixlist = Table[generatematrix[4, 3], 10000];
counts = Table[
   Count[matrixlist[[;; , i, j]], #] & /@ Range[4], 
 {i, 4}, {j, 2, 3}];
GraphicsRow[
 BarChart3D[counts[[;; , ;; , #]], ChartLayout -> "Grid", 
    ChartLabels -> {Range[4], {2, 3}}, ViewPoint -> {1, -1, 1}, 
    PlotLabel -> ToString[#] <> "s by position"] & /@ Range[4], 
 ImageSize -> 750]