本週上課將介紹迴歸的基本原理,配合之前討論的研究設計,可以描述兩個變數之間的關係。例如兩個變數的散佈圖加上迴歸線:
library(UsingR)
ggplot(nym.2002, aes(age, time)) +
geom_point(col="#808000", size=2) +
geom_smooth(method="lm") +
theme_bw() +
theme(axis.title=element_text(size=12),
axis.text = element_text(size=12))
\[\hat{E}[Y|X]=\frac{\sum_{i=1}^N K_{h}((X_{i}-x_{0})/h)Y_{i}}{\sum_{i=1}^N K_{h}((X_{i}-x_{0})/h)} \]
im1<-here::here('Fig','nonpreg1.jpg')
knitr::include_graphics(im1)
Figure 2.1: 無母數迴歸線1
\(Y_{i}=\alpha_{0}+\beta_{1}(x_{i}-x_{0})+\cdots +\beta_{p}(x_{i}-x_{0})^{p}+E_{i}\)
im2<-here::here('Fig','nonpreg2.jpg')
knitr::include_graphics(im2)
Figure 2.2: 無母數迴歸線2
im3<-here::here('Fig','nonpreg3.jpg')
knitr::include_graphics(im3)
Figure 2.3: 無母數迴歸線3
從以上可知:
\(MSE_{pred.-y_{i}}=Var_{pred.}+Bias_{\mathit{f_{i}}-y_{i}}^2\)
im4<-here::here('Fig','nonpa_4.jpg')
knitr::include_graphics(im4)
Figure 2.4: 無母數迴歸線4
im5<-here::here('Fig','nonpa_8.jpg')
knitr::include_graphics(im5)
Figure 2.5: 無母數迴歸線5
im6<-here::here('Fig','loess_r.jpg')
knitr::include_graphics(im6)
Figure 2.6: 無母數迴歸線6
\(E[Y|X]=\beta_{0}+X\beta_{1}\)
\(RSS=e_{1}^2+e_{2}^2+\ldots +e_{n}^2\)
\[E(X)=\int_{-\infty}^{\infty}xf(x)dx\]
\[E(X)=\sum xf(x)=\sum x\cdot P(X=x)\]
\[\rm{Var}(X)=E(X^2)-(E(X))^2\]
\[\boxed{E(Y|X=x)=\mu_{Y|X=x}=\sum yf(y|x)}\]
\[\begin{equation} X = \begin{cases} 1 & \rm{with\hspace{.3em} probability}\quad 1/8\\ 2 & \rm{with\hspace{.3em}probability}\quad 7/8 \end{cases} \end{equation}\]
\[\begin{equation} Y|X= \begin{cases} 2X & \rm{with\hspace{.3em}probability}\quad 3/4\\ 3X & \rm{with\hspace{.3em}probability}\quad 1/4 \end{cases} \end{equation}\]
\[\begin{equation} Y|(X=1)= \begin{cases} 2 & \rm{with\hspace{.3em}probability}\quad 3/4\\ 3 & \rm{with\hspace{.3em}probability}\quad 1/4 \end{cases} \end{equation}\]
\[\boxed{Var(Y|X=x)=E(Y^2|X)-(E(Y|X))^2}\]
\[E(Y)=\sum E(Y|X=x)P(X=x)]\]
\[E(Y)=E[E(Y|X)]\]
set.seed(02138)
#X, Y
x<-rnorm(1000, 0, 0.1)
y<-rnorm(1000, 0, 1) + x
library(dplyr)
tmp <- data.table::data.table(X=x, Y=y) %>%
group_by(X) %>%
summarise(y.bar=mean(Y))
mean(tmp$y.bar)
[1] 0.04224
mean(y)
[1] 0.04224
:
\[\begin{align*} \{\tilde{\beta}_{0},\tilde{\beta}_{1}\}&=\arg\min\limits_{{\tilde{\beta}_{0},\tilde{\beta}_{1}}}\sum _{i=1}^n(y_{i}-\tilde{\beta}_{0}-x_{i}\tilde{\beta}_{1})^2\\ &= \arg\min\limits_{{\tilde{\beta}_{0},\tilde{\beta}_{1}}}\sum _{i=1}^n\hat{u_{i}}^2 \end{align*}\]
image1<-here::here('Fig','reg1.jpg')
knitr::include_graphics(image1)
Figure 3.1: 迴歸線圖
sales \(\approx {\beta}_{0}+{\beta}_{1}\cdot\) TV
file<-here::here('data','advertising.csv')
Advertising<-read.csv(file, sep=',', header = TRUE)
OLS1<-lm(sales ~ TV, data=Advertising)
stargazer::stargazer(OLS1, title='電視廣告與銷售量之間的關係',
type=ifelse(knitr::is_latex_output(),"latex","html"),
label=knitr::opts_current$get("label"))
Dependent variable: | |
sales | |
TV | 0.048*** |
(0.003) | |
Constant | 7.033*** |
(0.458) | |
Observations | 200 |
R2 | 0.612 |
Adjusted R2 | 0.610 |
Residual Std. Error | 3.259 (df = 198) |
F Statistic | 312.100*** (df = 1; 198) |
Note: | p<0.1; p<0.05; p<0.01 |
library(ggplot2)
A1<-ggplot(Advertising, aes(x=TV, y=sales)) +
labs(y = 'Sales', x = 'TV') +
geom_point(col="saddlebrown") +
geom_smooth(method="lm", col='blue', se=F, size=1.5) ; A1
Figure 3.2: 電視廣告與銷售量之間的關係
m1 <- lm(sales ~ TV, Advertising)
Advertising$predicted <- predict(m1) # Save the predicted values
Advertising$residuals <- residuals(m1) # Save the residual values
# Quick look at the actual, predicted, and residual values
#library(dplyr)
#Advertising %>% select(predicted, residuals) %>% head()
ggplot(Advertising, aes(x=TV, y=sales)) +
geom_point(color="saddlebrown") +
geom_point(aes(y = predicted), shape = 1, color="red") +
geom_segment(aes(xend=TV, yend=predicted), color="lightgray") +
theme_bw()
\[\begin{align*} \tilde{u} & = y_{i}- \hat{y}_{i} \\ & = y_{i}- \tilde{\beta}_{0}-\tilde{\beta}_{1}x_{i} \end{align*}\]
\[\begin{align} S(\tilde{u}) = {\sum\limits_{i=1}^n(y_{i}-\hat{y})^2} \\ L(y) = {\sum\limits_{i=1}^n(y_{i}-\hat{y})^2} \tag{4.1} \end{align}\]
\[\begin{align*} \frac{dL}{d\hat{y}}L(y) & = \frac{d}{d\hat{y}}{\sum\limits_{i=1}^n(y_{i}-\hat{y})^2} \\ & = \sum\limits_{i=1}^n(y_{i}^2-2y_{i}\hat{y}+\hat{y}^2) \\ & = \sum(-2y_{i}+2\hat{y}) \\ & = -2\sum(y_{i} - \hat{y}) \end{align*}\]
\[-2\sum(y_{i} - \hat{y})=0\]
\[\begin{align*} -2\sum(y_{i} - \hat{y}) & = -2(\sum y_{i})-n\hat{y}\\ n\hat{y} = \sum y_{i} \end{align*}\]
set.seed(666)
Y <- rnorm(1000, mean = 10, sd = 2)
mean(Y)
## [1] 9.961
obs <- rnorm(50, 10, 3)
# generate empty list
squared_residuals <- rep(NA, length(obs))
for (i in 1:length(obs)) {
squared_residuals[i] = sum((Y - obs[i])^2)
}
data.frame(obs_values = obs, squared_residuals = squared_residuals) %>%
ggplot(aes(obs_values, squared_residuals)) +
stat_smooth(method="lm",
formula = y ~ poly(x, 2),
se = FALSE,
colour = "#FCC3B0",
linetype = "dashed") +
geom_point(col = "#661E4F", size = 2.2, alpha = 0.7) +
geom_vline(xintercept=mean(Y) , linetype='dashed', colour='#EEAA11') +
geom_hline(yintercept=min(squared_residuals), linetype='dashed', colour='#113BEA') +
labs(title = "Sum of Squared Residuals (SSR) Loss Function",
x = "Summary Value",
y = "SSR") +
theme_minimal() +
# theme(text = element_text(family = ""),
# plot.title = element_text(family = "", hjust = 0.5) +
scale_y_continuous(labels = scales::comma)
Figure 4.1: 誤差平方和函數圖
\[\begin{align*} S(\tilde{\beta}_{0},\tilde{\beta}_{1})= {\sum\limits_{i=1}^n(y_{i}-\tilde{\beta}_{0}-x_{i}\tilde{\beta}_{1})^2} \end{align*}\]
1.首先對\(\{\tilde{\beta}_{0},\tilde{\beta}_{1}\}\)取微分
2.命兩者的微分等於0
3.求出\(\{\tilde{\beta}_{0},\tilde{\beta}_{1}\}\)的解。
\[y_{i}-\tilde{\beta}_{0}-x_{i}\tilde{\beta}_{1}\]
\[\begin{align*} S(\tilde{\beta}_{0},\tilde{\beta}_{1}) & = {\sum\limits_{i=1}^n(y_{i}-\tilde{\beta}_{0}-x_{i}\tilde{\beta}_{1})^2} \\ & = {\sum\limits_{i=1}^n(y_{i}^2-2y_{i}\tilde{\beta}_{0}-2y_{i}\tilde{\beta}_{1}x_{i}+ \tilde{\beta}_{0}^2+2\tilde{\beta}_{0}\tilde{\beta}_{1}x_{i}+ \tilde{\beta}_{1}^2x_{i}^2)} \end{align*}\]
\[\begin{align*} \frac{\partial S(\tilde{\beta}_{0},\tilde{\beta}_{1})}{\partial \tilde{\beta}_{0}}= {\sum\limits_{i=1}^n(-2y_{i}+2\tilde{\beta}_{0}+2\tilde{\beta}_{1}x_{i})} \end{align*}\]
\[\begin{align*} \frac{\partial S(\tilde{\beta}_{0},\tilde{\beta}_{1})}{\partial S(\tilde{\beta}_{1}})= {\sum\limits_{i=1}^n(-2y_{i}x_{i}+2\tilde{\beta}_{0}x_{i}+2\tilde{\beta}_{1}x_{i}^2)} \end{align*}\]
\[\begin{align*} 0 & = {\sum\limits_{i=1}^n(-2y_{i}+2\tilde{\beta}_{0}+2\tilde{\beta}_{1}x_{i})} \tag{4.2} \end{align*}\]
\[\begin{align*} 0 & = {\sum\limits_{i=1}^n(-2y_{i}x_{i}+2\tilde{\beta}_{0}x_{i}+2\tilde{\beta}_{1}x_{i}^2)} \tag{4.3} \end{align*}\]
\[\begin{align*} \hat{\beta}_{0}n &= {(\sum\limits_{i=1}^ny_{i})- \hat{\beta}_{1}{(\sum\limits_{i=1}^nx_{i})}} \\ \tilde{\beta}_{0} &=\bar{Y}-\tilde{\beta}_{1} \bar{x} \tag{4.4} \end{align*}\]
\[\begin{align*} \hat{\beta}_{1}\sum\limits_{i=1}^nx_{i}^2 &= (\sum\limits_{i=1}^nx_{i}y_{i})- \tilde{\beta}_{0}{(\sum\limits_{i=1}x_{i}}) \tag{4.5} \end{align*}\]
這兩個等式稱為normal equations
從normal equations的第1式((4.4)可以得到:
\[\begin{align*} \hat{\beta}_{1} &=\frac{\sum y_{i}-\hat{\beta}_{0}n}{\sum x_{i}} \tag{4.6} \end{align*}\]
\[\begin{align*} \hat{\beta}_{0}=\frac{\sum x_{i}y_{i}-\hat{\beta}_{1}\sum x_{i}^2}{\sum x_{i}} \tag{4.7} \end{align*}\]
\[\begin{align*} \hat{\beta}_{1} & =\frac{\sum y_{i}-n\frac{\sum x_{i}y_{i}-\hat{\beta}_{1}\sum x_{i}^2}{\sum x_{i}}}{\sum x_{i}}\\ & = \frac{n\sum x_{i}y_{i}-\sum x_{i}\sum y_{i}}{n\sum x_{i}^2-(\sum x_{i})^2} \tag{4.8} \end{align*}\]
\[\begin{align*} {n\sum x_{i}y_{i}-\sum x_{i}\sum y_{i}} & = {n(\sum x_{i}y_{i}-\bar{y}\sum x_{i})}\\ & = {n(\sum x_{i}y_{i}-n\bar{x}\bar{y})} \\ & = {n(\sum x_{i}y_{i}-n\bar{x}\bar{y}-n\bar{x}\bar{y}+n\bar{x}\bar{y})} \\ & = {n(\sum x_{i}y_{i}-\bar{y}\sum x_{i}-\bar{x}\sum y_{i}+\sum \bar{x}\bar{y})} \\ & = {n\sum (x_{i}-\bar{x})(y_{i}-\bar{y})} \tag{4.9} \end{align*}\]
\[\begin{align*} {n\sum x_{i}^2-(\sum x_{i})^2} & = {n\sum x_{i}^2-(\sum x_{i})^2+(\sum x_{i})^2-(\sum x_{i})^2}\\ & = {n\sum x_{i}^2-2n\bar{x}(\sum x_{i})+n^2(\bar{x})^2} \\ & = {n(\sum x_{i}^2-2\bar{x}\sum x_{i}+n(\bar{x})^2)}\\ & = {n(\sum x_{i}^2-2\bar{x}\sum x_{i}+\sum \bar{x}^2)}\\ & = {n\sum(x_{i}-\bar{x})^2} \tag{4.10} \end{align*}\] (因為\(\sum \bar{x}^2=\bar{x}^2+\bar{x}^2+\cdots +\bar{x}^2=n\bar{x}^2\))
\[\begin{align*} {\hat{\beta}_{1}=\frac{\sum_{i=1}^n(x_{i}-\bar{x})(y_{i}-\bar{y})}{\sum_{i=1}^n(x_{i}-\bar{x})^2} }=\frac{\mathrm {Sample\hspace{.5em} covariance\hspace{.5em} of\hspace{.5em} X\hspace{.5em} and\hspace{.5em} Y}}{\mathrm {sample\hspace{.5em} variance\hspace{.5em} of\hspace{.5em} X}}$\\ \end{align*}\]
X的變異數越大,\(\hat{\beta}_{1}\)越小
X, Y的共變量越大,\(\hat{\beta}_{1}\)越大。共變量可寫成\(\sum xy\),其中 \(x=(X-\bar{X}),\)y=(Y-{Y})$。
另外,
\[ \hat{\beta}_{0}=\bar{y}-\hat{\beta}_{1}\bar{x} \]
★如果使用圖書館人數為X,借出的書本(百本)為Y,而且知道過去25天的各項變數統計為\(\sum X=200\)、\(\sum Y=300\)、\(\sum X^2=16600\)、\(\sum Y^2=1696\)、\(\sum XY=2436\),請求出\(\hat{Y}=\hat{\beta_{0}}+\hat{\beta_{1}X}\)。
\(\blacksquare\)把以上的數據代入(4.8),
n=25
#sum(X)
sum.x=200
#sum(Y)
sum.y=300
#sum(XY)
sum.xy <- 2436
#sum(x^2)
sumxsq <- 1660
#sum(y^2)
sumysq <- 1696
#(sumX)^2
sumx.sq <- sum.x^2
beta1 <- (n*sum.xy-sum.x*sum.y)/(n*sumxsq-sumx.sq)
beta1
[1] 0.6
beta0=sum.y/n-beta1*sum.x/n
beta0
[1] 7.2
p <- poly_from_zeros((1):0)
p
## -x + x^2
plot(p, xlab = expression(italic(x)), ylab = expression(italic(P(x))),
main = parse(text = paste("italic(P(x) ==",
as.character(p, decreasing = TRUE),")")),
xlim=c(-1,4))
x0 <- solve(deriv(p)) ## stationary points
lines(tangent(p, x0), col = "dark green", lty = "solid",
limits = cbind(x0-1/4, x0+1/4))
points(x0, p(x0), col = "dark green")
lines(tangent(p, 2), lty=2)
x<-c(2,3,3)
y<-c(2,2,6)
polygon(x, y, lty=2, lwd=2)
segments(-1.5, 2, 2, 2, lty=2, col='red')
segments(-1.5, 6, 3, 6, lty=2, col='red')
Figure 4.2: 一元二次函數求微分圖1
p <- poly_from_zeros((1):0)
plot(p, xlab = expression(italic(x)), ylab = expression(italic(P(x))),
main = parse(text = paste("italic(P(x) ==",
as.character(p, decreasing = TRUE),")")),
xlim=c(-1,4), xaxt='n', yaxt='n')
axis(2, at=c(2, 6), c(expression(paste(f(xi))),expression(paste(f(xi+h)))))
axis(1, at=c(2, 3), c(expression(paste(xi)),expression(paste(xi+h))))
x0 <- solve(deriv(p)) ## stationary points
lines(tangent(p, x0), col = "dark green", lty = "solid",
limits = cbind(x0-1/4, x0+1/4))
points(x0, p(x0), col = "dark green")
lines(tangent(p, 2), lty=2, col='blue', lwd=1.6)
x<-c(2,3,3)
y<-c(2,2,6)
polygon(x, y, lty=2, lwd=2)
segments(-1.5, 2, 2, 2, lty=2, col='red')
segments(-1.5, 6, 3, 6, lty=2, col='red')
Figure 4.3: 一元二次函數求微分圖2
\[\begin{align*} f(\xi+h)-f(\xi) & =(\xi+h)^2-(\xi+h)-(\xi^2-\xi) \\ & = \xi^2+2\xi\cdot h + h^2-\xi-h-\xi^2+\xi \\ & = 2\xi\cdot h + h^2 -h \tag{4.11} \end{align*}\]
\[\begin{align*} m &=\frac{f(\xi+h)-f(\xi)}{\xi+h-\xi} \\ & = \frac{2\xi\cdot h + h^2 -h}{h} \\ & = 2\xi + h -1 \tag{4.12} \end{align*}\]
\[f^{`}=\frac{\partial y}{\partial x}\]
\[f^{`}(x)=ax^{a-1}\]
圖4.3中的藍色虛線代表切線,定義為通過\((\xi,f(\xi))\)這個點而且斜率為\(m\)的直線。
綠色的點則是當\(f{`}=0\)時的切線,此時\(f(\xi)\)是\(f(x)\)的最低點。心算可知當\(\xi\)等於0.5時,\(f^{`}=0\)。
\[\begin{align*} Y & =\hat{\beta}_{0}+ \hat{\beta}_{1}X+\hat{u} \\ \frac{\partial Y(\hat{\beta}_{0}, \hat{\beta}_{1})}{\partial X} & =\hat{\beta}_{1} \end{align*}\]
\[\sum {x}_{i}\hat{u}_{i}=0\]
證明: \[\begin{align*} \sum x_{i}\hat{u}_{i} & = \sum x_{i}(y_{i}-\hat{\beta}_{0}-\hat{\beta}_{1}x_{i})\\ & = \sum x_{i}y_{i}-\hat{\beta}_{0}\sum x_{i}-\hat{\beta}_{1}\sum x_{i}^2 \end{align*}\]
根據normal equations,也就是式(4.5),\(\hat{\beta}_{0}\sum x_{i}-\hat{\beta}_{1}\sum x_{i}^2=\sum x_{i}y_{i}\)
\[\bar{\hat{y}}=\bar{y}\]
\[\sum {x}_{i}\hat{u}_{i}=0 \]
\[\begin{align*} \sum x_{i}\hat{u}_{i} & = \sum x_{i}(y_{i}-\hat{\beta}_{0}-\hat{\beta}_{1}x_{i})\\ & = \sum x_{i}y_{i}-\hat{\beta}_{0}\sum x_{i}-\hat{\beta}_{1}\sum x_{i}^2 \end{align*}\]
\[\sum \hat{y}_{i}\hat{u}_{i}=0\]
\[\begin{align*} \sum \hat{y}_{i}\hat{u}_{i} & = \sum (\hat{\beta}_{0}+\hat{\beta}_{1}x_{i})\hat{u}_{i}\\ & = \sum \hat{\beta}_{0}\hat{u}_{i}+\hat{\beta}_{1}\sum x_{i}\hat{u}_{1} \\ &= \hat{\beta}_{0}\sum \hat{u}_{i}+\hat{\beta}_{1}\sum x_{i}\hat{u}_{1} \end{align*}\]
\[\sum \hat{u}_{i}= 0\qquad\sum x_{i}\hat{u}_{1}=0\]
\[\sum \hat{\beta}_{0}\hat{u}_{i}+\hat{\beta}_{1}\sum x_{i}\hat{u}_{1}= 0\]
image3<-here::here('Fig','regybar0.jpg')
knitr::include_graphics(image3)
Figure 4.4: 有Y平均值的迴歸線圖
image5<-here::here('Fig','regybarxbar.jpg')
knitr::include_graphics(image5)
Figure 4.5: 有X與Y平均值的迴歸線圖
image6<-here::here('Fig','regybar1.jpg')
knitr::include_graphics(image6)
Figure 4.6: 有Y平均值以及迴歸線的迴歸圖線
\[\begin{align*} u &= y_{i}-\hat{y}_{i} \\ &= y_{i}- \tilde{\beta}_{0}-\tilde{\beta}_{1}x_{i} \end{align*}\]
\[\hat{u} \equiv \tilde{u} = \frac{1}{n}\mathcal {\sum\limits_{i=1}^n y_{i}} \]
\[ \hat{\beta_{1}}=\mathcal{n\sum (x_{i}-\bar{x})(y_{i}-\bar{y})} \]
\[\begin{align*} \hat{\beta}_{1} & = \frac{\sum_{i=1}^n(x_{i}-\bar{x})(y_{i}-\bar{y})}{\sum_{i=1}^n(x_{i}-\bar{x})^2} \\ & = \frac{Sample\hspace{.5em} covariance\hspace{.5em} of\hspace{.5em} X\hspace{.5em} and\hspace{.5em} Y}{sample\hspace{.5em} variance\hspace{.5em} of\hspace{.5em} X} \end{align*}\]
另一方面, \[ \hat{\beta}_{0}=\bar{y}-\hat{\beta}_{1}\bar{x} \]
Residual Sum of Squares
\[\begin{align*} \sum _{i}^n(\hat{y}_{i}-y_{i})^2 & = \sum _{i}^n\hat{u}^2\\ & = SSR \\ & = \rm{Var}[\hat{u}] \end{align*}\]
Explained Sum of Squares
\[\begin{align*} \sum _{i}^n(\hat{y}-\bar{y})^2 & = SSE\\ & = Var[\hat{y}] \end{align*}\]
x <- seq(1,10,length.out = 100)
y <- 2 + 1.2*x + rnorm(100,0,sd = 2)
cat("Y~X, R-squared:", summary(lm(y ~ x))$r.squared, "\n")
## Y~X, R-squared: 0.6985
cat("X~Y, R-squared:", summary(lm(x ~ y))$r.squared, "\n")
## X~Y, R-squared: 0.6985
set.seed(116)
obs = rnorm(50, 10, 1)
dm<-data.frame(obs=rep(obs,2),
Y = c(rep('y1',50), rep('y2', 50)),
value = c(1 + 1.5*obs + runif(50, 0, 3),
1 + 1.5*obs + rchisq(50, 2)))
ggpubr::ggscatter(dm, x='obs', y='value',add='reg.line',
color='Y', palette = "jco") +
facet_wrap(~ Y) +
stat_cor(label.y = 30) +
stat_regline_equation(label.y = 27)
Figure 6.1: 不同的\(R^2\)迴歸線
set.seed(21)
obs = rnorm(50, 10, 1)
dm<-data.frame(obs=rep(obs,2),
Y = c(rep('y1',50), rep('y2', 50)),
value = c(1 + 1.5*obs + runif(50, 0, 3),
1 + 1.5*obs + rchisq(50, 2)))
ggpubr::ggscatter(dm, x='obs', y='value',add='reg.line',
color='Y', palette = "jco") +
facet_wrap(~ Y) +
stat_cor(label.y = 30) +
stat_regline_equation(label.y = 27)
Figure 6.2: 不同的亂數的迴歸線
set.seed(02138)
X1 <-rnorm(100, 0, 1); X2 <- X1+rnorm(100, 0, 1)
print(cor(X1, X2))
[1] 0.6743
#Y
Y <- X1+rt(100, 40)
f1<-lm(Y ~ X1)
f2<-lm(Y ~ X2)
stargazer(f1, f2, align=TRUE, title='三個迴歸模型比較',
type=ifelse(knitr::is_latex_output(),"latex","html"),
label=knitr::opts_current$get("label"))
Dependent variable: | ||
Y | ||
(1) | (2) | |
X1 | 1.079*** | |
(0.108) | ||
X2 | 0.505*** | |
(0.102) | ||
Constant | 0.007 | 0.048 |
(0.108) | (0.139) | |
Observations | 100 | 100 |
R2 | 0.503 | 0.201 |
Adjusted R2 | 0.498 | 0.193 |
Residual Std. Error (df = 98) | 1.076 | 1.365 |
F Statistic (df = 1; 98) | 99.230*** | 24.620*** |
Note: | p<0.1; p<0.05; p<0.01 |
# graph
par(xpd=NA, mar=par()$mar+c(1, 0, 0, 0))
plot(X1, Y, type='n', xlab="X1, X2")
points(X1, Y, pch=16)
points(X2, Y, col="red", pch=16)
legend("bottomright", c("X1","X2"), col=c("black", "red"),
pch=c(16, 16), bty="n")
Figure 6.3: 散佈圖
set.seed(3939889)
r2.0 <- function(sig){
x <- seq(1,10,length.out = 100) # our predictor
y <- 2 + 1.2*x + rnorm(100,0, sd = sig) # our response; a function of x plus some random noise
summary(lm(y ~ x))$r.squared # print the R-squared value
}
sigmas <- seq(1, 10,length.out = 20)
rout <- sapply(sigmas, r2.0) # apply our function to a series of sigma values
dt <- data.frame(sigmas, rout)
library(ggplot2)
ggplot(data=dt, aes(x=sigmas, y=rout)) +
geom_line(col='#FF6600', size=1.5) +
geom_point() +
labs(y=expression(R^2), x=expression(sigma^2)) +
theme_classic()
Figure 6.4: 變異數與解釋變異量圖1
set.seed(3939889)
beta <- function(sig){
x <- seq(1,10,length.out = 100) # our predictor
y <- 2 + 1.2*x + rnorm(100,0, sd = sig) # our response; a function of x plus some random noise
summary(lm(y ~ x))$coefficients[1,2] # print the R-squared value
}
sigmas <- seq(1, 10,length.out = 20)
res <- sapply(sigmas, beta)
dt <- data.frame(x=sigmas, y=res)
ggplot(data=dt, aes(sigmas, res)) +
geom_line(col='#FF6600', size=1.5) +
geom_point() +
labs(y=expression(beta[1]), x=expression(sigma^2)) +
theme_classic()
Figure 6.5: 變異數與解釋變異量圖2
set.seed(5525252)
Y.pre <- function(sig){
x <- seq(1,10,length.out = 100) # our predictor
y <- 2 + 1.2*x + rnorm(100,0, sd = sig) # our response; a function of x plus some random noise
m1<-lm(y ~ x)
return(m1$fitted.values) # fitted values
}
Y.mean <- function(sig){
x <- seq(1,10,length.out = 100)
y <- 2 + 1.2*x + rnorm(100,0, sd = sig)
return(mean(y)) # fitted values
}
Y.values <- function(sig){
x <- seq(1,10,length.out = 100)
y <- 2 + 1.2*x + rnorm(100,0, sd = sig) # our response
return(y)
}
sigmas <- c(1, 10)
tmp1<- sapply(sigmas, Y.pre) # apply our function
tmp2<- sapply(sigmas, Y.mean)
tmp3<- sapply(sigmas, Y.values)
library(dplyr); library(data.table)
tmp <- data.table(Y.pre1=tmp1[,1], Y.mean1=tmp2[1], Y.values1=tmp3[,1],
Y.pre2=tmp1[,2], Y.mean2=tmp2[2], Y.values2=tmp3[,2])
tmp %>% summarise(SSR1=sum(Y.pre1-Y.mean1)^2, SST1=sum(Y.values1-Y.mean1)^2,
R.squared1=SSR1/SST1,
SSR2=sum(Y.pre2-Y.mean2)^2, SST2=sum(Y.values2-Y.mean2)^2,
R.squared2=SSR2/SST2)
## SSR1 SST1 R.squared1 SSR2 SST2 R.squared2
## 1 208.3 11.6 17.95 42504 5031 8.448
kable(head(tmp, n=10), caption='SST與變異數') %>%
kable_styling(full_width = F)
Y.pre1 | Y.mean1 | Y.values1 | Y.pre2 | Y.mean2 | Y.values2 |
---|---|---|---|---|---|
3.375 | 8.619 | 2.796 | 4.158 | 7.655 | -2.276 |
3.483 | 8.619 | 2.727 | 4.270 | 7.655 | 3.049 |
3.592 | 8.619 | 2.268 | 4.382 | 7.655 | 17.000 |
3.701 | 8.619 | 3.778 | 4.495 | 7.655 | 17.140 |
3.810 | 8.619 | 3.584 | 4.607 | 7.655 | 4.024 |
3.919 | 8.619 | 3.414 | 4.719 | 7.655 | -10.736 |
4.028 | 8.619 | 4.375 | 4.832 | 7.655 | 5.456 |
4.137 | 8.619 | 1.992 | 4.944 | 7.655 | -1.539 |
4.246 | 8.619 | 5.026 | 5.056 | 7.655 | 12.123 |
4.354 | 8.619 | 6.581 | 5.168 | 7.655 | -10.050 |
調整後的\(R^2\)考慮樣本數\(n\)以及自變數的數目\(k\): \[ R^2_{Adj}=1-\frac{(1-R^2)(n-1)}{n-k-1} \]
DT<-data.frame(Y=c(1,1,1,1,1,2,2,2,2,2,3,3,3,10),
X=c(1,2,1,1,2,1,2,1,3,1,2,3,1,11))
m1 <- lm(Y ~ X, data=DT)
library(ggpubr)
ggscatter(DT, x = "X", y = "Y", add = "reg.line", color = '#aecc02') +
stat_cor(label.x = 3, label.y = 32) +
stat_regline_equation(label.x = 3, label.y = 35)
Figure 6.6: R2散佈圖1
library(tidyverse)
DT<-tibble(
X=seq(1, 10, by=0.5),
Y=X^2)
library(ggpubr)
ggscatter(DT, x = "X", y = "Y", add = "reg.line", color = '#c12c02') +
stat_cor(label.x = 4, label.y = 75) +
stat_regline_equation(label.x = 4, label.y = 85)
Figure 6.7: R2散佈圖2
DTnew<-tibble(X=c(7, 7.5, 8, 8.9, 8.7, 1, 2),
Y=c(19, 19.5, 20, 30 , 23, 1, 1.3))
library(ggpubr)
ggscatter(DTnew, x = "X", y = "Y", add = "reg.line", color = '#21baec') +
stat_cor(label.x = 1, label.y = 32) +
stat_regline_equation(label.x = 1, label.y = 35)
Figure 6.8: R2散佈圖3
mtcars
這筆資料的hp以及mpg繪製散佈圖與迴歸線圖,並且計算迴歸係數。
UsingR
的babies
這筆資料,估計年齡(age)與身高(ht)對於嬰兒重量(wt)的影響。注意這些變數有一定的範圍。
X1<-c(1,2,3,2,5,5,2,4,3,3)
X2<-c(4,6,7,6,7,7,5,7,6,5)
Y<-c(30,38,44,38,50,52,33,50,45,40)
mag <- rbind(X1,X2,Y)
knitr::kable(mag, format = 'simple')
X1 | 1 | 2 | 3 | 2 | 5 | 5 | 2 | 4 | 3 | 3 |
X2 | 4 | 6 | 7 | 6 | 7 | 7 | 5 | 7 | 6 | 5 |
Y | 30 | 38 | 44 | 38 | 50 | 52 | 33 | 50 | 45 | 40 |
R
估計X1影響Y的作用,以及X2影響Y的作用。
nym.2002
資料中,性別與年齡會影響完成馬拉松的時間嗎?
## 最後更新日期 05/19/2021