The permutation of given number sequence that has specific correlation with another

Question

I am interested in the relationship between the Pearson correlation coefficients and the permutations of two random number sequences.

An initial Mathematica study is as below:

SeedRandom[1]
(data=RandomReal[1,{30,2}])//MatrixForm;
Correlation[data[[All,1]],data[[All,2]]]
Correlation[Sort@data[[All,1]],data[[All,2]]]
Correlation[Sort@data[[All,1]],Sort@data[[All,2]]]
Correlation[Sort@data[[All,1]],Sort[#,Greater]&@data[[All,2]]]

Outputs are:

-0.0615673 (*correlation coefficient of the original order*)
0.209375 (*sorting the first sequence*)
0.981946 (*sorting both the two sequences in the same order*)
-0.964172 (*sorting both the two sequences in converse order*)

My questions are:

1. How can I find the permutation(s) when the correlation coefficient of the two sequences is the closest to zero?

2. Given a number between the minimum (-0.964172 for this case) and the maximum (0.981946 for this case), how to find the right permutations of which the correlation coefficient of the two sequences are closest to the given number?

I tried to use Permutations and then search(or Optimize/NMinimize) in the permutation space, but always encountered into SystemException["MemoryAllocationFailure"]

Answer 1

It's not surprising that you receive SystemException["MemoryAllocationFailure"] because 30!=265252859812191058636308480000000.

SeedRandom[1];
data = RandomReal[1, {30, 2}];

Correlation[data[[;; , 1]], data[[;; , 2]]]

-0.0615673

Okay. Now we will searching permutation when the correlation coefficient of the two sequences is the closest to zero.

We can reformulate the problem as searching covariance closest to zero.

n1 = (# - Mean[#]) &@data[[;; , 1]];
n2 = (# - Mean[#]) &@data[[;; , 2]];
u = Table[Unique["x"], {30}, {30}];

sol = NMinimize[
    {
     n1.u.n2,
     n1.u.n2 >= 0.,
     Thread[Total[u[[#]]] == 1] & /@ Range[30],
     Thread[Total[u[[;; , #]]] == 1] & /@ Range[30],
     Thread[Flatten[u] > 0],
     Thread[Flatten[u] \[Element] Integers]
     },
    Flatten[u]
    ]; // AbsoluteTiming

(* {25.4994, Null} *)

perm = (u /. sol[[2]]).n2 + Mean[data[[;; , 2]]];

Correlation[data[[;; , 1]], perm]

2.34369*10^-7

And now answer on your second question. For example, we would like to see correlation closest to 0.2.

k = 0.2*29*StandardDeviation[data[[;; , 1]]]*StandardDeviation[data[[;; , 2]]]

Number 29 is from the covariance formula:

Length[v1] = 30 and minus 1 equals 29.

sol2 = NMinimize[
    {
     n1.u.n2,
     n1.u.n2 >= k,
     Thread[Total[u[[#]]] == 1] & /@ Range[30],
     Thread[Total[u[[;; , #]]] == 1] & /@ Range[30],
     Thread[Flatten[u] > 0],
     Thread[Flatten[u] \[Element] Integers]
     },
    Flatten[u]
    ]; // AbsoluteTiming

(* {10.0725, Null} *)

perm = (u /. sol2[[2]]).n2 + Mean[data[[;; , 2]]];

Correlation[data[[;; , 1]], perm]

0.200001