Spurious Correlation

Hermann.Singer@FernUni-Hagen.de

Create arbitrary correlation r_xy  from 2 groups i=1,2  with intragroup correlations r_i



Variance-Covariance decomposition (X=(x,y)):

Cov(X)             = E[ Cov(X|i)]          +     Cov(E[X|i])

total variance = variance(within) + variance(between)



Covariance decomposition:

Cov(x,y)     =  E[ Cov(x,y|i)] + Cov(E[x|i],E[y|i]) 

                                = (∑_i)  p_i Cov(x,y|i) + (Underscript[∑  , i ])p_i (E[x|i]-muex)(E[y|i]-muey)

total variance = variance(within) + variance(between)



Partial correlation:

  version 1 (mean correlation):

      r_xy|i = E[ Cov(x,y|i)/Sqrt(Cov(x|i)Cov(y|i))]

                           =  (∑_i)p_i  Cov(x,y|i) /Sqrt( Cov(x|i) Cov(y|i))

                           =  (∑_i)p_i  Corr(x,y|i) 


 version 2(mean covariance/mean variances):

     r_xy|i  = E[ Cov(x,y|i)]/Sqrt(E[ Cov(x|i)]E[ Cov(y|i)])
 
                           =  (∑_i)p_i Cov(x,y|i) /Sqrt( (∑_i)  p_i Cov(x|i) (∑_i)  p_i Cov(y|i))

simulatedata//Clear
simulatedata[mu_,{sx_,sy_,rho_},n_,seed_]:=
Module[{S,sxy,eps},
SeedRandom[seed];
sxy=sx sy rho;
eps=$MachineEpsilon;
S={{eps+sx^2,sxy},{sxy,eps+sy^2}}//CholeskyDecomposition//Transpose;
Map[(mu+S.#)&,RandomReal[NormalDistribution[0,1],{n,2}]]
]

Manipulate[

data1=simulatedata[μ1,{σ1,ρ1}//Flatten,datapoints1,seed1];
S1=Covariance[data1];
r1=Correlation[data1][[1,2]];

data2=simulatedata[μ2,{σ2,ρ2}//Flatten,datapoints2,seed2];
S2=Covariance[data2];
r2=Correlation[data2][[1,2]];

r=Correlation[Join[data1,data2]][[1,2]];

plr={{-5,5},{-5,5}};

  g1=ListPlot[data1,Joined->False,Frame->True,Axes->False,AspectRatio->1,
                                          PlotRange->plr,PlotStyle->{Opacity[.6],Blue,PointSize[.02]}];

 g2=ListPlot[data2,Joined->False,Frame->True,Axes->False,AspectRatio->1,
                                          PlotRange->plr,PlotStyle->{Opacity[.6],Red,PointSize[.02]}];

n=datapoints1+datapoints2;

p1=datapoints1/n;
p2=datapoints2/n;

rpart1=p1 r1+ p2 r2;

ECov=p1 S1+p2 S2;

rpart2=ECov[[1,2]]/Sqrt[ECov[[1,1]]ECov[[2,2]]];

num=PaddedForm[#,{4,2}]&;
Show[{g1,g2},ImageSize->500, PlotLabel->Style["{r, r1, r2, rpart1, rpart2} = "<>ToString@num[{r,r1,r2,rpart1,rpart2}],Blue,FontSize->18]]

,{{μ1,{2,-2}},{-3,-3},{3,3},Locator},{{σ1,{  1,   1}},{0,0},{2,2}},{{ρ1,.8},-1,1},{seed1,1,100,1},{{datapoints1,100},2,1000,1},
    {{μ2,{-2,2}},{-3,-3},{3,3},Locator},{{σ2,{.5,.5}},{0,0},{2,2}},{{ρ2,.0},-1,1},{seed2,1,100,1},{{datapoints2,100},2,1000,1},

SaveDefinitions->True]