Looking for other integer lists with the same length, quartiles, mean, min, max, and standard deviation

Question

I want to find at least one set, namely B with the same length, quartiles, mean, min, max, standard deviation as A. I have tried as follows but the standard deviation is not the same. The trivial case in which A=B is not my interest.

How to find B programmatically?

A = {0, 5, 5, 10, 10, 10, 10, 30, 30, 35, 40, 40, 40, 50, 55, 100};
B = {0, 0, 10, 10, 10, 10, 30, 30, 30, 35, 35, 35, 45, 45, 45, 100};
Length[A] == Length[B]
Quartiles[A] == Quartiles[B]
Mean[A] == Mean[B]
Min[A] == Min[B]
Max[A] == Max[B]
StandardDeviation[A] == StandardDeviation[B]

Answer 1

Interesting Problem

Just deal with cases where aa = A (best not to use capital letters for variables) has a length that is a power of 2. This means the quartiles and median are averages of points to the left and right of where the quartile and median would be, e.g., the median of {1,2} is their mean, 1.5. Easy to adjust to where they'd coincide with values.

Set the problem up...

SeedRandom[1];
num = 2^3
aa = RandomInteger[200, {num}] // Sort
(* {8, 31, 64, 65, 95, 96, 112, 200} *)

Define the vector of B variables

bvars = Table[b[i], {i, num}]
(* {b[1], b[2], b[3], b[4], b[5], b[6], b[7], b[8]} {b[1], b[2], b[3], b[4], b[5], b[6], b[7], b[8]} *)

Define the linear relationships for Mean, Quartiles, Median, Min, and Max (assumes aa is sorted). We end up with a matrix of rows corresponding to each of properties.

meanRow = Table[1, {num}];
medianRow = minRow = maxRow = q1Row = q3Row = 0 meanRow;
medianRow[[num/2]] = medianRow[[1 + num/2]] = 1;
q1Row[[num/4]] = q1Row[[1 + num/4]] = 1;
q3Row = Reverse@q1Row;
minRow[[1]] = 1;
maxRow = Reverse@minRow;

mat = {meanRow, medianRow, q1Row, q3Row, minRow, maxRow}

Define the linear equalities, ignoring any scaling parameters for mean, and quartiles...

linearEqns = {(mat.bvars) == (mat.aa)}

If the standard deviations are equal, then the variances are equal, and if the means are already enforced to be equal, then the second moments are equal, so define the quadratic equality.

quadEqn = {bvars.bvars == aa.aa}

Define a set of inequalities to enforce sort order

sortInequalities = Table[b[i] <= b[i + 1], {i, num - 1}];

Then find an instance or three

res = FindInstance[Join[linearEqns, sortInequalities, quadEqn], bvars,Integers,4] // Values

$ \left( \begin{array}{cccccccc} 8 & 24 & 71 & 77 & 83 & 104 & 104 & 200 \\ 8 & 31 & 64 & 80 & 80 & 87 & 121 & 200 \\ 8 & 31 & 64 & 65 & 95 & 96 & 112 & 200 \\ 8 & 28 & 67 & 70 & 90 & 95 & 113 & 200 \\ \end{array} \right) $

Check...

 stats[vec_] :=  Map[#[vec] &, {Length, Quartiles, Mean, Min, Max, StandardDeviation}]

Map[stats[#] == stats[aa] &, res]
(* {True, True, True, True} *)

With lengths of variables 16 or greater, it really struggles. Here's a solve for Length[aa]=16

aa = {0, 1, 6, 8, 13, 13, 14, 17, 17, 18, 19, 28, 33, 34, 35, 39}

res = {0, 0, 0, 7, 14, 17, 17, 17, 17, 22, 22, 30, 31, 31, 31, 39}

Answer 2

Using FindInstance[] I found a small example using my own A and B:

A = {0, 1, 2, 3, 6, 7, 8, 10}; B = {0, 1, 2, 4, 5, 6, 9, 10};

The code used was this:

Q8[{a_, b_, c_, d_, e_, f_, g_, h_}] := {(2 b + 2 c)/4, (d + e)/2, (2 f + 2 g)/4}; 

With[{M = 9}, FindInstance[{
  0 < a1 < a2 < a3 < a4 < a5 < a6 < M,
  0 < b1 < b2 < b3 < b4 < b5 < b6 < M,
  a1 != b1 || a2 != b2 || a3 != b3 || a4 != b4 || a5 != b5 || a6 != b6,
  a1 + a2 + a3 + a4 + a5 + a6 == b1 + b2 + b3 + b4 + b5 + b6, 
  a1^2 + a2^2 + a3^2 + a4^2 + a5^2 + a6^2 == 
  b1^2 + b2^2 + b3^2 + b4^2 + b5^2 + b6^2, 
  Q8[{0, a1, a2, a3, a4, a5, a6, M}] == 
  Q8[{0, b1, b2, b3, b4, b5, b6, M}]},
  {a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6}, Integers, 99]]

Using your own A is even easier. My solutions (divided by 5) are:

A = {0, 1, 1, 2, 2, 2, 2, 6, 6, 7, 8, 8, 8, 10, 11, 20};
B1 = {0, 0, 0, 1, 3, 3, 4, 4, 8, 8, 8, 8, 8, 9, 10, 20};
B2 = {0, 0, 0, 2, 2, 2, 5, 5, 7, 7, 8, 8, 8, 10, 10, 20};
B3 = {0, 0, 1, 2, 2, 2, 3, 5, 7, 8, 8, 8, 8, 10, 10, 20};

Using B1 multiplied by 5 gives

B = {0, 0, 0, 5, 15, 15, 20, 20, 40, 40, 40, 40, 40, 45, 50, 100};

My code to find these 4 solutions is:

Q4n[v_List] := With[{n = Length[v]/4}, Table[v[[k*n]] + v[[k*n + 1]], {k, 3}]/2];

With[{M = 10}, FindInstance[{
0 <= b1 <= b2 <= b3 <= b4 <= b5 <= b6 <= b7 <= b8 <= b9 <= b10 <= b11 <= b12 <= b13 <= b14 <= M,
74 == b1 + b2 + b3 + b4 + b5 + b6 + b7 + b8 + b9 + b10 + b11 + b12 + b13 + b14, 
552 == b1^2 + b2^2 + b3^2 + b4^2 + b5^2 + b6^2 + b7^2 + b8^2 + b9^2 + b10^2 + b11^2 + b12^2 + b13^2 + b14^2,
{2, 6, 8} == Q4n[{0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, M}]},
{b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14}, Integers, 99]]

Answer 3

Clear["Global`*"]

equalStatsQ[A_?(VectorQ[#, NumericQ] &), B_?(VectorQ[#, NumericQ] &)] :=
 And @@ (Equal[#[A], #[B]] & /@
    {Length, Quartiles, Mean, Min, Max, StandardDeviation})

A = {0, 5, 5, 10, 10, 10, 10, 30, 30, 35, 40, 40, 40, 50, 55, 100};

B = {0, 0, 10, 10, 10, 10, 30, 30, 30, 35, 35, 35, 45, 45, 45, 100};

equalStatsQ[A, B]

(* False *)

Any random permutation of A will work

SeedRandom[0]

(samples = Table[RandomSample[A, Length@A], {5}]) // Column

equalStatsQ[A, #] & /@ samples

(* {True, True, True, True, True} *)