절편과 기울기에 대한 OLS 추정기 간의 상관

간단한 회귀 모형에서

$$y = \beta_0 + \beta_1 x + \varepsilon,$$

OLS 추정기 및 은 서로 관련되어 있습니다.$\hat{\beta}_0^{OLS}$$\hat{\beta}_1^{OLS}$

두 추정기 사이의 상관 관계 공식은 다음과 같습니다.

$$\operatorname{Corr}(\hat{\beta}_0^{OLS},\hat{\beta}_1^{OLS}) = \frac{-\sum_{i=1}^{n}x_i}{\sqrt{n} \sqrt{\sum_{i=1}^{n}x_i^2} }.$$

질문 :

1. 상관의 존재에 대한 직관적 인 설명은 무엇입니까?
2. 상관 관계의 존재에 중요한 의미가 있습니까?

게시물이 편집 되었고 샘플 크기와 상관 관계가 사라진다는 주장이 제거되었습니다. (@whuber와 @ChristophHanck에게 감사합니다.)

다음과 같이 시도해 보겠습니다 (실제로 유용한 직관인지 확실하지 않음).

위의 의견에 따르면 상관 관계는 대략 따라서 대신 이면 대부분의 데이터는 0의 오른쪽에 클러스터됩니다. 따라서, 경사 계수가 커지면, 상관 공식은 절편이 더 작아 질 필요가 있다고 주장합니다.

$$-\frac{E(X)}{\sqrt{E(X^2)}}$$ $E(X)>0$$E(X)=0$

나는 이와 같은 것을 생각하고있다 :

파란색 표본에서 기울기 추정값은 더 평평하므로 절편 추정값이 더 클 수 있습니다. 골든 샘플의 기울기는 다소 크므로이를 보완하기 위해 절편이 다소 작을 수 있습니다.

반면에 이면 절편에 대한 제약없이 기울기를 가질 수 있습니다.$E(X)=0$

공식의 분모도 다음 줄을 따라 해석 할 수 있습니다. 주어진 평균에 대해 로 측정 한 변동성이 증가하면 데이터가 축에 걸쳐 번져서 효과적으로 "보이게됩니다" "더 많은 평균은 제로로, 주어진 평균 에 대한 절편에 대한 제약을 완화합니다 .$E(X^2)$$x$$X$

다음은 그림을 완전히 설명하는 코드입니다.

n <- 30
x_1 <- sort(runif(n,2,3))
beta <- 2
y_1 <- x_1*beta + rnorm(n) # the golden sample

x_2 <- sort(runif(n,2,3)) 
beta <- 2
y_2 <- x_2*beta + rnorm(n) # the blue sample

xax <- seq(-1,3,by=.001)
plot(x_1,y_1,xlim=c(-1,3),ylim=c(-4,7),pch=19,col="gold",ylab="y",xlab="x")
abline(lm(y_1~x_1),col="gold",lwd=2)
abline(v=0,lty=2)
lines(xax,beta*xax) # the "true" regression line
abline(lm(y_2~x_2),col="lightblue",lwd=2)
points(x_2,y_2,pch=19,col="lightblue")

당신은 도허티의 따라하는 것 같아서 계량 경제학에 대한 소개를 아마 것을 지금 고려, 비 확률 변수, 그리고 평균 제곱 편차 정의 X를 할 MSD ( X ) = $x$$x$. MSD는x단위의 제곱으로 측정됩니다(예 :x가cm 인경우 MSD는cm2입니다). 근 평균 제곱 편차,RMSD(x)=$\DeclareMathOperator{\MSD}{MSD}\MSD(x) = \frac{1}{n} \sum_{i=1}^n (x_i - \bar{x})^2$$x$$x$$\text{cm}$$\text{cm}^2$ 가 원래 스케일에 있습니다. 이 결과$\DeclareMathOperator{\RMSD}{RMSD}\RMSD(x)=\sqrt{\MSD(x)}$

$$\DeclareMathOperator{\Corr}{Corr}\Corr(\hat{\beta}_0^{OLS},\hat{\beta}_1^{OLS}) = \frac{-\bar{x}}{\sqrt{\MSD(x) + \bar{x}^2}}$$

이것은 당신이 상관 관계는 모두에 의해 영향을받는 방법을 볼 수 있도록해야한다 평균 의 합니다 (경우 특히, 당신의 기울기와 절편 추정량의 상관 관계가 제거 X의 그것으로도 변수가 중심) 및 확산 . (이 분해로 인해 무증상이 더 분명해 졌을 수도 있습니다!)$x$$x$

이 결과의 중요성을 반복해서 설명하겠습니다. 평균이 0이 아닌 경우 ˉ x 를 빼서 중심에 맞도록 변환 할 수 있습니다 . 우리의 회귀 라인에 맞는 경우 Y 에서 X - ˉ X 기울기와 절편 추정치를 무상관 - 과소 또는 과대 평가 한 나머지의 과소 또는 과대 평가를 생산하는 경향이되지 않습니다에. 그러나이 회귀선은 단순히 x 회귀선 의 y 를 번역 한 것입니다 ! 의 절편의 표준 오차 (Y) 에 X - ˉ X 선 단지 불확실성의 측정은 $x$$\bar{x}$$y$$x - \bar{x}$$y$$x$$y$$x - \bar{x}$$\hat y$번역 된 변수 ; 그 선은 원래의 위치로 되돌아의 표준 오차로 복귀되는이 변환되는 경우 Y 에서 X = ˉ X를 . 보다 일반적으로는, 표준 오차 Y 임의의 X의 값은 회귀의 절편 단지 표준 오차이다 Y 적절히 번역에 X는 ; 표준 오차 Y 에서 X = 0 원래 미번역 회귀 절편 물론 표준 오차이다.$x - \bar x = 0$$\hat y$$x = \bar x$$\hat y$$x$$y$$x$$\hat y$$x=0$

우리가 번역 할 수 있기 때문에 , 어떤 의미에서 아무것도 특별한 약이 X = 0 에 대한 때문에 아무것도 특별한 β 0 . 생각의 비트와 함께, 나는 약에 대한 작품 무슨 말을 나는 Y를 에서 어떤 값 X 당신이 당신의 회귀선에서 평균 응답 예를 들어, 신뢰 구간에 대한 통찰력을 추구하는 경우에 유용합니다. 그러나, 우리는이 것을 본 것입니다 에 대해 뭔가 특별한 Y 에서 X = ˉ X , 그것은 여기에 대한 그 회귀선의 추정 높이의 오류 - 코스에서 추정이다$x$$x=0$$\hat \beta_0$$\hat y$$x$$\hat y$$x=\bar x$ — 회귀선 추정 경사의 오차는 서로 관련이 없습니다. 예상 절편 인 β 0= ˉ Y - β 1 ˉ X 및 추정의 추정으로부터 기인 할 필요 에러 ˉ Y 또는 추정 β 1(우리는 이후 간주X비 확률 등)를; 지금 우리는 오류의 두 가지 소스가 너무 오래로, 추정 된 기울기와 절편 (과소 평가 요격하는 경향이 경사를 과대 평가 간의 음의 상관 관계가 있어야한다 대수적 이유는 분명하다 상관 알고$\bar y$$\hat \beta_0 = \bar y - \hat \beta_1 \bar x$$\bar y$$\hat \beta_1$$x$)이지만 추정 가로 추정 평균 응답 사이의 양의 상관 관계 Y = ˉ Y 에서X= ˉ X . 그러나 대수 없이도 그러한 관계를 볼 수 있습니다.$\bar x < 0$$\hat y = \bar y$$x = \bar x$

추정 된 회귀선을 통치자로 상상해보십시오. 즉 눈금자 통과한다 . 우리는이 선의 위치에 본질적으로 관련이없는 두 가지 불확실성이 있음을 보았습니다. 나는 이것을 "광채"불확실성과 "병렬 슬라이딩"불확실성으로 키네마 틱으로 시각화합니다. 통치자를 속이기 전에 ( ˉ x , ˉ y$(\bar x, \bar y)$$(\bar x, \bar y)$피벗으로, 경사면의 불확실성과 관련된 풍성한 광채를 제공하십시오. 눈금자는 좋은 흔들림을 가지며, 더 격렬하게 기울기에 대해 매우 불확실 할 경우 (실제로 불확실성이 크면 이전에 양의 기울기가 음으로 표시 될 수 있음) 에서 회귀선의 높이 = = ˉ x 는 이런 종류의 불확실성에 의해 변하지 않으며, twang의 효과는 당신이 보는 평균으로부터 더 두드러집니다.$x=\bar x$

눈금자를 "슬라이드"하려면 원래 위치와 평행을 유지하도록주의하면서 단단히 잡고 위 아래로 이동하십시오. 경사를 바꾸지 마십시오! 위아래로 얼마나 활발하게 이동하는지는 회귀선이 평균점을 통과 할 때의 높이에 대해 얼마나 불확실한 지에 달려 있습니다. y 축이 평균점을 통과 하도록 가 변환 된 경우 절편의 표준 오차가 무엇인지 생각해보십시오 . 여기에서 회귀 직선의 추정 된 높이가 간단하기 때문에 또는, ˉ Y를 , 또한 표준 오차이다 ˉ Y . 이런 종류의 "슬라이딩"불확실성은 "twang"과 달리 회귀선의 모든 점에 동일한 방식으로 영향을 미칩니다.$x$$y$$\bar y$$\bar y$

이 두 가지 불확실성이 독립적으로 (우리가 다음 정규 분포 오류 조건을 가정하면 아니라, uncorrelatedly하지만 기술적으로 독립적이어야 함) 높이의 있도록 적용 Y 귀하의 회귀 라인에있는 모든 포인트의에서 0을하는 "twanging"불확실성에 의해 영향을받는 그 의미는 점점 나 빠지고, 어디에서나 동일한 "미끄럼"불확실성입니다. (앞서 약속 한 회귀 신뢰 구간과의 관계, 특히 너비가 ˉ x 에서 가장 좁은 방식을 알 수 있습니까?)$\hat y$$\bar x$

이는 불확도에 포함 Y 에서 X = 0 우리가 표준 오차는 무엇을 의미하는 본질적으로, β 는 0 . 이제 ˉ x 가 x = 0 의 오른쪽에 있다고 가정하자 . 그런 다음 그래프를 더 높은 추정 기울기로 조정하면 빠른 스케치에서 알 수 있듯이 추정 차단이 감소하는 경향이 있습니다. 이것은 − ˉ x에 의해 예측 된 음의 상관 관계입니다.$\hat y$$x=0$$\hat \beta_0$$\bar x$$x=0$ˉx가 양수인경우 MSD ( x ) + ˉ x 2 반대로,ˉx가x=0의 왼쪽이면추정 기울기가 높을수록interx가 음일때 방정식이 예측하는양의상관 관계에 따라추정 절편이 증가하는 경향이 있음을 알 수있습니다. 참고 경우 것을ˉx는0에서 길이 방향의 향해 확실 구배의 회귀 직선의 추정이며$\frac{-\bar{x}}{\sqrt{\MSD(x) + \bar{x}^2}}$$\bar x$$\bar x$$x=0$$\bar x$$\bar x$$y$축이 점점 더 불안정 해집니다 ( "twang"의 진폭이 평균에서 멀어짐). 에서 "twanging"에러 - 기간은의 "슬라이딩"오류 능가 대규모 것 ˉ Y 의 오차 있도록 용어를 β , 0은 거의 임의의 에러에 의해 결정된다 β 1 . 당신은 쉽게 수학적으로 확인, 우리가 가지고가는 경우 바와 같이 ˉ X → ± ∞ 엠에스디 또는 오류의 표준 편차 변경하지 않고 의 U 사이의 상관 관계를 β 0 $- \hat \beta_1 \bar x$$\bar y$$\hat \beta_0$$\hat \beta_1$$\bar x \to \pm \infty$$s_u$$\hat \beta_0$경향∓1.$\hat \beta_1$$\mp 1$

이것을 설명하기 위해 (이미지를 마우스 오른쪽 버튼으로 클릭하고 저장하거나 해당 옵션을 사용할 수있는 경우 새 탭에서 전체 크기로 볼 수 있습니다) 의 반복 샘플링을 고려했습니다. X 난 + U를 I를 , 여기서 U I ~ N ( 0 , 10 (2) ) 의 고정 된 세트를 통해 IID되는 X의 값 ˉ X = 10 이므로 E ( ˉ Y ) = $y_i = 5 + 2x_i + u_i$$u_i \sim N(0, 10^2)$$x$$\bar x = 10$$\mathbb{E}(\bar y)=25$. 이 설정에서는 추정 기울기와 절편 사이에 상당히 강한 음의 상관 관계가 있으며, , x = ˉ x 에서 추정 평균 응답 및 추정 절편 사이에는 약한 양의 상관 관계가 있습니다. 애니메이션은 실제 (회색) 회귀선 위에 그려진 샘플 (금) 회귀선과 함께 여러 시뮬레이션 된 샘플을 보여줍니다. 두 번째 행은 추정 된 ˉ y 에만 오류가 있고 경사가 실제 경사와 일치하는 경우 ( "슬라이딩"오류) 추정 된 회귀선 모음이 어떻게 보이는지 보여줍니다 . 경사면에만 오차가 있고 ˉ $\bar y$$x=\bar x$$\bar y$$\bar y$모집단 값과 일치 함 ( "twanging"오류); 마지막으로, 두 가지 오류 원인이 결합되었을 때 추정 된 선의 모음이 실제로 어떻게 보이는지. 낮은 인터셉트의 경우 파란색에서 높은 인터셉트의 경우 빨간색 으로, 실제로 추정 된 인터셉트 (오류 소스 중 하나가 제거 된 처음 두 그래프에 표시된 인터셉트가 아님) 의 크기 로 색상이 구분 됩니다 . 색상만으로도 ˉ y 가 낮은 표본은 추정 된 절편이 더 높은 경향이 있음을 알 수 있습니다.$\bar y$예상 경사. 다음 행은 추정치의 시뮬레이션 된 (히스토그램) 및 이론적 (정규 곡선) 샘플링 분포를 보여주고 마지막 행은 이들 사이의 산점도를 보여줍니다. 와 추정 기울기 사이의 상관 관계, 추정 된 절편과 기울기 사이의 음의 상관 관계 및 절편과 ˉ y 사이의 양의 상관 관계 가 없는지 관찰하십시오 .$\bar y$$\bar y$

무엇이 MSD는의 분모로하고있다 ? 측정 한x값의 범위를 넓히면기울기를보다 정확하게 추정 할 수 있으며 스케치를 통해 직관이 명확하지만ˉy를더 잘추정 할 수는 없습니다. MSD를 거의 0에 가깝게 (즉, 샘플링 포인트는x의 평균에 거의 근접 함)시각화하는 것이 좋습니다. 따라서 경사면의 불확실성이 커집니다. y축이ˉx와거리가있는경우(즉,ˉx≠$\frac{-\bar{x}}{\sqrt{\MSD(x) + \bar{x}^2}}$$x$$\bar y$$x$$y$$\bar x$$\bar x \neq 0$) 절편의 불확실성이 경사 관련 텅잉 오차에 의해 완전히 지배된다는 것을 알 수 있습니다. 대조적으로, 평균을 변경하지 않고 측정 의 확산을 늘리면 기울기 추정의 정확도가 크게 향상되고 선에 가장 온화한 선단을 취하면됩니다. 절편의 높이는 이제 슬라이딩 불확실성에 의해 좌우되는데, 이는 예상 경사와 무관합니다. 이것은 추정 기울기와 절편 사이의 상관 관계가 MSD ( x ) → ± ∞ 이고 ˉ x ≠ 0 일 때 ± 1 으로 0 이되는 경향이 있다는 대수 사실과 함께 계산됩니다.$x$$\MSD(x) \to \pm \infty$$\bar x \neq 0$$\pm 1$(부호의 부호가 반대이다 등) MSD ( X ) → 0 .$\bar x$$\MSD(x) \to 0$

기울기와 절편 추정량의 상관 관계의 함수이었다 모두 와의 MSD (또는 RMSD) x는 , 어떻게 자신의 상대적 기여도 무게를합니까? 사실, 모든 문제 있다는 것은입니다 비율 ˉ X 의 RMSD에 X는 . 기하학적 직관은 RMSD가 우리에게 x에 대해 일종의 "자연 단위"를 제공한다는 것입니다 . w i = x i / RMSD ( x ) 를 사용하여 x 축의 크기를 재조정하면 수평 절편으로 추정 된 절편을 남기고 un y를 변경하지 않고 새로운 값을줍니다.$\bar x$$x$$\bar x$$x$$x$$x$$w_i = x_i / \RMSD(x)$$\bar y$ 이고 추정 기울기에 x 의 RMSD를 곱합니다. 새로운 기울기와 추정 인터셉터 사이의 상관 공식은 RMSD ( w ) 1과 ˉ w , 즉 ˉ $\RMSD(w)=1$$x$$\RMSD(w)$$\bar w$ . 절편 추정치가 변경되지 않았고 기울기 추정치에 양의 상수를 곱한 값과의 상관 관계는 변경되지 않았습니다. 따라서원래기울기와 절편간의 상관 관계는 ˉ x 에만 의존해야합니다.$\frac{\bar x}{\RMSD(x)}$ . 수학적으로 우리는 상단과 하단을 구분하여 볼 수 있습니다- ˉ $\frac{\bar x}{\RMSD(x)}$ 로RMSD(여기서 x)을 얻었다CORR을( β 0, β 1)=-( ˉ X /RMSD(X)$\frac{-\bar x}{\sqrt{\MSD(x)+\bar{x}^2}}$$\RMSD(x)$ .$\Corr\left(\hat \beta_0, \hat \beta_1 \right) = \frac{- (\bar x / \RMSD(x))}{\sqrt{1 + (\bar x / \RMSD(x))^2}}$

사이의 상관 관계를 찾으려면 β 0 과 ˉ Y를 고려 COV ( β 0 , ˉ Y ) = COV ( ˉ Y를 - β 1 ˉ X , ˉ Y ) . 의 bilinearity으로 COV 이것이 COV ( ˉ Y , ˉ Y ) - ˉ X COV ( β 1 , ˉ Y )$\hat \beta_0$$\bar y$$\DeclareMathOperator{\Cov}{Cov}\Cov(\hat \beta_0, \bar y)=\Cov(\bar y - \hat \beta_1 \bar x, \bar y)$$\Cov$$\Cov(\bar y, \bar y) - \bar x \Cov(\hat \beta_1, \bar y)$. 첫 번째 항은 두 번째 항은 0으로 설정했습니다. 이것에서 우리는 추론$\operatorname{Var}(\bar y)=\frac{\sigma_u^2}{n}$

$$\Corr(\hat \beta_0, \bar y)=\frac{1}{\sqrt{1 + (\bar x/\RMSD(x))^2}}$$

따라서이 상관 관계는 ˉ x 비율에만 의존합니다. . 의 제곱 유의CORR( β 0, β 1)및CORR가( β 0, ˉ Y )하나 합 : 우리는 이후이 기대하는 모든(고정 용 샘플링 변이X)에서 β 0중 변화에 기인 에서 β 1또는 변형 예에 ˉ Y 및 변동이 소스가 서로 무상관. 다음은 비율에 대한 상관 관계의 도표입니다$\frac{\bar x}{\RMSD(x)}$$\Corr(\hat \beta_0, \hat \beta_1)$$\Corr(\hat \beta_0, \bar y)$$x$$\hat \beta_0$$\hat \beta_1$$\bar y$ .$\frac{\bar x}{\RMSD(x)}$

어떻게하면 플롯이 명확히 도시 높은 RMSD 상대가 , 절편 추정 오류로 인해 경사 추정치의 에러에 크게하며 때 반면 두 개의 밀접하게 상관되어 ˉ X 것은 낮은 RMSD 상대는 ,이 에러가 우세한 ˉ y 의 추정에서 절편과 기울기 사이의 관계는 약하다. 참고 기울기 절편의 상관 비율의 홀수 함수가 있음 ˉ $\bar x$$\bar x$$\bar y$ , 그 부호의 부호에 의존하므로 ˉ X 하고 제로이면 ˉ X =0와 절편의 상관 반면 ˉ Y는 항상 긍정적이고, 즉 그것은하지 않는 비율 짝수 함수 어떤 쪽의 상관Y시킴으로써 행한다 그 ˉ X IS한다. 만약 상관 관계는 크기가 동일 ˉ X는 하나 RMSD 멀리 내지Y는시킴으로써 행한다 때CORR( β 0, ˉ Y )=$\frac{\bar x}{\RMSD(x)}$$\bar x$$\bar x=0$$\bar y$$y$$\bar x$$\bar x$$y$및CORR(β0,β1)=±$\Corr(\hat \beta_0, \bar y)=\frac{1}{\sqrt{2}} \approx 0.707$부호가ˉx와 반대 인 2 ≈±0.707. 위 시뮬레이션의 예에서,ˉx=10및RMSD(x)≈5.16이므로 평균은y축에서약1.93RMSD였습니다. 이 비율에서 절편과 기울기 사이의 상관 관계는 더 강하지 만 절편과ˉy사이의 상관 관계는 여전히 무시할 수 없습니다.$\Corr(\hat \beta_0, \hat \beta_1)=\pm \frac{1}{\sqrt{2}} \approx \pm 0.707$$\bar x$$\bar x=10$$\RMSD(x) \approx 5.16$$1.93$$y$$\bar y$

옆으로, 나는 절편의 표준 오차에 대한 공식을 생각하고 싶습니다.

$$\operatorname{s.e.}(\hat \beta_0^{OLS}) = \sqrt{s_u^2 \left( \frac{1}{n} + \frac{{\bar x}^2 }{n \MSD(x)} \right) }$$

같은 의 표준 오차에 대한 수식 및 동을 Y 에서X=X0(평균 응답을 신뢰 구간에 사용되며 I는 번역을 통해 앞서 설명한 바와 같이 어느 절편은 특별한 경우 논의),$\sqrt{\text{sliding error} + \text{twanging error}}$$\hat y$$x = x_0$

$$\operatorname{s.e.}(\hat y) = \sqrt{s_u^2 \left( \frac{1}{n} + \frac{(x_0 - \bar x)^2}{n \MSD(x)} \right) }$$

플롯의 R 코드

require(graphics)
require(grDevices)
require(animation

#This saves a GIF so you may want to change your working directory
#setwd("~/YOURDIRECTORY")
#animation package requires ImageMagick or GraphicsMagick on computer
#See: http://www.inside-r.org/packages/cran/animation/docs/im.convert
#You might only want to run up to the "STATIC PLOTS" section
#The static plot does not save a file, so need to change directory.

#Change as desired
simulations <- 100 #how many samples to draw and regress on
xvalues <- c(2,4,6,8,10,12,14,16,18) #used in all regressions
su <- 10 #standard deviation of error term
beta0 <- 5 #true intercept
beta1 <- 2 #true slope
plotAlpha <- 1/5 #transparency setting for charts
interceptPalette <- colorRampPalette(c(rgb(0,0,1,plotAlpha),
            rgb(1,0,0,plotAlpha)), alpha = TRUE)(100) #intercept color range
animationFrames <- 20 #how many samples to include in animation

#Consequences of previous choices
n <- length(xvalues) #sample size
meanX <- mean(xvalues) #same for all regressions
msdX <- sum((xvalues - meanX)^2)/n #Mean Square Deviation
minX <- min(xvalues)
maxX <- max(xvalues)
animationFrames <- min(simulations, animationFrames)

#Theoretical properties of estimators
expectedMeanY <- beta0 + beta1 * meanX
sdMeanY <- su / sqrt(n) #standard deviation of mean of Y (i.e. Y hat at mean x)
sdSlope <- sqrt(su^2 / (n * msdX))
sdIntercept <- sqrt(su^2 * (1/n + meanX^2 / (n * msdX)))


data.df <- data.frame(regression = rep(1:simulations, each=n),
                      x = rep(xvalues, times = simulations))

data.df$y <- beta0 + beta1*data.df$x + rnorm(n*simulations, mean = 0, sd = su) 

regressionOutput <- function(i){ #i is the index of the regression simulation
  i.df <- data.df[data.df$regression == i,]
  i.lm <- lm(y ~ x, i.df)
  return(c(i, mean(i.df$y), coef(summary(i.lm))["x", "Estimate"],
          coef(summary(i.lm))["(Intercept)", "Estimate"]))
}

estimates.df <- as.data.frame(t(sapply(1:simulations, regressionOutput)))
colnames(estimates.df) <- c("Regression", "MeanY", "Slope", "Intercept")

perc.rank <- function(x) ceiling(100*rank(x)/length(x))
rank.text <- function(x) ifelse(x < 50, paste("bottom", paste0(x, "%")), 
                                paste("top", paste0(101 - x, "%")))
estimates.df$percMeanY <- perc.rank(estimates.df$MeanY)
estimates.df$percSlope <- perc.rank(estimates.df$Slope)
estimates.df$percIntercept <- perc.rank(estimates.df$Intercept)
estimates.df$percTextMeanY <- paste("Mean Y", 
                                    rank.text(estimates.df$percMeanY))
estimates.df$percTextSlope <- paste("Slope",
                                    rank.text(estimates.df$percSlope))
estimates.df$percTextIntercept <- paste("Intercept",
                                    rank.text(estimates.df$percIntercept))

#data frame of extreme points to size plot axes correctly
extremes.df <- data.frame(x = c(min(minX,0), max(maxX,0)),
              y = c(min(beta0, min(data.df$y)), max(beta0, max(data.df$y))))

#STATIC PLOTS ONLY

par(mfrow=c(3,3))

#first draw empty plot to reasonable plot size
with(extremes.df, plot(x,y, type="n", main = "Estimated Mean Y"))
invisible(mapply(function(a,b,c) { abline(a, b, col=c) }, 
                 estimates.df$Intercept, beta1, 
                 interceptPalette[estimates.df$percIntercept]))

with(extremes.df, plot(x,y, type="n", main = "Estimated Slope"))
invisible(mapply(function(a,b,c) { abline(a, b, col=c) }, 
                 expectedMeanY - estimates.df$Slope * meanX, estimates.df$Slope, 
                 interceptPalette[estimates.df$percIntercept]))

with(extremes.df, plot(x,y, type="n", main = "Estimated Intercept"))
invisible(mapply(function(a,b,c) { abline(a, b, col=c) }, 
                 estimates.df$Intercept, estimates.df$Slope, 
                 interceptPalette[estimates.df$percIntercept]))

with(estimates.df, hist(MeanY, freq=FALSE, main = "Histogram of Mean Y",
                        ylim=c(0, 1.3*dnorm(0, mean=0, sd=sdMeanY))))
curve(dnorm(x, mean=expectedMeanY, sd=sdMeanY), lwd=2, add=TRUE)

with(estimates.df, hist(Slope, freq=FALSE, 
                        ylim=c(0, 1.3*dnorm(0, mean=0, sd=sdSlope))))
curve(dnorm(x, mean=beta1, sd=sdSlope), lwd=2, add=TRUE)

with(estimates.df, hist(Intercept, freq=FALSE, 
                        ylim=c(0, 1.3*dnorm(0, mean=0, sd=sdIntercept))))
curve(dnorm(x, mean=beta0, sd=sdIntercept), lwd=2, add=TRUE)

with(estimates.df, plot(MeanY, Slope, pch = 16,  col = rgb(0,0,0,plotAlpha), 
                        main = "Scatter of Slope vs Mean Y"))

with(estimates.df, plot(Slope, Intercept, pch = 16, col = rgb(0,0,0,plotAlpha),
                        main = "Scatter of Intercept vs Slope"))

with(estimates.df, plot(Intercept, MeanY, pch = 16, col = rgb(0,0,0,plotAlpha),
                        main = "Scatter of Mean Y vs Intercept"))


#ANIMATED PLOTS

makeplot <- function(){for (i in 1:animationFrames) {

  par(mfrow=c(4,3))

  iMeanY <- estimates.df$MeanY[i]
  iSlope <- estimates.df$Slope[i]
  iIntercept <- estimates.df$Intercept[i]

  with(extremes.df, plot(x,y, type="n", main = paste("Simulated dataset", i)))
  with(data.df[data.df$regression==i,], points(x,y))
  abline(beta0, beta1, lwd = 2)
  abline(iIntercept, iSlope, lwd = 2, col="gold")

  plot.new()
  title(main = "Parameter Estimates")
  text(x=0.5, y=c(0.9, 0.5, 0.1), labels = c(
    paste("Mean Y =", round(iMeanY, digits = 2), "True =", expectedMeanY),
    paste("Slope =", round(iSlope, digits = 2), "True =", beta1),
    paste("Intercept =", round(iIntercept, digits = 2), "True =", beta0)))

  plot.new()
  title(main = "Percentile Ranks")
  with(estimates.df, text(x=0.5, y=c(0.9, 0.5, 0.1),
                          labels = c(percTextMeanY[i], percTextSlope[i],
                                     percTextIntercept[i])))


  #first draw empty plot to reasonable plot size
  with(extremes.df, plot(x,y, type="n", main = "Estimated Mean Y"))
  invisible(mapply(function(a,b,c) { abline(a, b, col=c) }, 
                   estimates.df$Intercept, beta1, 
                   interceptPalette[estimates.df$percIntercept]))
  abline(iIntercept, beta1, lwd = 2, col="gold")

  with(extremes.df, plot(x,y, type="n", main = "Estimated Slope"))
  invisible(mapply(function(a,b,c) { abline(a, b, col=c) }, 
                expectedMeanY - estimates.df$Slope * meanX, estimates.df$Slope, 
                interceptPalette[estimates.df$percIntercept]))
  abline(expectedMeanY - iSlope * meanX, iSlope,
         lwd = 2, col="gold")

  with(extremes.df, plot(x,y, type="n", main = "Estimated Intercept"))
  invisible(mapply(function(a,b,c) { abline(a, b, col=c) }, 
                   estimates.df$Intercept, estimates.df$Slope, 
                   interceptPalette[estimates.df$percIntercept]))
  abline(iIntercept, iSlope, lwd = 2, col="gold")

  with(estimates.df, hist(MeanY, freq=FALSE, main = "Histogram of Mean Y",
                          ylim=c(0, 1.3*dnorm(0, mean=0, sd=sdMeanY))))
  curve(dnorm(x, mean=expectedMeanY, sd=sdMeanY), lwd=2, add=TRUE)
  lines(x=c(iMeanY, iMeanY),
        y=c(0, dnorm(iMeanY, mean=expectedMeanY, sd=sdMeanY)),
        lwd = 2, col = "gold")

  with(estimates.df, hist(Slope, freq=FALSE, 
                          ylim=c(0, 1.3*dnorm(0, mean=0, sd=sdSlope))))
  curve(dnorm(x, mean=beta1, sd=sdSlope), lwd=2, add=TRUE)
  lines(x=c(iSlope, iSlope), y=c(0, dnorm(iSlope, mean=beta1, sd=sdSlope)),
        lwd = 2, col = "gold")

  with(estimates.df, hist(Intercept, freq=FALSE, 
                          ylim=c(0, 1.3*dnorm(0, mean=0, sd=sdIntercept))))
  curve(dnorm(x, mean=beta0, sd=sdIntercept), lwd=2, add=TRUE)
  lines(x=c(iIntercept, iIntercept),
        y=c(0, dnorm(iIntercept, mean=beta0, sd=sdIntercept)),
        lwd = 2, col = "gold")

  with(estimates.df, plot(MeanY, Slope, pch = 16,  col = rgb(0,0,0,plotAlpha), 
                          main = "Scatter of Slope vs Mean Y"))
  points(x = iMeanY, y = iSlope, pch = 16, col = "gold")

  with(estimates.df, plot(Slope, Intercept, pch = 16, col = rgb(0,0,0,plotAlpha),
                          main = "Scatter of Intercept vs Slope"))
  points(x = iSlope, y = iIntercept, pch = 16, col = "gold")

  with(estimates.df, plot(Intercept, MeanY, pch = 16, col = rgb(0,0,0,plotAlpha),
                          main = "Scatter of Mean Y vs Intercept"))
  points(x = iIntercept, y = iMeanY, pch = 16, col = "gold")

}}

saveGIF(makeplot(), interval = 4, ani.width = 500, ani.height = 600)

상관 관계 대 대 RMSD의 비율의 도표 :$\bar x$

require(ggplot2)

numberOfPoints <- 200
data.df  <- data.frame(
  ratio = rep(seq(from=-10, to=10, length=numberOfPoints), times=2),
  between = rep(c("Slope", "MeanY"), each=numberOfPoints))
data.df$correlation <- with(data.df, ifelse(between=="Slope",
  -ratio/sqrt(1+ratio^2),
  1/sqrt(1+ratio^2)))

ggplot(data.df, aes(x=ratio, y=correlation, group=factor(between),
                    colour=factor(between))) +
  theme_bw() + 
  geom_line(size=1.5) +
  scale_colour_brewer(name="Correlation between", palette="Set1",
                      labels=list(expression(hat(beta[0])*" and "*bar(y)),
                              expression(hat(beta[0])*" and "*hat(beta[1])))) +
  theme(legend.key = element_blank()) +
  ggtitle(expression("Correlation of intercept estimates with slope and "*bar(y))) +
  xlab(expression("Ratio of "*bar(X)/"RMSD(X)")) +
  ylab(expression(paste("Correlation")))