3
$\begingroup$

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]
$\endgroup$
3
$\begingroup$

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]]
$\endgroup$
3
$\begingroup$

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. 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}
$\endgroup$
-2
$\begingroup$
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

enter image description here

equalStatsQ[A, #] & /@ samples

(* {True, True, True, True, True} *)
$\endgroup$
  • 1
    $\begingroup$ I would assume this counts as the trivial case. $\endgroup$ – KraZug Jan 28 at 21:06
  • $\begingroup$ It is a trivial case. $\endgroup$ – Money Oriented Programmer Jan 28 at 21:07

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.