線形モデル3:
連続×カテゴリの
多重線形回帰
分散分析と線形回帰の組み合わせ技
これまでカテゴリカル変数の解析は分散分析、連続変数の解析は線形回帰、と区別して紹介してきた。実はこれらの変数は、一緒に説明変数に組み込むことが可能である。つまり、説明変数にカテゴリカル変数と連続変数が混在していてもよいし、連続変数が複数含まれていてもよい。このような、連続変数×カテゴリカル変数、連続変数×連続変数のような解析を多重線形回帰multiple linear regression、あるいは単に重回帰とよぶ。本項では連続変数とカテゴリカル変数が説明変数の重回帰を紹介し、連続変数が複数含まれる解析は次回に紹介する。
では、連続変数xと2水準(A、B)を持つカテゴリカル変数gのモデルはどうなるだろうか。線形モデルの表記にならって下記のようになる。カテゴリカル変数は2水準だけなので下記の一本の式で十分だ(Aのときはg = 0、Bのときはg = 1)。
y ~ b1 + b2 x + b3 g + b4 (x × g)
この式はどんなデータの状況を想定していることになるだろうか。以下のように変形するとわかりやすくなる。
y ~ (b1 + b3 g) + (b2 + b4 g) x
カテゴリカル変数がAのとき、g = 0を代入すれば、
y ~ b1 + b2 x
カテゴリカル変数がBのとき、g = 1を代入すれば、
y ~ (b1 + b3) + (b2 + b4) x
このように、カテゴリカル変数によって傾きと切片が異なる直線を推定してることになる。もし、交互作用を考慮しない(b4 = 0と仮定)ならば、カテゴリカル変数がAのとき、g = 0を代入すれば、
y ~ b1 + b2 x
カテゴリカル変数がBのとき、g = 1を代入すれば、
y ~ (b1 + b3) + b2 x
となり、2本の直線は切片が異なり、傾きは等しい、平行な直線を推定することになり、以前紹介したような交互作用がなければ平行、あれば平行ではない、という関係が強調されていることになる。このような、交互作用を考慮しない(ないと仮定できる)、連続変数×カテゴリカル変数の多重線形回帰を共分散分析(Analysis of covariance、ANCOVA)と呼ぶこともある。帰無仮説は今までと同様に、残差が平均0の正規分布に従うと仮定し、「b1 = 0、b2 = 0、b3 = 0、b4 = 0」である。
係数の推定
係数の推定は線形回帰で紹介したように最小二乗法を用いる。線形回帰の時に明らかになったことを使いまわすことで比較的簡単に示すことができる。
これの意味するところは、まず、g = 0のときその水準に含まれる標本を単独で線形回帰することで、b1とb2の推定値を得ることができる。次に、g = 1のとき、その水準に含まれる標本だけで線形回帰をするとb1 + b3を切片、b2 + b4を傾きとする推定値が得られる。ここから、g = 0のときの推定値b1、b2を差し引けばb3、b4が求まるという寸法だ。それほど難しいことではないだろう。
多重線形回帰の検出力
さて、今回もシミュレートしてみよう。次のようにb1 ≠ 0、b2、b3、b4 = 0のデータを生成して、線形回帰を行う。
------------------------------------------------------
library(plotn)
cols <- col_genelator(number = 2, alpha = 1)
fils <- col_genelator(number = 2, alpha = 0.5)
b1 <- 10
b2 <- 0
b3 <- 0
b4 <- 0
s <- 5
n <- 30
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)#水準Aのデータ生成
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)#水準Bのデータ生成
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
head(d)
## x y g
## 1 14.626422 8.1310194 A
## 2 1.703273 12.1936144 A
## 3 15.573617 8.6202482 A
## 4 9.704097 18.4047000 A
## 5 15.455977 0.7768798 A
## 6 21.048418 17.2785586 A
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
#連続変数xとカテゴリカル変数gが説明変数になっていることに注目
fit2 <- summary(fit1)
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図1の描画
b1e <- coef(fit2)[1,1] #b1の推定値
b2e <- coef(fit2)[2,1] #b2の推定値
b3e <- coef(fit2)[3,1] #b3の推定値
b4e <- coef(fit2)[4,1] #b4の推定値
overdraw(abline(a = b1e, b = b2e, col = cols[1]), #水準Aの直線
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2)) #水準Bの直線
------------------------------------------------------
図1 データの様子と回帰直線
さて、b1だけが0ではなく、b2 = b3 = b4 = 0を仮定しているので、2水準の直線は切片が同じで、傾きはともに0であることを想定している。実際、図1を見るとそのようなデータ生成になっている。ではこの時の検出力を確かめよう。
------------------------------------------------------
b1 <- 10
b2 <- 0
b3 <- 0
b4 <- 0
s <- 5
n <- 30
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
for (i in 1:10000){
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
fit2 <- summary(fit1)
p1 <- c(p1, coef(fit2)[1,4]) #b1のP値
p2 <- c(p2, coef(fit2)[2,4]) #b2のP値
p3 <- c(p3, coef(fit2)[3,4]) #b3のP値
p4 <- c(p4, coef(fit2)[4,4]) #b4のP値
}
histn(p1, xlab = "P value", ylab = "頻度") #図2の描画
histn(p2, xlab = "P value", ylab = "頻度") #図3の描画
histn(p3, xlab = "P value", ylab = "頻度") #図4の描画
histn(p4, xlab = "P value", ylab = "頻度") #図5の描画
sum(p1 < 0.05)
## [1] 9985
sum(p2 < 0.05)
## [1] 536
sum(p3 < 0.05)
## [1] 506
sum(p4 < 0.05)
## [1] 553
------------------------------------------------------
図2 b1のP値の分布
図3 b2のP値の分布
図4 b3のP値の分布
図5 b4のP値の分布
見ると仮定通り、b1の検出力は100%近いのに対して、残りの係数の危険率は5%に抑えられている。次は傾きも足してみよう。ただし、水準間の違いはない(b3 = b4 = 0)。
------------------------------------------------------
b1 <- 10
b2 <- 2
b3 <- 0
b4 <- 0
s <- 5
n <- 30
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
for (i in 1:10000){
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
fit2 <- summary(fit1)
p1 <- c(p1, coef(fit2)[1,4]) #b1のP値
p2 <- c(p2, coef(fit2)[2,4]) #b2のP値
p3 <- c(p3, coef(fit2)[3,4]) #b3のP値
p4 <- c(p4, coef(fit2)[4,4]) #b4のP値
}
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図6の描画
b1e <- coef(fit2)[1,1]
b2e <- coef(fit2)[2,1]
b3e <- coef(fit2)[3,1]
b4e <- coef(fit2)[4,1]
overdraw(abline(a = b1e, b = b2e, col = cols[1]),
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2))
histn(p1, xlab = "P value", ylab = "頻度") #図7の描画
histn(p2, xlab = "P value", ylab = "頻度") #図8の描画
histn(p3, xlab = "P value", ylab = "頻度") #図9の描画
histn(p4, xlab = "P value", ylab = "頻度") #図10の描画
sum(p1 < 0.05)
## [1] 9984
sum(p2 < 0.05)
## [1] 10000
sum(p3 < 0.05)
## [1] 520
sum(p4 < 0.05)
## [1] 487
------------------------------------------------------
図6 データの様子と回帰直線
図7 b1のP値の分布
図8 b2のP値の分布
図9 b3のP値の分布
図10 b4のP値の分布
b1およびb2の検出力は100%近くなった。一方で、b3、b4は危険率5%程度に抑えられている。では、今度は水準間で切片も変えてみよう。ただし、傾きは一緒だ。
------------------------------------------------------
b1 <- 10
b2 <- 2
b3 <- 5
b4 <- 0
s <- 5
n <- 30
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
for (i in 1:10000){
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
fit2 <- summary(fit1)
p1 <- c(p1, coef(fit2)[1,4]) #b1のP値
p2 <- c(p2, coef(fit2)[2,4]) #b2のP値
p3 <- c(p3, coef(fit2)[3,4]) #b3のP値
p4 <- c(p4, coef(fit2)[4,4]) #b4のP値
}
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図11の描画
b1e <- coef(fit2)[1,1]
b2e <- coef(fit2)[2,1]
b3e <- coef(fit2)[3,1]
b4e <- coef(fit2)[4,1]
overdraw(abline(a = b1e, b = b2e, col = cols[1]),
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2))
histn(p1, xlab = "P value", ylab = "頻度") #図12の描画
histn(p2, xlab = "P value", ylab = "頻度") #図13の描画
histn(p3, xlab = "P value", ylab = "頻度") #図14の描画
histn(p4, xlab = "P value", ylab = "頻度") #図15の描画
sum(p1 < 0.05)
## [1] 9973
sum(p2 < 0.05)
## [1] 10000
sum(p3 < 0.05)
## [1] 4694
sum(p4 < 0.05)
## [1] 514
------------------------------------------------------
図11 データの様子と回帰直線
図12 b1のP値の分布
図13 b2のP値の分布
図14 b3のP値の分布
図15 b4のP値の分布
b1およびb2の検出力は100%近くなった。そして、この条件のもとではb3の検出力は47%程度である。そして、b4の危険率は5%程度である。では、今度は水準間で傾きだけを変えてみよう。
------------------------------------------------------
b1 <- 10
b2 <- 2
b3 <- 0
b4 <- -3
s <- 5
n <- 30
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
for (i in 1:10000){
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
fit2 <- summary(fit1)
p1 <- c(p1, coef(fit2)[1,4]) #b1のP値
p2 <- c(p2, coef(fit2)[2,4]) #b2のP値
p3 <- c(p3, coef(fit2)[3,4]) #b3のP値
p4 <- c(p4, coef(fit2)[4,4]) #b4のP値
}
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図16の描画
b1e <- coef(fit2)[1,1]
b2e <- coef(fit2)[2,1]
b3e <- coef(fit2)[3,1]
b4e <- coef(fit2)[4,1]
overdraw(abline(a = b1e, b = b2e, col = cols[1]),
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2))
histn(p1, xlab = "P value", ylab = "頻度") #図17の描画
histn(p2, xlab = "P value", ylab = "頻度") #図18の描画
histn(p3, xlab = "P value", ylab = "頻度") #図19の描画
histn(p4, xlab = "P value", ylab = "頻度") #図20の描画
sum(p1 < 0.05)
## [1] 9980
sum(p2 < 0.05)
## [1] 10000
sum(p3 < 0.05)
## [1] 516
sum(p4 < 0.05)
## [1] 10000
------------------------------------------------------
図16 データの様子と回帰直線
図17 b1のP値の分布
図18 b2のP値の分布
図19 b3のP値の分布
図20 b4のP値の分布
b1、b2、b4の検出力は100%近くなった。一方、b3の危険率は5%程度である。では、最後に変わり種の状態として、交互作用項b4だけが0ではない状況を考える。なお、以下のシミュレーションではあることを確認するためにちょっとした計算を追加している。
------------------------------------------------------
b1 <- 0
b2 <- 0
b3 <- 0
b4 <- -10
s <- 5
n <- 30
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
p5 <- NULL
p6 <- NULL
p7 <- NULL
for (i in 1:10000){
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
fit2 <- summary(fit1)
fit3 <- anova(fit1) #分散分析表を出力
p1 <- c(p1, coef(fit2)[1,4]) #b1のP値
p2 <- c(p2, coef(fit2)[2,4]) #b2のP値
p3 <- c(p3, coef(fit2)[3,4]) #b3のP値
p4 <- c(p4, coef(fit2)[4,4]) #b4のP値
p5 <- c(p5, fit3$`Pr(>F)`[1]) #連続変数のP値
p6 <- c(p6, fit3$`Pr(>F)`[2]) #カテゴリカル変数のP値
p7 <- c(p7, fit3$`Pr(>F)`[3]) #交互作用のP値
}
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図21の描画
b1e <- coef(fit2)[1,1]
b2e <- coef(fit2)[2,1]
b3e <- coef(fit2)[3,1]
b4e <- coef(fit2)[4,1]
overdraw(abline(a = b1e, b = b2e, col = cols[1]),
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2))
histn(p1, xlab = "P value", ylab = "頻度") #図22の描画
histn(p2, xlab = "P value", ylab = "頻度") #図23の描画
histn(p3, xlab = "P value", ylab = "頻度") #図24の描画
histn(p4, xlab = "P value", ylab = "頻度") #図25の描画
sum(p1 < 0.05)
## [1] 522
sum(p2 < 0.05)
## [1] 514
sum(p3 < 0.05)
## [1] 487
sum(p4 < 0.05)
## [1] 10000
------------------------------------------------------
図21 データの様子と回帰直線
図22 b1のP値の分布
図23 b2のP値の分布
図24 b3のP値の分布
図25 b4のP値の分布
このとき、b4の検出力が100%となり、残りの係数の危険率は5%程度に抑えられた。さて、この状況は二元配置分散分析で、特定の要因組み合わせの標本だけの平均値だけが異なり、各要因単独では効果がなかった状況と類似していることは想像つくだろうか。こんな時、分散分析では交互作用だけでなく、単純主効果も有意になってしまっていた。上のシミュレーションのように、実は線形回帰でも分散分析表をanova関数に線形回帰の解析結果を入力することで計算することができる(名前に反して、anova関数は分散分析を行う関数ではない(!)、分散分析を行う関数はaov関数だ……)。fit2とfit3の中身を確認してみよう。
------------------------------------------------------
fit2
##
## Call:
## lm(formula = y ~ x * g, data = d)
##
## Residuals:
## Min 1Q Median 3Q Max
## -11.5924 -3.9156 -0.6812 3.0212 13.1318
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -3.1629 2.3181 -1.364 0.178
## x 0.1613 0.1212 1.331 0.189
## gB 5.1716 3.4705 1.490 0.142
## x:gB -10.2728 0.1846 -55.662 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 5.836 on 56 degrees of freedom
## Multiple R-squared: 0.9969, Adjusted R-squared: 0.9967
## F-statistic: 5927 on 3 and 56 DF, p-value: < 2.2e-16
fit3
## Analysis of Variance Table
##
## Response: y
## Df Sum Sq Mean Sq F value Pr(>F)
## x 1 72530 72530 2129.3 < 2.2e-16 ***
## g 1 427601 427601 12553.5 < 2.2e-16 ***
## x:g 1 105533 105533 3098.2 < 2.2e-16 ***
## Residuals 56 1907 34
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
------------------------------------------------------
fit2では唯一、交互作用項の係数だけが有意になっているが、fit3の分散分析表を見ると交互作用項だけでなく連続変数とカテゴリカル変数が有意になっている。これは矛盾しているわけではなく、計算の性質によるものだ。重回帰モデルに立ち戻ってみると、以下のような二つのパターンに式変形できる。
y ~ (b1 + b3 g) + (b2 + b4 g) x
y ~ (b1 + b2 x) + (b3 + b4 x) g
分散分析にとって「xの効果がある」というのは、xによってyの平均が変化することを意味するのだから、(b2 + b4 g) ≠ 0であればよい。つまり、例え、b2 = 0であっても、b4 ≠ 0であれば分散分析においては「xの効果がある」として検出されうる、ということだ。同様の議論でb4 ≠ 0であれば、分散分析においては「gの効果がある」と推定されうる。逆に、この考察からb2 ≠ 0かつb4 ≠ 0なのに、分散分析において「xに効果がない」とさせるようなデータを作らせることができる。つまり、(b2 + b4 g) = 0となればよいのだから、b2 = - b4 gとなるような組み合わせならよい。gは変数だが、gの変動に対して平均的に見て(b2 + b4 g) = 0となるように設定できれば良いから、平均をEで表して、b2 = - b4 E(g)を満たすデータになればよい。分散分析ならg = 0 or 1なので、E(g) = nB/(nA + nB)とする(nAは水準A、nBは水準Bのサンプルサイズ)。もちろん同様の議論で、b3 ≠ 0なのに分散分析で「gに効果がない」データも作らせることができる。
では、逆に2つのカテゴリカル変数を説明変数とするデータに線形回帰モデルを当てはめて解析をしてみよう。二元配置分散分析の時に扱った、主効果がなく、交互作用だけが有意になりそうなデータを対象にしてみる。
------------------------------------------------------
nAX <- 30
nAY <- 30
nBX <- 30
nBY <- 30
meAX <- 70
meAY <- 50
meBX <- 50
meBY <- 50
s <- 15
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
for (i in 1:10000){
mAX <- rnorm(nAX, mean = meAX, sd = s)
mAY <- rnorm(nAY, mean = meAY, sd = s)
mBX <- rnorm(nBX, mean = meBX, sd = s)
mBY <- rnorm(nBY, mean = meBY, sd = s)
d <- data.frame(m = c(mAX, mAY, mBX, mBY),
g1 = c(rep("A", times = nAX+nAY), rep("B", times = nBX+nBY)),
g2 = c(rep("X", times = nAX), rep("Y", times = nAY),
rep("X", times = nBX), rep("Y", times = nBY))
)
d$g1 <- factor(d$g1, levels = c("B","A")) #水準Bを切片にするために水準間の順位を変更
d$g2 <- factor(d$g2, levels = c("Y","X")) #水準Yを切片にするために水準間の順位を変更
fit1 <- lm(m ~ g1 * g2, data = d) #多重線形回帰
fit2 <- summary(fit1)
p1 <- c(p1, coef(fit2)[1,4])
p2 <- c(p2, coef(fit2)[2,4])
p3 <- c(p3, coef(fit2)[3,4])
p4 <- c(p4, coef(fit2)[4,4])
}
boxplotn(m ~ g1 + g2, data = d, ylab = "data", jitter.method = "swarm",
cex.dot = 1, pch.dot = c(16,16,17,17), col.dot = cols,
col.bor = cols, col.fill = fils) #図26の描画
fit2
##
## Call:
## lm(formula = m ~ g1 * g2, data = d)
##
## Residuals:
## Min 1Q Median 3Q Max
## -41.997 -8.578 0.662 8.999 35.066
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 46.470 2.703 17.192 < 2e-16 ***
## g1A 6.406 3.823 1.676 0.09647 .
## g2X 2.602 3.823 0.681 0.49738
## g1A:g2X 17.043 5.406 3.153 0.00206 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 14.8 on 116 degrees of freedom
## Multiple R-squared: 0.3309, Adjusted R-squared: 0.3136
## F-statistic: 19.12 on 3 and 116 DF, p-value: 3.815e-10
histn(p1, xlab = "P value", ylab = "頻度") #図27の描画
histn(p2, xlab = "P value", ylab = "頻度") #図28の描画
histn(p3, xlab = "P value", ylab = "頻度") #図29の描画
histn(p4, xlab = "P value", ylab = "頻度") #図30の描画
sum(p1 < 0.05)
## [1] 10000
sum(p2 < 0.05)
## [1] 500
sum(p3 < 0.05)
## [1] 498
sum(p4 < 0.05)
## [1] 9474
------------------------------------------------------
図26 データの様子
図27 b1のP値の分布
図28 b2のP値の分布
図29 b3のP値の分布
図30 b4のP値の分布
確かに上のシミュレーションでは、b4の検出力が95%程度で、b2、b3の危険率が5%程度となっており、予測通りの結果となった。以上の議論をまとめて判断すると、今までさんざん、aov関数を使って分散分析を行ってきたが、特別な事情がない限りは、線形回帰のlm関数を使って係数を確認したほうが、データを正確に紐解くことができる、ということだろうか。もちろん、分散分析表は一つの要約として便利なのだが、いきなり要約を確認するのではなく、その中身を見るという意味ではlm関数のほうが優秀だ。また、係数をすぐ見える形で算出してくれているので、データの予測の観点からも便利だろう。
唯一、注意が必要な点は切片にあたるデータによっては出力結果が変わって見えることだろうか。実際は、本質は変わっていないのだが、異なる結果のように見える、ということである。例えば、上記の例では切片を標本BYにすることで、要因g1の単独効果b2 = Aに変わることの効果、要因g2の単独効果b3 = Xに変わることの効果、が無いような設定にした。つまり、E(標本BY) = E(標本AY)、E(標本BY) = E(標本BX)となっている。そして、交互作用効果b4 = AとXに代わることの効果は存在する、つまり、E(標本BY) ≠ E(標本AX)である。
一方で、もし、切片を標本AXにしたらどうだろう。すると、b2はBに変わる効果なので、E(標本BX) - E(標本AX)として推定される。つまり、有意な効果が検出されるだろう。同様にb3も有意になる。そして、交互作用b4 = E(標本BY) - E(標本AX) - b2 - b3として推定される。ところで、データの仮定からE(標本BY) - E(標本AX) = b2 = b3なので、b4 = -b2 = -b3 ≠ 0となり、やはり有意になる。というように、切片によって結果の見え方は異なる。
多重線形回帰の危険率
さて、危険率もシミュレートしてみよう。次のようにb1 、b2、b3、b4 = 0のデータを生成して、線形回帰を行う。
------------------------------------------------------
b1 <- 0
b2 <- 0
b3 <- 0
b4 <- 0
s <- 5
n <- 30
p1 <- NULL
p2 <- NULL
p3 <- NULL
p4 <- NULL
for (i in 1:10000){
x1_1 <- runif(n, 0, 30)
x1_2 <- runif(n, 0, 30)
y1 <- b2 * x1_1 + rnorm(n = n, mean = b1, sd = s)
y2 <- (b2+b4) * x1_2 + rnorm(n = n, mean = b1+b3, sd = s)
d <- data.frame(x = c(x1_1, x1_2), y = c(y1, y2), g = rep(c("A","B"), each = n))
fit1 <- lm(y ~ x * g, data = d)
fit2 <- summary(fit1)
fit3 <- anova(fit1)
p1 <- c(p1, coef(fit2)[1,4])
p2 <- c(p2, coef(fit2)[2,4])
p3 <- c(p3, coef(fit2)[3,4])
p4 <- c(p4, coef(fit2)[4,4])
}
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図31の描画
b1e <- coef(fit2)[1,1]
b2e <- coef(fit2)[2,1]
b3e <- coef(fit2)[3,1]
b4e <- coef(fit2)[4,1]
overdraw(abline(a = b1e, b = b2e, col = cols[1]),
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2))
histn(p1, xlab = "P value", ylab = "頻度") #図32の描画
histn(p2, xlab = "P value", ylab = "頻度") #図33の描画
histn(p3, xlab = "P value", ylab = "頻度") #図34の描画
histn(p4, xlab = "P value", ylab = "頻度") #図35の描画
sum(p1 < 0.05)
## [1] 490
sum(p2 < 0.05)
## [1] 507
sum(p3 < 0.05)
## [1] 504
sum(p4 < 0.05)
## [1] 495
------------------------------------------------------
図31 データの様子と回帰直線
図32 b1のP値の分布
図33 b2のP値の分布
図34 b3のP値の分布
図35 b4のP値の分布
以上のようにいずれの係数も危険率5%程度となった。
Rで行う多重線形回帰ーその1
では、Rで多重線形回帰を行ってみよう。今回は下記のようなデータだ。さっそく、図にしてみよう。
------------------------------------------------------
x <- c(4, -9, 5, -1, 5, 11, 9, -5, 1, -8,
-10, 9, -4, -6, 6, 14, -3, 4, -9, 2,
-10, -2, -4, 14, 16, -8, -8, 17, 18,
17, 15, -10, 16, 14, -2, 7, -9, 7, -10,
5, 9, -1, 4, 4, 7, 0, 14, 4, 0, 5, 14,
-9, 16, -4, 9, 4, 18, 9, -4, 11)
y <- c(6, 14, 7, 26, -9, 24, 14, 14, 46, 10,
7, 18, -6, 19, 9, 10, 15, 18, 2, 14,
-2, 4, 31, -7, 16, 29, 8, 12, 33, -4,
-57, 88, -53, -51, 38, -7, 75, -3, 87,
1, -15, 14, 10, 6, -22, 27, -45, -15, 21,
-3, -28, 78, -63, 40, -14, 14, -65, -40, 26, -17)
g <- rep(c("A","B"), each = 30)
d <- data.frame(x = x, y = y, g = g)
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T) #図36の描画
------------------------------------------------------
図36 データの様子
みると、水準Aはほとんど傾きが0で、水準Bは負の傾きを持っていそうだ。ゆえに交互作用の検出が期待される。水準Aのほうをg = 0としたときのモデル式は、
水準A:y ~ b1 + b2 x
水準B:y ~ (b1 + b3) + (b2 + b4) x
となることを考慮して係数の推定を見てみよう。
------------------------------------------------------
fit1 <- lm(y ~ x * g, data = d) #多重線形回帰
fit2 <- summary(fit1)
fit1
##
## Call:
## lm(formula = y ~ x * g, data = d)
##
## Coefficients:
## (Intercept) x gB x:gB
## 12.56325 0.01696 12.77297 -5.14344
fit2
##
## Call:
## lm(formula = y ~ x * g, data = d)
##
## Residuals:
## Min 1Q Median 3Q Max
## -21.648 -5.697 1.419 5.983 33.420
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 12.56325 2.16176 5.812 3.07e-07 ***
## x 0.01696 0.23145 0.073 0.941842
## gB 12.77297 3.25706 3.922 0.000242 ***
## x:gB -5.14344 0.34668 -14.836 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 11.52 on 56 degrees of freedom
## Multiple R-squared: 0.8798, Adjusted R-squared: 0.8734
## F-statistic: 136.7 on 3 and 56 DF, p-value: < 2.2e-16
plotn(y ~ x, data = d, mode = "m", group = "g", pch = c(16, 17), legend = T,
lty.leg = c(1,2)) #図37の描画
b1e <- coef(fit2)[1,1]
b2e <- coef(fit2)[2,1]
b3e <- coef(fit2)[3,1]
b4e <- coef(fit2)[4,1]
overdraw(abline(a = b1e, b = b2e, col = cols[1]),
abline(a = b1e+b3e, b = b2e+b4e, col = cols[2], lty = 2))
------------------------------------------------------
図37 データの様子と回帰直線
b1 = 12.56、b2 = 0.017、b3 = 12.77、b4 = -5.14で、b2以外は有意なようだ。つまり、水準Aの回帰直線はy = 12.56 + 0.017x、水準Bはy = 12.56 + 12.77 + (0.017 - 5.14)xになるということで、確かにデータと一致している。では、ここからfit2内に格納されている各データを計算していこう。まず、残差Residualsの分布は、
------------------------------------------------------
ye <- c(b2e * d[d$g == "A", "x"] + b1e,
(b2e+b4e) * d[d$g == "B", "x"] + (b1e+b3e)
)
#yの推定値(水準AとBで分けて計算している)
quantile(d$y - ye) #yの実測値と推定値の差
## 0% 25% 50% 75% 100%
## -21.648058 -5.696577 1.418660 5.982939 33.419789
------------------------------------------------------
係数Coefficientsの推定値Estimateの項は、
------------------------------------------------------
b2e_h <- cov(d[d$g == "A", "x"], d[d$g == "A", "y"])/var(d[d$g == "A", "x"])
#xの係数b2
b1e_h <- mean(d[d$g == "A", "y"]) - mean(d[d$g == "A", "x"]) * b2e_h
#(Intercept)のb1
b4e_h <- cov(d[d$g == "B", "x"], d[d$g == "B", "y"])/var(d[d$g == "B", "x"]) - b2e_h
#gBの係数b3
b3e_h <- mean(d[d$g == "B", "y"]) - mean(d[d$g == "B", "x"]) * (b4e_h + b2e_h) - b1e_h
#x:gBの交互作用係数b4
b1e_h
## [1] 12.56325
b2e_h
## [1] 0.0169617
b3e_h
## [1] 12.77297
b4e_h
## [1] -5.143441
------------------------------------------------------
係数Coefficientsの標準誤差Std.Errorの項は、
------------------------------------------------------
se <- sum((d$y - ye)^2)/(length(x) - 4)
#残差の不偏分散、自由度はサンプルサイズ- 推定するパラメータ数なので、60 - 4 = 56
sb1 <- sqrt(
se * (1/length(d[d$g == "A", "x"]) +
(mean(d[d$g == "A", "x"])^2)/(var(d[d$g == "A", "x"]) * (length(d[d$g == "A", "x"])-1)
)
)
) #b1 standard error
sb2 <- sqrt(se/(var(d[d$g == "A", "x"]) * (length(d[d$g == "A", "x"])-1))) #b2 standard error
sb3 <- sqrt(
se * (1/length(d[d$g == "B", "x"]) +
(mean(d[d$g == "B", "x"])^2)/(var(d[d$g == "B", "x"]) * (length(d[d$g == "B", "x"])-1)
)
)
+ sb1^2) #b3 standard error
sb4 <- sqrt(se/(var(d[d$g == "B", "x"]) * (length(d[d$g == "B", "x"])-1)) + sb2^2) #b4 standard error
sb1
## [1] 2.161762
sb2
## [1] 0.231455
sb3
## [1] 3.257065
sb4
## [1] 0.3466769
------------------------------------------------------
係数Coefficientsのt valueの項は、
------------------------------------------------------
b1t <- b1e_h/sb1 #b1 t-value
b2t <- b2e_h/sb2 #b2 t-value
b3t <- b3e_h/sb3 #b3 t-value
b4t <- b4e_h/sb4 #b4 t-value
b1t
## [1] 5.81158
b2t
## [1] 0.07328293
b3t
## [1] 3.92162
b4t
## [1] -14.83641
------------------------------------------------------
係数CoefficientsのPr(>|t|)の項は、
------------------------------------------------------
pt(q = b1t, df = length(x)-4, lower.tail = sign(b1t) < 0) * 2
## [1] 3.072685e-07
pt(q = b2t, df = length(x)-4, lower.tail = sign(b2t) < 0) * 2
## [1] 0.9418421
pt(q = b3t, df = length(x)-4, lower.tail = sign(b3t) < 0) * 2
## [1] 0.0002423744
pt(q = b4t, df = length(x)-4, lower.tail = sign(b4t) < 0) * 2
## [1] 4.696814e-21
------------------------------------------------------
残差の標準誤差Residual standard errorは
------------------------------------------------------
sqrt(se) #Residual standard error
## [1] 11.51745
------------------------------------------------------
R二乗値は
------------------------------------------------------
var(ye)/var(y) #Multiple R-squared
## [1] 0.8798313
------------------------------------------------------
F値とその時のP値は
------------------------------------------------------
sr <- sum((ye - mean(ye))^2)/3 #パラメータの自由度で割る
sr/se #F-value
## [1] 136.6705
pf(df1 = 3, df2 = length(x) - 4, q = sr/se, lower.tail = F)
## [1] 9.753464e-26
------------------------------------------------------
というように計算される。以上のように、2水準に含まれる連続変数に関して、回帰直線を推定することができた。これで条件によって異なる連続変数の応答を推定することが可能となった。