文系のための「自由度調整済み決定係数」

ここまでの話では、重回帰分析の仕組みとモデルの読み方を整理してきた。
要するに、重回帰係数について、連立方程式を解き、
重回帰係数の値の正負と値の大小によって変数間の関係を観察する。

そうそう。特異値分解による擬逆行列から連立方程式を解く場合には、
以下のような式によって、重回帰係数を算出することができた。
少々、クドいかもしれないが、とりあえず再掲しておく。



一般的に、擬逆行列の解法は変数pが対象数nよりも小さい場合と（n > p）、
変数pが対象数nよりも大きい場合（n < p）で異なっているが、
特異値分解を用いた場合には近似的に計算することができる。 

とにかく、この式によって導出されたベクトルが重回帰係数であり、
この重回帰係数を用いて、次のような重回帰モデルを導出することができる。



さて、基本的な話は、これで収まっているのであるが、 問題となるのは、
このモデルが本当に正しいのか？という問題である。
まずは、このモデルの適合の度合いというか、説明力を知りたい。

最も単純な方法は、残差から重回帰モデルの適合性を評価する決定係数を用いる方法。
 予測値のバラツキ（回帰の平方和）「Sr」、残差のバラツキ（残差平方和）「Se」、
そして、目的変数の総平方和 「St」から以下の式によって表すことができる。



この式を変形し、以下のようにしたものが決定係数と呼ばれるものであった。



詳細に関しては、残差と決定係数の話ですでに整理済みの話である。
決定係数は、モデルで説明できない残差の大きさを反映した指標である。

ところで、この指標は直感的に理解しやすいのであるが、少々、問題がある。
実は、変数の数が増えれば増えるほど決定係数の値は高くなってしまうのである。
そこで登場するのが、「自由度修正済み決定係数」と呼ばれるものである。



ここでは、目的変数の総平方和「St」に対して対象数「n-1」で基準化し、
Seは、Stと同様に対象数で基準化すると同時に、説明変数の数「p」で基準化をしている。
つまり、全体では一つの対象における一つの変数当たりの残差でモデルを評価する。

このような調整を行うことで、対象数と変数の数の影響が除去される。
とにかく、前回のデータを用いて、自由度調整済み決定係数とやらを計算してみる。
まず、前回と同様に、インターネット経由で直接データを読み込む。
今回の演習で使用するデータも前回と同じ。

library(RCurl) 

ライブラリを読み込めたら、
以下のコマンドを実行する。

# Google Spreadsheet からデータをダウンロードする
data <- getURL("https://docs.google.com/spreadsheet/pub?key=0AtOtIs5BjRVhdDdyTmgtNm9DcEVJb3VLbnh3ZFlNb2c&single=true&gid=0&range=A1%3AH295&output=csv")

# ダウンロードしたデータを読み込む
X <- as.data.frame(read.table(textConnection(data), header=TRUE, row.names=1, sep=","))

次に、重回帰分析を実行する。前回と同様に、「墳長」を目的変数とし、
その他の変数から重回帰モデルを立てる。

# 念の為に最初のデータの状態を保存しておく。
O <- X

# 実際の目的変数も保存しておく。
y <- O[, 1]

 # 目的変数を元の行列から分離する
y <- X[, 1]
X <- as.matrix(X[, -1])

# 切片の計算のために先頭行を「1」の行列を付け加える。
Intercept <- matrix(rep(1, nrow(X)), ncol=1)
X <- cbind(Intercept, X)

# 特異値分解を行う
X.svd <- svd(X)
X.svd.v <- X.svd$v
X.svd.d <- diag(X.svd$d)
X.svd.u <- X.svd$u

 # 重回帰係数を求める
X.lm <- ((X.svd.v %*% solve(X.svd.d)) %*% t(X.svd.u)) %*% y 

# 解りやすいように名前を付ける。
rownames(X.lm) <- c("Intercept",colnames( X[,2:ncol(X)]))
colnames(X.lm) <- "coefficients" 

# 最後に重回帰モデルから予測する。
# なお、以下の計算はベクトルの成分の掛け算。
y_hat <- X.lm[1] + X.lm[2]*X[,2] + X.lm[3]*X[,3] + X.lm[4]*X[,4] + X.lm[5]*X[,5] + X.lm[6]*X[,6] + X.lm[7]*X[,7]

# まずは、StとSeを求めて、決定係数を算出する。
Se <- sum((y-y_hat)^2)
St <- sum((y-mean(y))^2)

# 以下が標準的な決定係数。
1-(Se/St) 

# 次に、自由度調整済み決定係数を求める
p <- ncol(X)-1
n <- length(y)
1-(Se/(n-p-1))/(St/(n-1)) 

実行結果は以下の通り。決定係数と自由度調整済み決定係数はかなり高い。 

> # 以下が標準的な決定係数。
> 1-(Se/St)  
[1] 0.9926216
> 
> # 次に、自由度調整済み決定係数を求める
> p <- ncol(X)-1
> n <- length(y)
> 1-(Se/(n-p-1))/(St/(n-1))  
[1] 0.9924674

決定係数は、モデルの当てはまりの良さを表す指標であるので、
今回の結果の場合は、モデル全体では99%以上の説明力を持っていることが解る。
したがって、今回のモデルは、非常に当てはまりの良いモデルだと言える。

さて、残差の検討もしておく。これも、必ず確認しておく必要がある。

たしか、残差プロットは、まんべんなく散らばっていた方が良かった。

残差に何らかの傾向が現れているということは、重回帰モデルとして問題がある。

# 残差を標準化してバラツキ具合を観察する。
plot(scale(y-y_hat), ylab="Residuals")
abline(h=0)
abline(h=c(-2, 2), col="gray", lty=2)

# 外れ値を検出する
(r.lower <- which(scale(y-y_hat) < -2)) # −2よりも小さいもの
(r.upper <- which(scale(y-y_hat) > 2))  # +2よりも大きいもの
1-((length(r.upper)+length(r.lower))/n)

そして、実行結果は以下の通り。

# 外れ値を検出する
> (r.lower <- which(scale(y-y_hat) < -2)) # −2よりも小さいもの
[1] 91 98 137 243 258
> (r.upper <- which(scale(y-y_hat) > 2)) # +2よりも大きいもの
[1] 53 94 121 127 131 162 164 263 264 267
> 1-((length(r.upper)+length(r.lower))/n)
[1] 0.9489796 

一般的に重回帰分析における残差は正規分布に従うとされている。
そして、標準正規分布に従うのであれば、±2σ に95.4%が入ることになるので、
簡易な方法として、標準化した値の±2の外側を「外れ値」とする。 

今回の場合、全体の約94.9%が、±2σの範囲内に収まっていて、
また、散布図を見る限りは、何の傾向も見えてこない。
したがって、やはり、このモデルは非常に良い状況を表していることになる。 

自由度調整済み決定係数を用いることで、モデルの適合の度合いを知ることができ、
さらに、F検定という方法を用いることでモデルの適合性を評価するができる。
これに関しては、次回に整理することにする。

文系のための「二変数の関係」（３）

これまでの話から、二つの変数間の関係を見るための方法には、
相関係数以外にも単回帰という方法があることが理解できたハズ。

単回帰は、相関係数に良く似ているが、
一方の変数によってもう一方を説明するという考え方に基づいている。
相関係数は、二つの変数を平等に見ていたので、この点が大きく異なる。

また、重要なこととして、相関係数は二つの変数が平等なので軸は関係無いが、
単回帰の場合は、どちらを説明変数に置くかによって値が異なる。
まぁ、この辺りは、感覚的に理解できていることだろうと信じたい。

さて、今回は、もう少し単回帰について踏み込んでみる。
実は、前回の話では、二つの変数間の関係の強さについては、
十分に検討ができていなかったのである。

相関係数と同様に、二つの変数間の関係の強さを観察するには、
推定された値と実際の値との誤差の部分の解釈が必要となる。
本日は、このことについて整理する。

ということで、前回のデータの読み込みから。

# Windows と Linux の人は次のコマンド
X <- read.table("clipboard", sep=",", header=TRUE)

# Mac の人は次のコマンド
X <- read.table(pipe("pbpaste") , sep=",", header=TRUE)

以下が、そのデータ。データの説明に関しては、平均の話を参照。

Oroshi_Kg, Taka, Naka, Yasu
Tai, 1336, 3150, 1217, 53
Chinu, 226, 630, 513, 105
Sawara, 212, 1575, 1259, 840
Yazu, 4834, 840, 315, 179
Suzuki, 618, 1575, 1146, 525
Akou, 21, 4725, 3129, 1575
Kochi, 28, 2100, 874, 210
Okoze, 28, 5250, 2635, 210
Ainame, 29, 3150, 621, 315
Hage, 1205, 1890, 383, 210
Konoshiro, 21, 2100, 1100, 105
Sayori, 12, 5250, 3916, 1260
Anago, 1637, 2625, 1721, 630
Mebaru, 330, 4200, 1680, 315
Tachiuo, 1211, 2310, 930, 105
Hamo, 1622, 3938, 592, 53
Karei, 41, 6300, 3178, 525
Hirame, 540, 2100, 1496, 210
Aji, 5149, 3150, 789, 210
Saba, 5413, 3675, 625, 53
Ika, 2414, 2888, 1083, 105
Tako, 1844, 1890, 1180, 525
Ebi, 560, 7350, 1420, 525
KurumaEbi, 222, 8925, 6508, 2625
Koiwashi, 1316, 1155, 617, 328
ObaIwashi, 2716, 499, 267, 175
Mentai, 678, 1155, 859, 394
Hamachi, 4772, 998, 632, 105
Isaki, 268, 2625, 1465, 840

ふむ。前回と同様に、中値と安値の関係を使うことにするか。
単回帰分析も行うことにしよう。lm()関数があるが今は使わない。

x1 <- X$Naka
x2 <- X$Yasu

# まず、推定値を求める
B <- cov(x1,x2)/var(x1)

# まず、推定値を求める
B0 <- mean(x2) - B*mean(x1)

# x2の推定値を求める
x2.hat <- B0 + B*x1

数式あった方が解り易い。x1によってx2の値を説明するので、
たしか、以下のような式になるハズであった。



ここで、二つ推定値のいうのがそれぞれ、

,  

であった。詳しい説明は既にしてあるから、ここまでは大丈夫であろう。
自信が無い人は、もう一度復習をすること。

さて、現在、この回帰式によって説明されるのは、
あくまで、理屈として推定される値であって、実際の値とは異なる。
理屈上の話だから、直線で推定の直線が描けたのであった。

では、実際の値というのは、推定された値を使ってどのように表現できるか？



この式は、推定値では無くて、実際の値を表しているから、
左辺の「^（ハット）」が取れていることにも注目。

さて、この式の中で重要なことは最後に「ℇ」の値が付いていること。
これを「残差（residuals）」と呼び、この記号は一般的に残差を表す。

つまり、推定された値に誤差を加えたものが実際の値、と考えるのである。
この辺りの考え方は、数学嫌いの人には、少々、理解し難いかもしれない。

では、残差は、どうすれば求めることができるか？
これも中学校までの数学の知識があれば簡単なことであろう。



つまり、実際の値から推定値を引くだけ。混乱することは無い。
では、早速、この誤差の部分を計算してみる。

residuals <- x2 - x2.hat

ふむ。これで誤差が計算できた。ちょっと解りにくいので可視化する。

# 上手く重なるようにx軸とy軸の描画範囲を固定する
x.lim <- c(0,max(x1))
y.lim <- c(0,max(x2))

# 散布図を作成する
plot(x1, x2, xlim=x.lim, ylim=y.lim, pch=16)

# 図を重ねるためのオマジナイ
par(new=TRUE)

# xの値の範囲を最低値と最大値で決める。
x1.range <- seq(min(x1),max(x1))

# x値の範囲に対応する推定値を計算する。
x1.estim <- B0 + B*x1.range

# 回帰直線を引く
plot(x1.range, x1.estim, xlim=x.lim, ylim=y.lim, xaxt="n", yaxt="n", xlab="", ylab="", type="l", col="red")

# 残差を表す線を描画する
for(i in seq(1,length(x1))){
  x <- rep(x1[i],2)                 # x1の値を2つ作る
  y <- c(x2[i], x2[i]-residuals[i]) # x2の値とx2の値から残差を引いた値を作る

  # 残差を表す垂線を引く
  par(new=TRUE)
  plot(x, y, xlim=x.lim, ylim=y.lim, xaxt="n", yaxt="n", xlab="", ylab="", type="l", col="blue")
}

# 最後にグリッドを描いて全体を整える
grid()

この図において、実際の値から回帰直線に引かれた垂線が残差「residuals」である。
この残差というのが、二つの変数間の関係を観察する上で重要な値で、
残差を合わせた値が小さいほど当てはまりが良いことを表す。



二乗しているのは、値の正負が打ち消し合わないようにするため。
これを残差平方和（Sum Squared Error）と呼ぶ。とりあえず、Se と置いておく。
試しに、今回のデータを使って、この値を確認してみる。

(se <- sum(residuals^2))

これを実行すると、以下のようになる。

> (se <- sum(residuals^2))
[1] 2076206

さて、この値が小さいということが重要なのだけれど、これは大きいのか？
この値の大小の程度を見分けるためには、やはり、基準化しないといけない。
原点に帰って、もう一度、この残差というものが何なのかを考えてみる。

データを観察する上で、最も重要なのは、くどいけれど、バラツキ。
そして、個々の値のバラツキを偏差と言い、
偏差を二乗して足し合わせたものが偏差平方和。

とりあえず、目的変数の総平方和（Sum Squared Total Deviation）と呼び、
この値をSt とでも置いておくことにする。式は以下の通り。



これを対象数から1を引いた「n-1」で割ると？そうそう、分散になる。
要するに、分散の式の分子の部分に当たるのであった。

さて、このStとSeの関係に注目してやると、
Stは観測値のバラツキの平方和で、Seは残差のバラツキの平方和だから、
予測値のバラツキとSe を足したものが、St になるはず。

では、予測値のバラツキはどうなるか？というと、以下のようになる。



つまり、St = Se + Sr という関係が成立するはず。
これは、直感的に理解できる。ここからが数学マジック！
両辺をStで割るとどういうことになるのか？



となる。ここで、残差平方和の影響の大きさを見たいので、
この式から、予測値のバラツキの部分を抜いてしまう。
すると、以下のようになる。左辺に何もないと困るので「」を置いておく。



つまり、残差平方和の大きさというのは、このように表すことができる。
この値が「1」に近づくということは、残差の影響が小さいことを意味する。
なかなか、エレガントな数式。私は美しいと思うのだが、どうだろう？

さて、この「」という指標は頻繁に登場する。だからちゃんと名前がある。
一般的に、この指標のことを「決定係数」と呼び、慣例的に「」で表す。

では、この決定係数を実際に計算してみる。

# 一応、三つの値を出しておく。
st <- sum((x2-rep(mean(x2), length(x2)))^2)
sr <- sum((x2.hat-rep(mean(x2), length(x2)))^2)
se <- sum((x2-x2.hat)^2)

# 決定係数の計算
(R2 <- 1-(se/st))

では、確認。以下が実行結果。

> # 決定係数の計算
> (R2 <- 1-(se/st))
[1] 0.7576962

さて、この結果は果たして高いと言えるのかどうか？実は、判断は難しいのであるが、
一方の変数がもう一方を説明する上で、75.8％の説明力を持っていることを示していて、
これは、決して低い値ではない。大体、60〜70％以上であれば、悪くはない。

決定係数に関しては、注意するべきことがある。
相関係数と同様に、この値を盲目的に信用してはならないし、
慎重にデータの解釈をしなければならない。決定係数は、基準の一つでしかない。

例えば、決定係数は、対象数が多くなると必然的に値が高くなるので、
自由度調整済み決定係数と呼ばれる指標を用いたり、
確立統計の手法を用いる場合もある。

さてさて、最後に、Rのlm()関数を使った場合についてもやっておく。
とりあえず、X.reg という変数に、回帰分析の結果を入れて、その要約を確認する。

X.reg <- lm(x2 ~ x1)
summary(X.reg)

以下がこの処理の実行結果。

> X.reg <- lm(x2 ~ x1)
> summary(X.reg)

Call:
lm(formula = x2 ~ x1)

Residuals:
    Min      1Q  Median      3Q     Max 
-678.72 -163.58   -7.29  158.81  506.60 

Coefficients:
             Estimate Std. Error t value Pr(>|t|)    
(Intercept) -69.68447   77.21191  -0.903    0.375    
x1            0.36372    0.03958   9.189 8.45e-10 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 

Residual standard error: 277.3 on 27 degrees of freedom
Multiple R-squared: 0.7577, Adjusted R-squared: 0.7487 
F-statistic: 84.43 on 1 and 27 DF,  p-value: 8.447e-10 

実は、色々と見ないといけないのであるが、
そもそも、今回の話の目的は、二つの変数間の関係を見ることであって、
精密な推定を行うことではない。ということで、決定係数以外は無視。

さて、上記の出力において、Coefficients の部分は係数の部分。
決定係数の部分は、下から二行目の部分。Multiple R-squared の右側。
ちゃんと、手計算で算出した決定係数と一致していることが解る。

回帰分析の解説の多くは、「目的変数を説明変数によって推定する手法」、
と紹介しているのではないかと思うが、変数間の関係を見ることが重要なのである。
これは、相関係数の考え方に非常に良く似ているのである。たしかに、式も似ていた。

相関係数との違いは、一方の変数によってもう一方の変数を説明するという考え方。
したがって、その説明力を「残差」に注目して検討するのである。
残差が小さいほど、二つの変数の間の関係は強いということになる。

他の教科書に書かれているように、推定に注目するのであれば、
より複雑なことが必要になるし、3つ以上の変数間の関係になると結構大変。
残差そのものに関する検討や、複数の変数の当てはまりの高さの検討も必要。

この章で書いてしまいたい話ではあるが、
この辺りの話は、中級編の重回帰分析の話で整理することにする。