単純な回帰モデルでは、
OLS推定器とは相関しています。β
2つの推定量の相関関係の式は次のとおりです(正しく導出できた場合)。
質問:
- 相関の存在の直感的な説明は何ですか?
- 相関関係の存在は重要な意味を持ちますか?
投稿は編集され、サンプルサイズとともに相関関係がなくなるという主張は削除されました。(@whuberと@ChristophHanckに感謝します。)
単純な回帰モデルでは、
OLS推定器とは相関しています。β
2つの推定量の相関関係の式は次のとおりです(正しく導出できた場合)。
質問:
投稿は編集され、サンプルサイズとともに相関関係がなくなるという主張は削除されました。(@whuberと@ChristophHanckに感謝します。)
回答:
次のように試してみましょう(それが有用な直観であるかどうかは本当にわかりません):
上記のコメントに基づいて、相関はおおよそ したがって、ではなく場合、ほとんどのデータはゼロの右側にクラスター化されます。したがって、勾配係数が大きくなると、相関式は切片を小さくする必要があると断言します。 E(X)>0E(X)=0
私はこのようなことを考えています:
青色のサンプルでは、勾配の推定値はより平坦です。つまり、切片の推定値が大きくなる可能性があります。金色のサンプルの勾配はいくぶん大きいため、これを補正するために切片をいくらか小さくすることができます。
一方、場合、切片に制約なしで任意の勾配を設定できます。
数式の分母は、これらの線に沿って解釈することもできます測定される変動が増加すると、データは軸上に塗りつぶされ、効果的に「見える」ようになります。 "再び平均がゼロになり、特定の平均に対する切片の制約が緩和されます。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")
あなたは、ドハティさん従うことを好むかもしれない計量経済学入門を、おそらく今あることのために考慮すると、非確率変数であり、かつ、平均二乗偏差の定義する。MSDは、単位の正方形で測定されることに注意してください(例えば場合である次に、MSDがである)、根平均二乗偏差一方、は元のスケールです。これによりx MSD (x )= 1XXセンチセンチ2RMSD(X)=√
これは相関関係が両方の影響を受けているか見るのを助ける必要があります平均の(あれば特に、あなたの傾きと切片の推定量との相関関係が削除された変数を中心に)ともそのことで普及。(この分解により、漸近性がより明確になった可能性もあります!)x
この結果の重要性を繰り返します平均が0でない場合は、差し引くことで変換して、中央に配置できるようにします。我々は回帰直線適合した場合上傾きと切片推定値は無相関である-過小または過大評価一方に他方に過小または過大評価を生成する傾向がありません。しかし、この回帰直線は、回帰直線上の単なる変換です!切片の標準誤差上のの行は、単にの不確実性の尺度であるときに翻訳された可変ˉ X、Y 、X - ˉ X、Y 、X 、Y、Y、X - ˉ X = 0 、Y、X = ˉ X 、Y、X 、Y 、X 、Y、X = 0; その行が元の位置に戻されると、これはでの標準エラーに戻ります。より一般的には、任意の値でのの標準誤差は、適切に変換されたの回帰の切片の標準誤差です。でのの標準誤差は、もちろん、元の未翻訳回帰の切片の標準誤差です。
を変換できるので、ある意味で特別なことはなく、したがって特別なことは何もありません。思考のビットが、私は約のための作品言うことをしていますで任意の値、あなたの回帰直線からの平均応答のための例えば信頼区間への洞察を求めている場合に便利です。ただし、ここではで特別なものがあることを確認しました。これは、回帰線の推定高さの誤差であり、もちろん推定されるためです。X = 0 β 0 、YのX 、Y、X = ˉ X ˉ Y β 0—また、回帰直線の推定勾配の誤差は互いに関係ありません。推定切片はあり、その推定誤差はの推定またはの推定に由来する必要があります(は非-確率的); これら2つの誤差の原因は無相関であることがわかったので、推定された勾配と切片の間に負の相関があるはずであることが代数的に明らかです(勾配の推定は、限り、切片を過小評価する傾向があり)切片および推定平均応答 atˉ Y β 1 X ˉ X < 0 、Y = ˉ Y X = ˉ X。しかし、代数なしでもそのような関係を見ることができます。
推定された回帰直線を定規として想像してください。そのルーラーは通過する必要があり。この線の位置には、本質的に無関係な2つの不確実性があることがわかりました。これは、「ツイニング」不確実性と「平行スライド」不確実性として運動学的に視覚化します。ルーラーをひっくり返す前に、をピボットとして保持し、スロープの不確実性に関連する心のこもったトゥワングを与えます。ルーラーはより激しく揺れますので、傾斜について非常に不確かな場合(実際、不確実性が大きい場合、以前は正の傾斜はおそらく負になります)、での回帰直線の高さに注意してください(ˉ X、ˉ Y)X = ˉ Xこの種の不確実性によって変化することはなく、トゥワングの効果は見た目から離れるほど顕著になります。
ルーラーを「スライド」するには、しっかりとつかみ、上下に移動します。元の位置と平行になるように注意してください。勾配を変更しないでください。上下にどれだけ激しくシフトするかは、回帰線が平均点を通過する際の回帰線の高さに関する不確実性に依存します。軸が平均点を通過するようにが変換された場合、切片の標準誤差はどうなるかを考えてください。また、ここでの回帰直線の推定高さは、単純であるため、、それはまたの標準誤差である。この種の「スライディング」不確実性は、「トワング」とは異なり、回帰直線上のすべての点に等しく影響することに注意してください。、Y ˉ Y ˉ Y
高ので、これら二つの不確実性は、(uncorrelatedly、よく、私たちは正規分布誤差項を仮定した場合、彼らは技術的に独立していなければならない)独立して適用されますあなたの回帰直線上のすべての点のはゼロである「twanging」不確実性の影響を受けています平均とそれから悪化し、どこでも同じ「スライド」不確実性。(前に約束した回帰信頼区間との関係、特に幅が最も狭い方法を見ることができますか?) ˉ X
これはの不確実性が含までの、我々は標準誤差で何を意味するか、本質的である、。今仮定の右にある ; 次に、グラフをより高い推定勾配に変更すると、簡単なスケッチが明らかになるため、推定切片が減少する傾向があります。これは、が正の場合、によって予測される負の相関です。逆に、が左側にある場合、推定された勾配が高いほど、正の値と一致して推定された切片が増加する傾向があることがわかります。、X=0 β 0 ˉ X X=0- ˉ X ˉXˉXX=0ˉXˉX、Y-β1ˉが負の場合に方程式が予測する相関。がゼロから遠い場合、軸に向かう不確実な勾配の回帰線の外挿はますます不安定になることに注意してください( "twang"の振幅は平均から悪化します)。項の "twanging"エラーは、項の "sliding"エラーを大幅に上回るため、エラーはエラーによってほぼ完全に決定されます。。代数的に簡単に検証できるので、MSDまたはエラーの標準偏差を変更せずにを取得するとˉ Y β 0 β 1 ˉ X →±∞SU β 0 β 1∓1場合、とはなる傾向があります。
これを説明するために(画像を右クリックして保存するか、そのオプションが利用可能な場合は新しいタブでフルサイズで表示することをお勧めします)繰り返しサンプリングを検討することを選択しました、ここではiidで、値の固定セットでなので、です。このセットアップでは、推定勾配と切片の間にかなり強い負の相関があり、での推定平均応答間に弱い正の相関がありU 、I〜N (0 、10 2)X ˉ X = 10 E( ˉ Y X= ˉ X ˉ Y ˉ Y ˉ Y ˉ Y ˉ Y、および推定切片。アニメーションは、サンプル(金)回帰線が真(黒)回帰線上に描かれた、いくつかのシミュレートされたサンプルを示しています。2行目は、推定のみ誤差があり、勾配が真の勾配に一致した場合(「スライド」誤差)、推定回帰線のコレクションがどのように見えるかを示しています。次に、勾配にのみ誤差があり、がその母集団の値と一致した場合( "twanging"エラー)。そして最後に、両方のエラーの原因が組み合わされたときに、推定された行のコレクションが実際にどのように見えたのか。これらは実際に推定された切片のサイズによって色分けされています(最初の2つのグラフに示されている、エラーの原因の1つが除去された切片ではありません)低い切片の青から高い切片の赤まで。色からだけでは、我々が持つそのサンプルを見ることができることに注意してください低 とサンプルやったように、低推定インターセプトを生成する傾向が見られた高い推定斜面を。次の行は、推定値のシミュレーション(ヒストグラム)および理論(正規曲線)サンプリング分布を示し、最後の行はそれらの間の散布図を示します。と推定勾配の間に相関がないこと、推定切片と勾配の間に負の相関、切片と間に正の相関があることを観察します。
の分母でMSDは何をしていますか?測定する値の範囲を広げると、勾配をより正確に推定できることがよく知られており、スケッチから直感が明確になりますが、これ以上推定することはできません。MSDをゼロに近づけることを視覚化することをお勧めします(つまり、の平均に非常に近いサンプリングポイントのみ)。これにより、スロープの不確実性が大きくなります。軸がからの距離の場合(つまり、 XˉYY ˉ X ˉ X ≠ 0 、X MSD (X )→ ± ∞ ˉ X ≠ 0 ± 1 ˉ X MSD (X )→ 0)インターセプトの不確実性は、スロープ関連のトゥワングエラーによって完全に支配されることがわかります。対照的に、平均値を変更せずに測定値の広がりを増やすと、勾配推定の精度が大幅に向上し、ラインに最も穏やかなトワングをかけるだけで済みます。インターセプトの高さは、スライドの不確実性によって支配されますが、これは推定スロープとは関係ありません。これは、推定勾配と切片の相関がとしてゼロになる傾向があり、場合はに向かうという代数的事実と(符号は逆です)符号)。
傾きと切片の推定量の相関関係は、両方の関数であったおよびMSD(またはRMSD)の、ので、どのようにそれらの相対的な貢献度はアップ重み付けのですか?実際には、すべての事項ということはあるの比率のRMSDの。幾何学的な直観は、RMSDが一種の「自然単位」を与えるということです。を使用して軸を再スケールすると、これは推定された切片と変更せずに残し、新しいを与え、推定値を乗算する水平ストレッチですのRMSDによる勾配 X ˉ XX W I = X I / RMSD (X )ˉ yの RMSD (W )= 1 、X RMSD (W )ˉ W ˉ X。新しい傾きと切片の推定量の間の相関式は唯一の面である一つであり、そして比で、。切片推定値は変更されず、勾配推定値は正の定数で乗算されるだけなので、それらの間の相関は変化していません。したがって、元の勾配と切片の間の相関ものみに依存する必要があり。代数的に我々は、頂部及び底部を分割し、これを見ることができるによって得ることˉ X - ˉ X RMSD(X)コアー( β 0、 β 1)=- ( ˉ X /RMSD(X))。
との相関を見つけるには、。双線形性により、これはです。最初の項はで、2つ目の項は以前にゼロに設定しました。これから推測します ˉ Y Covを( β 0、 ˉ Y)=Covを( ˉ Y - β 1 ˉ X、 ˉ Y)CovをCovを( ˉ Y、 ˉ Y)- ˉ X Covを( β 1、 ˉ Y)VAR( ˉ Y)=σ 2 U
したがって、この相関関係は、比率のみに依存します。注の二乗そのと合計1へ:私たちはので、これを期待して、すべての(固定のためのサンプリング変動で)は、変動または変動のいずれかが原因であり、これらの変動の原因は互いに相関していません。以下は、比率に対する相関のプロットです。コアー( β 0、 β 1)コアー( β 0、 ˉ Y)X β 0 β 1 ˉ Y ˉ X
プロットは、がRMSDに比べて高い場合、切片推定の誤差が主に勾配推定の誤差に起因し、2つが密接に相関しているのに対し、がRMSDに比べて低い場合を明確に示しています支配的な推定における誤差であり、切片と勾配の関係はより弱くなります。切片と勾配との相関は比奇数関数であるため、その符号は符号に依存し、場合はゼロになります。、一方、切片と相関ˉ X ˉ Y ˉ Xˉ X ˉ X =0 ˉ Y Y ˉ X ˉ X yのコアー( β 0、 ˉ Y)=1は常に正であり、比率の偶数関数です。つまり、が軸のどちら側にあるかは関係ありません。、が軸から1 RMSD離れている場合、相関は大きさが等しくなります。ここで、記号は反対です。上記のシミュレーションの例では、およびなので、平均はから約 RMSDでしたコアー(β0、β1)=±1ˉXˉX=10RMSD(X)≈5.161.93YˉY-軸; この比率では、切片と勾配の相関は強くなりますが、切片と相関はまだ無視できません。
余談ですが、切片の標準誤差の式を考えたいのですが、
の標準誤差のための式のために、及び同で(平均応答の信頼区間のために使用され、そのインターセプトは、翻訳引数を介して前に説明したように、特別なケースです)、Y X=X0
プロットの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 に対する比率のプロットの場合:
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")))