目录

本教程涵盖R语言统计与建模的12个核心主题，每个章节均包含数学原理阐释与代码实现。

章节概览

章节 主题 主要内容
第一章 线性回归模型 多元线性回归、OLS估计、残差分析、变量选择、正则化
第二章 广义线性模型 逻辑回归、泊松回归、负二项回归、零膨胀模型
第三章 混合效应模型 线性混合模型、随机效应、GLMM、重复测量分析
第四章 时间序列分析 时间序列分解、ARIMA、SARIMA、GARCH模型
第五章 生存分析 Kaplan-Meier估计、Cox回归、竞争风险模型
第六章 多元统计分析 PCA、因子分析、聚类分析、判别分析
第七章 面板数据模型 固定效应、随机效应、Hausman检验、动态面板
第八章 结构方程模型 路径分析、验证性因子分析、潜变量增长模型
第九章 非参数与半参数回归 核密度估计、LOESS、样条回归、GAM
第十章 计量经济学方法 工具变量、断点回归、双重差分、倾向得分匹配
第十一章 模型选择与诊断 信息准则、交叉验证、残差诊断、影响点检测
第十二章 贝叶斯统计建模 贝叶斯推断、MCMC、贝叶斯回归、模型比较

详细目录

第十二章：贝叶斯统计建模

在Rstudio中安装本节课所有需要的包，运行以下指令：

install.packages(c(
  "ggplot2", "dplyr", "tidyr", "broom", "gridExtra",
  "car", "MASS", "lmtest", "sandwich", "leaps", "glmnet", "splines",
  "pscl", "brant",
  "lme4", "nlme", "lmerTest",
  "forecast", "tseries", "vars", "rugarch", "fGarch",
  "survival", "survminer", "cmprsk",
  "FactoMineR", "factoextra", "cluster", "vegan", "mclust", "psych",
  "plm", "bife", "pglm",
  "lavaan", "semPlot",
  "mgcv",
  "AER", "MatchIt", "quantreg", "rdrobust",
  "rstanarm", "brms", "coda", "bayesplot", "loo",
  "boot", "caret", "AICcmodavg"
))

第一章：线性回归模型

线性回归是统计分析中最基础、应用最广泛的建模方法之一。本章将从模型原理出发，系统讲解多元线性回归的建模过程、参数估计、假设检验、诊断方法及扩展技术。

1.1 多元线性回归模型形式与假设

意义与使用场景

核心意义：多元线性回归用于研究一个连续型因变量与多个自变量之间的线性关系，是量化多因素影响、进行预测推断的基础工具。

举例：研究年龄、BMI、住院天数对医疗费用的影响

为什么这种数据适合用线性回归？

首先，因变量”医疗费用”是连续型数值变量（单位：元），取值范围从几百到几十万不等，符合线性回归对因变量的要求。其次，三个自变量——年龄（连续变量）、BMI（连续变量）、住院天数（连续变量）——都是可量化的数值型指标，且理论上与医疗费用存在近似线性的关系：年龄越大，慢性病越多，费用越高；BMI偏离正常范围越多，并发症风险越大；住院天数越长，累计费用越高。这种”连续因变量+多个连续自变量+近似线性关系”的数据结构，正是多元线性回归的典型适用场景。

研究目的是什么？

本研究有三个层次的目的：1. 量化影响程度：回答”年龄每增加1岁，医疗费用平均增加多少元？“这类具体问题，为卫生经济学分析提供依据；2. 识别关键因素：在控制其他变量后，判断哪个因素对费用的影响最大，为医疗资源分配和干预策略提供指导；3. 预测应用：建立预测模型，根据患者特征预估医疗费用，辅助医院预算管理和医保控费。

可能得到什么样的结果？

假设回归结果为：费用 = -5000 + 200×年龄 + 150×BMI + 800×住院天数

  1. 截距解释：当年龄=0、BMI=0、住院天数=0时，理论费用为-5000元（截距本身无实际意义，仅是数学外推）。
  2. 系数解释：年龄系数200表示，在BMI和住院天数不变的情况下，年龄每增加1岁，医疗费用平均增加200元，同理住院天数每增加1天，费用增加800元。
  3. 比较重要性：通过标准化系数或t值，可以判断哪个因素的影响更显著。
  4. 预测示例：一位60岁、BMI=25、住院10天的患者，预计费用 = -5000 + 200×60 + 150×25 + 800×10 = 11,750元。

需要注意什么？

线性回归假设变量间关系是线性的，但实际中可能存在非线性关系（如BMI与费用可能是U型曲线，过低或过高都增加风险）。此外，医疗费用通常右偏分布，可能需要对数变换。这些都需要在建模前进行探索性分析。

数学基础

多元线性回归模型：

描述因变量\(Y\)与多个自变量\(X_1, X_2, \ldots, X_p\)之间线性关系的统计模型。

模型形式： \[Y_i = \beta_0 + \beta_1 X_{i1} + \beta_2 X_{i2} + \cdots + \beta_p X_{ip} + \varepsilon_i\]

矩阵形式： \[\mathbf{Y} = \mathbf{X}\boldsymbol{\beta} + \boldsymbol{\varepsilon}\]

参数说明： - \(Y_i\)：第\(i\)个观测的因变量值 - \(X_{ij}\)：第\(i\)个观测的第\(j\)个自变量值 - \(\beta_0\)：截距项 - \(\beta_j\)：第\(j\)个自变量的回归系数 - \(\varepsilon_i\)：随机误差项 - \(\mathbf{Y}\)：\(n \times 1\)的因变量向量 - \(\mathbf{X}\)：\(n \times (p+1)\)的设计矩阵 - \(\boldsymbol{\beta}\)：\((p+1) \times 1\)的参数向量

经典假设（高斯-马尔可夫假设）：

假设 数学表达 含义
线性性 \(E(\varepsilon_i) = 0\) 误差期望为零
同方差性 \(Var(\varepsilon_i) = \sigma^2\) 误差方差恒定
独立性 \(Cov(\varepsilon_i, \varepsilon_j) = 0\) 误差相互独立
正态性 \(\varepsilon_i \sim N(0, \sigma^2)\) 误差服从正态分布（推断需要）
无多重共线性 \(rank(\mathbf{X}) = p+1\) 自变量间无线性关系

高斯-马尔可夫定理：

在假设1-4满足时，OLS估计量是最佳线性无偏估计量（BLUE）： - 无偏性：\(E(\hat{\boldsymbol{\beta}}) = \boldsymbol{\beta}\) - 有效性：在所有线性无偏估计量中方差最小

代码实现

# ============================================================
# 模拟生成医疗费用数据集
# 场景：研究患者年龄、BMI、住院天数对医疗费用的影响
# ============================================================

# 设置样本量
n <- 200

# 生成自变量
age <- round(rnorm(n, mean = 55, sd = 12))        # 年龄（岁），均值55，标准差12
bmi <- round(rnorm(n, mean = 25, sd = 4), 1)      # BMI指数，均值25，保留1位小数
los <- round(rnorm(n, mean = 7, sd = 3))          # 住院天数，均值7天
los <- pmax(los, 1)                               # 约束：住院天数至少1天

# 生成因变量：医疗费用（元）
# 真实模型：费用 = 1000 + 50*年龄 + 200*BMI + 500*住院天数 + 误差
# 解释：基础费用1000元，年龄每增1岁费用增50元，BMI每增1费用增200元，住院每天增500元
medical_cost <- 1000 + 50 * age + 200 * bmi + 500 * los + rnorm(n, 0, 1500)
medical_cost <- pmax(round(medical_cost, 0), 0)   # 费用取整且非负

# 创建数据框
medical_data <- data.frame(
  patient_id = 1:n,
  age = age,
  bmi = bmi,
  los = los,
  medical_cost = medical_cost
)

# 查看数据结构
str(medical_data)
## 'data.frame':    200 obs. of  5 variables:
##  $ patient_id  : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ age         : num  48 52 74 56 57 76 61 40 47 50 ...
##  $ bmi         : num  33.8 30.2 23.9 27.2 23.3 23.1 21.8 22.6 31.6 24.8 ...
##  $ los         : num  7 3 5 7 9 2 6 9 5 8 ...
##  $ medical_cost: num  15271 11099 11930 10466 14196 ...
# 查看前几行数据
head(medical_data)
##   patient_id age  bmi los medical_cost
## 1          1  48 33.8   7        15271
## 2          2  52 30.2   3        11099
## 3          3  74 23.9   5        11930
## 4          4  56 27.2   7        10466
## 5          5  57 23.3   9        14196
## 6          6  76 23.1   2        10104
# 描述性统计
summary(medical_data[, -1])
##       age             bmi             los         medical_cost  
##  Min.   :27.00   Min.   :15.10   Min.   : 1.00   Min.   : 6755  
##  1st Qu.:47.00   1st Qu.:22.60   1st Qu.: 5.00   1st Qu.:10832  
##  Median :54.00   Median :25.10   Median : 7.00   Median :12312  
##  Mean   :54.88   Mean   :25.16   Mean   : 7.11   Mean   :12299  
##  3rd Qu.:62.00   3rd Qu.:27.82   3rd Qu.: 9.00   3rd Qu.:13710  
##  Max.   :94.00   Max.   :35.30   Max.   :14.00   Max.   :19782

1.2 最小二乘估计（OLS）

意义与使用场景

核心意义：最小二乘法是线性回归最常用的参数估计方法，通过最小化预测误差的平方和来求解最优系数。

举例：根据患者年龄、BMI预测住院费用，找到最佳预测方程

为什么用最小二乘法？

假设我们收集了200名患者的年龄、BMI和住院费用数据，希望找到一个方程：费用 = β₀ + β₁×年龄 + β₂×BMI。问题是：什么样的β₀、β₁、β₂才是”最优”的？最小二乘法的思路是：选择使所有患者的”预测误差平方和”最小的系数。为什么用平方而不是绝对值？因为平方函数可导，便于数学推导；且对大误差惩罚更重，符合实际需求。在高斯-马尔可夫假设下，最小二乘估计是最佳线性无偏估计量（BLUE）。

研究目的是什么？

  1. 得到回归系数：确定年龄和BMI对费用的具体影响数值。
  2. 预测新患者费用：根据新患者的年龄和BMI，预测其住院费用。
  3. 量化预测精度：计算系数的标准误和置信区间。

可能得到什么样的结果？

假设OLS估计结果为：费用 = -3000 + 150×年龄 + 200×BMI

  1. 系数解释：年龄系数150表示，BMI相同时，年龄每增加1岁，费用平均增加150元。
  2. 标准误：年龄系数的标准误为20，则95%置信区间为150±1.96×20 = [110.8, 189.2]。
  3. 预测：一位50岁、BMI=25的患者，预测费用 = -3000 + 150×50 + 200×25 = 7,000元。

需要注意什么？

最小二乘法对异常值敏感（因为平方会放大异常值的影响），如果数据存在异常值，可考虑稳健回归方法。此外，如果存在异方差，需要使用稳健标准误修正。

数学基础

最小二乘法（Ordinary Least Squares, OLS）：

通过最小化残差平方和来估计回归系数的方法。

残差平方和（RSS）： \[RSS = \sum_{i=1}^{n}(Y_i - \hat{Y}_i)^2 = \sum_{i=1}^{n}\varepsilon_i^2\]

OLS估计量： \[\hat{\boldsymbol{\beta}} = (\mathbf{X}'\mathbf{X})^{-1}\mathbf{X}'\mathbf{Y}\]

参数说明： - \(\hat{\boldsymbol{\beta}}\)：回归系数的OLS估计值 - \(\mathbf{X}'\)：设计矩阵的转置 - \((\mathbf{X}'\mathbf{X})^{-1}\)：信息矩阵的逆

估计量的性质：

性质 公式 说明
期望 \(E(\hat{\boldsymbol{\beta}}) = \boldsymbol{\beta}\) 无偏估计
方差 \(Var(\hat{\boldsymbol{\beta}}) = \sigma^2(\mathbf{X}'\mathbf{X})^{-1}\) 估计量的协方差矩阵
标准误 \(SE(\hat{\beta}_j) = \sqrt{\hat{\sigma}^2 \cdot c_{jj}}\) \(c_{jj}\)为\((\mathbf{X}'\mathbf{X})^{-1}\)的对角元素

\(\sigma^2\)的估计： \[\hat{\sigma}^2 = \frac{RSS}{n-p-1} = MSE\]

代码实现

# 使用lm()函数进行OLS估计
# 公式：因变量 ~ 自变量1 + 自变量2 + ...
model_ols <- lm(medical_cost ~ age + bmi + los, data = medical_data)

# 查看模型摘要
summary(model_ols)
## 
## Call:
## lm(formula = medical_cost ~ age + bmi + los, data = medical_data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -3856.1 -1002.9   117.5  1037.1  4023.0 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  401.129    943.059   0.425    0.671    
## age           44.221      9.655   4.580 8.26e-06 ***
## bmi          230.785     27.458   8.405 8.66e-15 ***
## los          515.256     38.689  13.318  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1542 on 196 degrees of freedom
## Multiple R-squared:  0.5657, Adjusted R-squared:  0.559 
## F-statistic: 85.09 on 3 and 196 DF,  p-value: < 2.2e-16
# 提取回归系数
coefficients(model_ols)
## (Intercept)         age         bmi         los 
##   401.12895    44.22123   230.78488   515.25594
# 使用broom包整理结果为数据框格式
broom::tidy(model_ols)
## # A tibble: 4 × 5
##   term        estimate std.error statistic  p.value
##   <chr>          <dbl>     <dbl>     <dbl>    <dbl>
## 1 (Intercept)    401.     943.       0.425 6.71e- 1
## 2 age             44.2      9.66     4.58  8.26e- 6
## 3 bmi            231.      27.5      8.40  8.66e-15
## 4 los            515.      38.7     13.3   3.07e-29
# 手动计算OLS估计量（验证）
X <- model.matrix(~ age + bmi + los, data = medical_data)  # 设计矩阵
Y <- medical_data$medical_cost                               # 因变量向量

# 计算OLS估计量：beta_hat = (X'X)^(-1) X'Y
beta_hat <- solve(t(X) %*% X) %*% t(X) %*% Y
rownames(beta_hat) <- c("(Intercept)", "age", "bmi", "los")

# 比较手动计算与lm()的结果
cat("手动计算的OLS估计值：\n")
## 手动计算的OLS估计值：
print(beta_hat)
##                  [,1]
## (Intercept) 401.12895
## age          44.22123
## bmi         230.78488
## los         515.25594
cat("\nlm()函数的OLS估计值：\n")
## 
## lm()函数的OLS估计值：
print(coefficients(model_ols))
## (Intercept)         age         bmi         los 
##   401.12895    44.22123   230.78488   515.25594

1.3 回归系数的解释与假设检验

意义与使用场景

核心意义：回归系数量化了各自变量对因变量的独立影响程度，假设检验则判断这种影响是否具有统计学意义。

举例：分析年龄、BMI、住院天数对医疗费用的影响，判断哪些因素显著

为什么需要假设检验？

回归分析得到的系数是样本估计值，存在抽样误差。例如，样本中年龄系数是200元/岁，但这可能是偶然波动导致的。假设检验回答的问题是：如果真实世界中年龄对费用没有影响（β=0），观察到样本系数200的概率有多大？如果这个概率（p值）很小（<0.05），则认为年龄确实影响费用。假设检验帮助区分”真实效应”和”抽样噪音”。

研究目的是什么？

  1. 确定显著因素：在多个候选因素中，识别出真正影响费用的因素。
  2. 量化影响程度：给出每个显著因素的具体影响数值和置信区间。
  3. 控制混杂因素：在控制其他变量后，估计某个因素的独立效应。

可能得到什么样的结果？

假设回归结果：

  1. 年龄系数：β̂ = 200，SE = 30，t = 6.67，p < 0.001。结论：年龄显著影响费用，每增加1岁费用增加200元（95%CI: 141-259元）。
  2. BMI系数：β̂ = 50，SE = 40，t = 1.25，p = 0.21。结论：BMI对费用的影响不显著，不能排除BMI与费用无关的可能性。
  3. 住院天数系数：β̂ = 800，SE = 100，t = 8.00，p < 0.001。结论：住院天数显著影响费用。

需要注意什么？

统计显著不等于实际重要。大样本下很小的效应也可能显著，需要结合效应大小判断。此外，多重检验时需要校正显著性水平（如Bonferroni校正）。

数学基础

回归系数的解释：

系数 解释
\(\hat{\beta}_0\) 当所有自变量为0时，因变量的预测值（截距）
\(\hat{\beta}_j\) 在其他自变量保持不变时，\(X_j\)每增加1个单位，\(Y\)的平均变化量

假设检验：

对于每个回归系数，检验： \[H_0: \beta_j = 0 \quad vs \quad H_1: \beta_j \neq 0\]

t统计量： \[t = \frac{\hat{\beta}_j - 0}{SE(\hat{\beta}_j)} \sim t_{n-p-1}\]

参数说明： - \(SE(\hat{\beta}_j)\)：回归系数的标准误 - \(n-p-1\)：自由度 - \(t_{n-p-1}\)：自由度为\(n-p-1\)的t分布

置信区间： \[\hat{\beta}_j \pm t_{\alpha/2, n-p-1} \cdot SE(\hat{\beta}_j)\]

p值判断： - \(p < 0.05\)：拒绝\(H_0\)，该自变量对因变量有显著影响 - \(p \geq 0.05\)：不能拒绝\(H_0\)，该自变量影响不显著

代码实现

# 回归系数的详细解释
coef_summary <- broom::tidy(model_ols, conf.int = TRUE)
print(coef_summary)
## # A tibble: 4 × 7
##   term        estimate std.error statistic  p.value conf.low conf.high
##   <chr>          <dbl>     <dbl>     <dbl>    <dbl>    <dbl>     <dbl>
## 1 (Intercept)    401.     943.       0.425 6.71e- 1  -1459.     2261. 
## 2 age             44.2      9.66     4.58  8.26e- 6     25.2      63.3
## 3 bmi            231.      27.5      8.40  8.66e-15    177.      285. 
## 4 los            515.      38.7     13.3   3.07e-29    439.      592.
# 解释回归系数
cat("\n========== 回归系数解释 ==========\n")
## 
## ========== 回归系数解释 ==========
cat(sprintf("截距(β0) = %.2f：当年龄=0、BMI=0、住院天数=0时，预测医疗费用为%.2f元\n", 
            coef_summary$estimate[1], coef_summary$estimate[1]))
## 截距(β0) = 401.13：当年龄=0、BMI=0、住院天数=0时，预测医疗费用为401.13元
cat(sprintf("年龄(β1) = %.2f：在BMI和住院天数不变时，年龄每增加1岁，医疗费用平均增加%.2f元\n", 
            coef_summary$estimate[2], coef_summary$estimate[2]))
## 年龄(β1) = 44.22：在BMI和住院天数不变时，年龄每增加1岁，医疗费用平均增加44.22元
cat(sprintf("BMI(β2) = %.2f：在年龄和住院天数不变时，BMI每增加1，医疗费用平均增加%.2f元\n", 
            coef_summary$estimate[3], coef_summary$estimate[3]))
## BMI(β2) = 230.78：在年龄和住院天数不变时，BMI每增加1，医疗费用平均增加230.78元
cat(sprintf("住院天数(β3) = %.2f：在年龄和BMI不变时，住院天数每增加1天，医疗费用平均增加%.2f元\n", 
            coef_summary$estimate[4], coef_summary$estimate[4]))
## 住院天数(β3) = 515.26：在年龄和BMI不变时，住院天数每增加1天，医疗费用平均增加515.26元
# 假设检验结果解读
cat("\n========== 假设检验结果 ==========\n")
## 
## ========== 假设检验结果 ==========
for (i in 2:nrow(coef_summary)) {
  var_name <- coef_summary$term[i]
  p_val <- coef_summary$p.value[i]
  if (p_val < 0.001) {
    sig <- "***"
  } else if (p_val < 0.01) {
    sig <- "**"
  } else if (p_val < 0.05) {
    sig <- "*"
  } else {
    sig <- ""
  }
  cat(sprintf("%s: t = %.3f, p = %.4f %s\n", 
              var_name, coef_summary$statistic[i], p_val, sig))
}
## age: t = 4.580, p = 0.0000 ***
## bmi: t = 8.405, p = 0.0000 ***
## los: t = 13.318, p = 0.0000 ***
cat("显著性标记: *** p<0.001, ** p<0.01, * p<0.05\n")
## 显著性标记: *** p<0.001, ** p<0.01, * p<0.05
# 置信区间
cat("\n========== 95%%置信区间 ==========\n")
## 
## ========== 95%%置信区间 ==========
for (i in 2:nrow(coef_summary)) {
  cat(sprintf("%s: [%.2f, %.2f]\n", 
              coef_summary$term[i], 
              coef_summary$conf.low[i], 
              coef_summary$conf.high[i]))
}
## age: [25.18, 63.26]
## bmi: [176.63, 284.94]
## los: [438.96, 591.56]
# 整体模型显著性检验（F检验）
model_summary <- summary(model_ols)
f_stat <- model_summary$fstatistic
p_value_f <- pf(f_stat[1], f_stat[2], f_stat[3], lower.tail = FALSE)
cat(sprintf("\n整体F检验: F = %.2f, p = %.4f\n", f_stat[1], p_value_f))
## 
## 整体F检验: F = 85.09, p = 0.0000

1.4 决定系数（R²）与调整R²

意义与使用场景

核心意义：R²衡量模型对数据的拟合优度，即模型解释了因变量变异的百分比，是评价回归模型质量的核心指标。

举例：评估医疗费用预测模型的解释能力

为什么需要R²？

假设我们建立了费用 = β₀ + β₁×年龄 + β₂×BMI + β₃×住院天数的回归模型。问题是：这个模型”好”到什么程度？R²回答这个问题：如果R² = 0.75，表示年龄、BMI、住院天数这三个变量解释了医疗费用变异的75%，剩下25%的变异由其他未纳入的因素（如病情严重程度、治疗方案等）或随机误差导致。R²将模型拟合效果量化为一个0-1之间的数值，便于理解和比较。

研究目的是什么？

  1. 评估模型解释力：判断当前模型是否足够好，是否需要纳入更多变量。
  2. 比较竞争模型：比较不同变量组合的模型哪个拟合更好。
  3. 报告研究质量：R²是回归分析的标准报告指标。

可能得到什么样的结果？

假设模型结果：

  1. R² = 0.75：模型解释了75%的费用变异，拟合效果良好。
  2. 调整R² = 0.74：考虑变量数量后的校正，与R²接近说明变量数量合理。
  3. 模型比较：如果加入”病情严重程度”后R²提升到0.85，说明该变量贡献了10%的额外解释力。

需要注意什么？

高R²不一定是好模型。过度拟合（变量过多）会导致R²虚高但预测能力下降。调整R²惩罚变量数量，更适合模型比较。此外，因果推断研究中R²可能较低，但模型仍有价值。

数学基础

决定系数\(R^2\)：

衡量模型对数据变异的解释能力。

计算公式： \[R^2 = 1 - \frac{RSS}{TSS} = 1 - \frac{\sum(Y_i - \hat{Y}_i)^2}{\sum(Y_i - \bar{Y})^2} = \frac{SSR}{TSS}\]

参数说明： - \(RSS\)：残差平方和（Residual Sum of Squares） - \(TSS\)：总平方和（Total Sum of Squares） - \(SSR\)：回归平方和（Sum of Squares for Regression） - \(\bar{Y}\)：因变量的均值

平方和分解： \[TSS = SSR + RSS\] \[\sum(Y_i - \bar{Y})^2 = \sum(\hat{Y}_i - \bar{Y})^2 + \sum(Y_i - \hat{Y}_i)^2\]

调整\(R^2\)（Adjusted \(R^2\)）：

考虑自变量数量的惩罚，避免过拟合。

\[R^2_{adj} = 1 - \frac{RSS/(n-p-1)}{TSS/(n-1)} = 1 - (1-R^2)\frac{n-1}{n-p-1}\]

参数说明： - \(n\)：样本量 - \(p\)：自变量个数

\(R^2\)与调整\(R^2\)的比较：

指标 范围 特点 适用场景
\(R^2\) \([0, 1]\) 随自变量增加而增加（或不变） 单个模型评估
调整\(R^2\) \([0, 1]\) 可能随无关变量增加而下降 模型比较、变量选择

代码实现

# 提取R²和调整R²
r_squared <- summary(model_ols)$r.squared
adj_r_squared <- summary(model_ols)$adj.r.squared

cat(sprintf("R² = %.4f\n", r_squared))
## R² = 0.5657
cat(sprintf("调整R² = %.4f\n", adj_r_squared))
## 调整R² = 0.5590
# 手动计算R²
Y <- medical_data$medical_cost
Y_hat <- fitted(model_ols)
Y_bar <- mean(Y)

TSS <- sum((Y - Y_bar)^2)      # 总平方和
RSS <- sum((Y - Y_hat)^2)      # 残差平方和
SSR <- sum((Y_hat - Y_bar)^2)  # 回归平方和

cat("\n========== 平方和分解 ==========\n")
## 
## ========== 平方和分解 ==========
cat(sprintf("总平方和(TSS) = %.2f\n", TSS))
## 总平方和(TSS) = 1072534642.88
cat(sprintf("回归平方和(SSR) = %.2f\n", SSR))
## 回归平方和(SSR) = 606689724.26
cat(sprintf("残差平方和(RSS) = %.2f\n", RSS))
## 残差平方和(RSS) = 465844918.61
cat(sprintf("TSS = SSR + RSS: %.2f = %.2f + %.2f\n", TSS, SSR, RSS))
## TSS = SSR + RSS: 1072534642.88 = 606689724.26 + 465844918.61
# 手动计算R²和调整R²
r_sq_manual <- 1 - RSS/TSS
n <- nrow(medical_data)
p <- 3  # 自变量个数
adj_r_sq_manual <- 1 - (RSS/(n-p-1))/(TSS/(n-1))

cat("\n========== 手动计算验证 ==========\n")
## 
## ========== 手动计算验证 ==========
cat(sprintf("手动计算R² = %.4f\n", r_sq_manual))
## 手动计算R² = 0.5657
cat(sprintf("手动计算调整R² = %.4f\n", adj_r_sq_manual))
## 手动计算调整R² = 0.5590
# 解释
cat("\n========== 结果解释 ==========\n")
## 
## ========== 结果解释 ==========
cat(sprintf("R² = %.2f%% 表示模型解释了医疗费用变异的%.2f%%\n", 
            r_squared*100, r_squared*100))
## R² = 56.57% 表示模型解释了医疗费用变异的56.57%
cat(sprintf("调整R² = %.2f%% 考虑了自变量数量的惩罚\n", adj_r_squared*100))
## 调整R² = 55.90% 考虑了自变量数量的惩罚

1.5 方差分析（ANOVA）表

意义与使用场景

核心意义：ANOVA表将总变异分解为可解释部分和不可解释部分，用于检验整体回归关系的显著性。

举例：检验年龄、BMI、住院天数联合是否对医疗费用有显著预测作用

为什么需要ANOVA表？

假设检验每个系数的t检验只能判断单个变量的显著性，但无法回答”整个模型是否有意义”的问题。例如，可能三个变量的系数都不显著（p都>0.05），但它们联合起来却能显著预测费用。ANOVA表通过F检验回答：这个包含年龄、BMI、住院天数的模型，整体上是否比”只用均值预测”更好？如果F检验显著（p<0.05），说明至少有一个自变量对费用有显著影响。

研究目的是什么？

  1. 整体模型检验：判断模型整体是否有效，避免”所有系数都不显著但模型整体有效”的误判。
  2. 变异分解：量化各因素解释的变异量，理解数据结构。
  3. 模型比较：比较嵌套模型的拟合效果差异。

可能得到什么样的结果？

假设ANOVA表结果：

  1. F = 25.6，p < 0.001：模型整体高度显著，至少有一个自变量对费用有显著影响。
  2. 变异分解：SSR = 1,000,000（回归解释），SSE = 500,000（残差），TSS = 1,500,000（总变异）。
  3. 解释比例：R² = SSR/TSS = 66.7%，模型解释了67%的费用变异。

需要注意什么？

F检验显著只说明”至少有一个系数不为零”，不说明所有系数都显著。需要结合t检验判断具体哪些变量显著。此外，F检验假设误差服从正态分布，需要先进行残差诊断。

数学基础

方差分析表（ANOVA Table）：

将总变异分解为回归解释的变异和残差变异，用于检验整体回归关系的显著性。

ANOVA表结构：

来源 自由度(df) 平方和(SS) 均方(MS) F值 p值
回归 \(p\) \(SSR\) \(MSR = SSR/p\) \(F = MSR/MSE\) \(P(F > F_{obs})\)
残差 \(n-p-1\) \(RSS\) \(MSE = RSS/(n-p-1)\)
总计 \(n-1\) \(TSS\)

F检验：

检验整体回归关系的显著性。

假设： \[H_0: \beta_1 = \beta_2 = \cdots = \beta_p = 0 \quad vs \quad H_1: 至少有一个\beta_j \neq 0\]

F统计量： \[F = \frac{MSR}{MSE} = \frac{SSR/p}{RSS/(n-p-1)} \sim F_{p, n-p-1}\]

参数说明： - \(MSR\)：回归均方 - \(MSE\)：残差均方（也是\(\sigma^2\)的无偏估计） - \(F_{p, n-p-1}\)：自由度为\((p, n-p-1)\)的F分布

代码实现

# 生成ANOVA表
anova_result <- anova(model_ols)
print(anova_result)
## Analysis of Variance Table
## 
## Response: medical_cost
##            Df    Sum Sq   Mean Sq F value    Pr(>F)    
## age         1  39416500  39416500  16.584 6.751e-05 ***
## bmi         1 145724361 145724361  61.312 2.992e-13 ***
## los         1 421548864 421548864 177.363 < 2.2e-16 ***
## Residuals 196 465844919   2376760                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
# 使用car包的Anova函数（Type II/III SS）
car::Anova(model_ols, type = "II")
## Anova Table (Type II tests)
## 
## Response: medical_cost
##              Sum Sq  Df F value    Pr(>F)    
## age        49854767   1  20.976 8.257e-06 ***
## bmi       167903714   1  70.644 8.661e-15 ***
## los       421548864   1 177.363 < 2.2e-16 ***
## Residuals 465844919 196                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
# 手动构建ANOVA表
Y <- medical_data$medical_cost
Y_hat <- fitted(model_ols)
Y_bar <- mean(Y)

n <- nrow(medical_data)
p <- 3

SSR <- sum((Y_hat - Y_bar)^2)
RSS <- sum((Y - Y_hat)^2)
TSS <- sum((Y - Y_bar)^2)

df_regression <- p
df_residual <- n - p - 1
df_total <- n - 1

MSR <- SSR / df_regression
MSE <- RSS / df_residual

F_stat <- MSR / MSE
p_value <- pf(F_stat, df_regression, df_residual, lower.tail = FALSE)

# 构建ANOVA表
anova_table <- data.frame(
  Source = c("Regression", "Residual", "Total"),
  df = c(df_regression, df_residual, df_total),
  SS = c(SSR, RSS, TSS),
  MS = c(MSR, MSE, NA),
  F = c(F_stat, NA, NA),
  p_value = c(p_value, NA, NA)
)

cat("\n========== 手动构建的ANOVA表 ==========\n")
## 
## ========== 手动构建的ANOVA表 ==========
print(anova_table, row.names = FALSE)
##      Source  df         SS        MS        F      p_value
##  Regression   3  606689724 202229908 85.08639 2.722826e-35
##    Residual 196  465844919   2376760       NA           NA
##       Total 199 1072534643        NA       NA           NA
# 解释
cat("\n========== ANOVA结果解释 ==========\n")
## 
## ========== ANOVA结果解释 ==========
cat(sprintf("F统计量 = %.2f，p值 = %.4f\n", F_stat, p_value))
## F统计量 = 85.09，p值 = 0.0000
if (p_value < 0.05) {
  cat("结论：拒绝原假设，模型整体显著，至少有一个自变量对因变量有显著影响\n")
} else {
  cat("结论：不能拒绝原假设，模型整体不显著\n")
}
## 结论：拒绝原假设，模型整体显著，至少有一个自变量对因变量有显著影响

1.6 残差分析

意义与使用场景

核心意义：残差分析是验证回归模型假设的关键步骤，通过检查残差的分布模式来判断模型是否合理。

举例：研究年龄、BMI、住院天数对医疗费用的影响后，需要验证模型假设是否满足

为什么这种数据适合用残差分析？

首先，线性回归模型有四个核心假设：线性关系、误差项正态性、同方差性、独立性。这些假设是否满足直接影响统计推断的有效性。其次，医疗费用数据可能存在异方差（费用高的患者方差可能更大）、非正态分布（费用通常右偏）等问题。残差分析能够系统性地检验这些假设，发现模型潜在的问题。

研究目的是什么？

本研究有三个层次的目的：1. 验证模型假设：检查残差是否满足正态性、同方差性、独立性假设；2. 发现异常观测：识别偏离模型预测较大的数据点，可能是数据错误或特殊病例；3. 改进模型：根据残差模式判断是否需要变量变换或添加新变量。

可能得到什么样的结果？

假设残差分析显示：Q-Q图中大部分点落在对角线上，但尾部略有偏离；残差vs拟合值图呈现漏斗形（低费用患者残差小，高费用患者残差大）。

  1. 正态性判断：Shapiro-Wilk检验p值=0.12，残差近似正态分布，假设基本满足。
  2. 异方差判断：Breusch-Pagan检验p值=0.03，存在异方差问题，高费用患者的预测误差更大。
  3. 异常值识别：发现3个学生化残差绝对值大于2的观测点，需要检查是否为数据录入错误。
  4. 改进建议：对医疗费用进行对数变换，可能改善异方差问题。

需要注意什么？

残差分析是诊断工具，不是解决工具。发现假设违背后需要采取相应措施：异方差可用加权最小二乘或变量变换；非正态可尝试变量变换；异常值需先确认是否为数据错误再决定处理方式。

数学基础

残差类型：

类型 公式 用途
普通残差 \(e_i = Y_i - \hat{Y}_i\) 基本诊断
标准化残差 \(r_i = \frac{e_i}{\hat{\sigma}}\) 正态性检验
学生化残差 \(t_i = \frac{e_i}{\hat{\sigma}\sqrt{1-h_{ii}}}\) 异常值识别

参数说明： - \(h_{ii}\)：帽子矩阵\(\mathbf{H} = \mathbf{X}(\mathbf{X}'\mathbf{X})^{-1}\mathbf{X}'\)的对角元素，称为杠杆值

残差分析的检验内容：

  1. 正态性检验：残差应近似正态分布
    • Q-Q图：点应近似落在对角线上
    • Shapiro-Wilk检验
  2. 异方差性检验：残差方差应恒定
    • 残差vs拟合值图：应无系统模式
    • Breusch-Pagan检验、White检验
  3. 独立性检验：残差应相互独立
    • Durbin-Watson检验（时间序列数据）

代码实现

# 提取残差和拟合值
residuals_std <- rstandard(model_ols)    # 标准化残差
residuals_stud <- rstudent(model_ols)    # 学生化残差
fitted_values <- fitted(model_ols)

# 创建诊断图数据框
diag_data <- data.frame(
  fitted = fitted_values,
  resid = residuals(model_ols),
  resid_std = residuals_std,
  resid_stud = residuals_stud
)

# 1. 残差vs拟合值图（检验异方差性）
p1 <- ggplot2::ggplot(diag_data, ggplot2::aes(x = fitted, y = resid)) +
  ggplot2::geom_point(alpha = 0.6) +
  ggplot2::geom_smooth(se = FALSE, color = "red", linetype = "dashed") +
  ggplot2::geom_hline(yintercept = 0, color = "blue", linetype = "dashed") +
  ggplot2::labs(title = "残差 vs 拟合值", x = "拟合值", y = "残差") +
  ggplot2::theme_minimal()

# 2. Q-Q图（检验正态性）
p2 <- ggplot2::ggplot(diag_data, ggplot2::aes(sample = resid_std)) +
  ggplot2::geom_qq() +
  ggplot2::geom_qq_line(color = "red") +
  ggplot2::labs(title = "残差Q-Q图", x = "理论分位数", y = "标准化残差") +
  ggplot2::theme_minimal()

# 3. 标准化残差直方图
p3 <- ggplot2::ggplot(diag_data, ggplot2::aes(x = resid_std)) +
  ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density)), 
                          bins = 30, fill = "steelblue", alpha = 0.7) +
  ggplot2::geom_density(color = "red", linewidth = 1) +
  ggplot2::labs(title = "标准化残差分布", x = "标准化残差", y = "密度") +
  ggplot2::theme_minimal()

# 4. 残差vs自变量图（以年龄为例）
diag_data$age <- medical_data$age
p4 <- ggplot2::ggplot(diag_data, ggplot2::aes(x = age, y = resid)) +
  ggplot2::geom_point(alpha = 0.6) +
  ggplot2::geom_smooth(se = FALSE, color = "red", linetype = "dashed") +
  ggplot2::geom_hline(yintercept = 0, color = "blue", linetype = "dashed") +
  ggplot2::labs(title = "残差 vs 年龄", x = "年龄", y = "残差") +
  ggplot2::theme_minimal()

# 组合图形
gridExtra::grid.arrange(p1, p2, p3, p4, ncol = 2)

# 正态性检验：Shapiro-Wilk检验
shapiro_test <- shapiro.test(residuals(model_ols))
cat("\n========== 正态性检验 ==========\n")
## 
## ========== 正态性检验 ==========
cat(sprintf("Shapiro-Wilk检验: W = %.4f, p = %.4f\n", 
            shapiro_test$statistic, shapiro_test$p.value))
## Shapiro-Wilk检验: W = 0.9878, p = 0.0830
if (shapiro_test$p.value > 0.05) {
  cat("结论：p > 0.05，不能拒绝正态性假设，残差近似正态分布\n")
} else {
  cat("结论：p < 0.05，拒绝正态性假设，残差可能不服从正态分布\n")
}
## 结论：p > 0.05，不能拒绝正态性假设，残差近似正态分布
# 异方差性检验：Breusch-Pagan检验
bp_test <- lmtest::bptest(model_ols)
cat("\n========== 异方差性检验 ==========\n")
## 
## ========== 异方差性检验 ==========
cat(sprintf("Breusch-Pagan检验: BP = %.4f, p = %.4f\n", 
            bp_test$statistic, bp_test$p.value))
## Breusch-Pagan检验: BP = 2.6993, p = 0.4403
if (bp_test$p.value > 0.05) {
  cat("结论：p > 0.05，不能拒绝同方差假设\n")
} else {
  cat("结论：p < 0.05，存在异方差性\n")
}
## 结论：p > 0.05，不能拒绝同方差假设
# 异方差性检验：White检验（使用car包的ncvTest）
white_test <- car::ncvTest(model_ols)
cat(sprintf("White检验: Chi-square = %.4f, p = %.4f\n", 
            white_test$ChiSquare, white_test$p))
## White检验: Chi-square = 0.1044, p = 0.7466

1.7 影响点与异常值诊断

意义与使用场景

核心意义：识别对模型估计有重大影响的观测点，这些点可能是数据录入错误、特殊群体或重要的发现。

举例：在医疗费用回归分析中，发现一位年轻患者费用异常高昂

为什么这种数据适合用影响点诊断？

首先，回归分析的结果（系数估计、标准误）对所有观测点的贡献是等权重的，个别极端值可能”拉动”回归线，改变整体结论。其次，医疗数据中存在多种异常情况：数据录入错误（费用多输一个零）、特殊病例（罕见并发症导致费用激增）、极端特征患者（超高龄或超低龄）。影响点诊断能够量化每个观测对模型的影响程度，避免被个别异常值误导。

研究目的是什么？

本研究有三个层次的目的：1. 识别异常值：找出Y方向（因变量）偏离模型预测较大的观测点；2. 识别高杠杆点：找出X方向（自变量）偏离数据主体的观测点；3. 识别强影响点：综合判断哪些观测对回归系数估计有重大影响，需要重点关注。

可能得到什么样的结果？

假设诊断结果显示：第47号观测的Cook距离=1.2（远超阈值4/n=0.04），学生化残差=3.5，杠杆值=0.15。

  1. 异常值判断：学生化残差绝对值大于2，该患者的实际费用远高于模型预测值。
  2. 杠杆值判断：杠杆值0.15超过阈值2(p+1)/n=0.08，该患者在自变量空间中位置特殊。
  3. 影响程度：Cook距离1.2远超阈值，删除该观测后，年龄系数从200变为170，变化显著。
  4. 原因分析：该患者为25岁但医疗费用高达15万元（因罕见手术），属于真实但特殊的病例。

需要注意什么？

影响点不一定是错误数据，也可能是真实但特殊的观测。处理策略应分三步：首先检查是否为数据录入错误；其次判断是否为与研究目的相关的特殊群体；最后决定是删除、单独分析还是保留并说明。切忌不加分析地删除所有影响点。

数学基础

异常值与影响点的区别：

概念 定义 识别方法
异常值 Y方向偏离模型预测的点 学生化残差 \(|t_i| > 2\)
高杠杆点 X方向偏离数据主体的点 杠杆值 \(h_{ii} > 2(p+1)/n\)
强影响点 对模型估计有重大影响的点 Cook距离 \(D_i > 4/n\) 或 \(> 1\)

杠杆值（Leverage）：

\[h_{ii} = \mathbf{x}_i'(\mathbf{X}'\mathbf{X})^{-1}\mathbf{x}_i\]

参数说明： - \(h_{ii}\)：帽子矩阵的第\(i\)个对角元素 - 取值范围：\(1/n \leq h_{ii} \leq 1\) - \(\sum_{i=1}^{n} h_{ii} = p+1\)

Cook距离：

综合衡量第\(i\)个观测对回归系数估计的影响。

\[D_i = \frac{\sum_{j=1}^{n}(\hat{Y}_j - \hat{Y}_{j(i)})^2}{(p+1)\hat{\sigma}^2} = \frac{e_i^2}{(p+1)\hat{\sigma}^2} \cdot \frac{h_{ii}}{(1-h_{ii})^2}\]

参数说明： - \(\hat{Y}_{j(i)}\)：删除第\(i\)个观测后第\(j\)个观测的拟合值 - \(e_i\)：第\(i\)个观测的残差

DFFITS和DFBETAS：

指标 公式 判断标准
DFFITS \(\frac{\hat{Y}_i - \hat{Y}_{i(i)}}{\hat{\sigma}_{(i)}\sqrt{h_{ii}}}\) \(|DFFITS| > 2\sqrt{(p+1)/n}\)
DFBETAS \(\frac{\hat{\beta}_j - \hat{\beta}_{j(i)}}{\hat{\sigma}_{(i)}\sqrt{c_{jj}}}\) \(|DFBETAS| > 2/\sqrt{n}\)

代码实现

# 计算各种诊断指标
influence_measures <- influence.measures(model_ols)
print(head(influence_measures$infmat, 10))
##           dfb.1_      dfb.age       dfb.bmi      dfb.los        dffit     cov.r
## 1  -7.398815e-02 -0.034764872  0.1365618895  0.002685856  0.155421745 1.0357346
## 2   1.147870e-03  0.001381330 -0.0065675600  0.007727469 -0.011811847 1.0447767
## 3  -2.983116e-03  0.012838685 -0.0023384401 -0.005578142  0.016262806 1.0437322
## 4   3.403865e-02 -0.012024291 -0.0546174341  0.001529761 -0.120046840 0.9812323
## 5   7.954218e-03  0.011067545 -0.0253263086  0.038100395  0.075436697 1.0152424
## 6  -1.822015e-05 -0.001694264  0.0005103219  0.001674205 -0.002628477 1.0628426
## 7  -2.114082e-02 -0.018793006  0.0313054998  0.015435010 -0.054180549 1.0261557
## 8  -1.149270e-01  0.131114438  0.0648830089 -0.060864300 -0.187682278 0.9989621
## 9   1.341265e-02  0.019691588 -0.0461786820  0.020418162 -0.062645654 1.0406981
## 10 -1.956328e-02  0.025063375  0.0052839783 -0.017725235 -0.066577376 1.0130052
##          cook.d         hat
## 1  6.045828e-03 0.030114585
## 2  3.505774e-05 0.023190158
## 3  6.645484e-05 0.022327031
## 4  3.580057e-03 0.006376240
## 5  1.425058e-03 0.008395402
## 6  1.736079e-06 0.039681241
## 7  7.366315e-04 0.010807768
## 8  8.764286e-03 0.017865461
## 9  9.852950e-04 0.022644150
## 10 1.109928e-03 0.006441036
# 提取各项指标
leverage <- hatvalues(model_ols)           # 杠杆值
cooks_d <- cooks.distance(model_ols)       # Cook距离
dffits_val <- dffits(model_ols)            # DFFITS
dfbetas_val <- dfbetas(model_ols)          # DFBETAS
student_resid <- rstudent(model_ols)       # 学生化残差

# 创建诊断数据框
diag_df <- data.frame(
  obs = 1:nrow(medical_data),
  leverage = leverage,
  cooks_d = cooks_d,
  dffits = dffits_val,
  student_resid = student_resid
)

# 定义阈值
n <- nrow(medical_data)
p <- 3
leverage_threshold <- 2 * (p + 1) / n
cooks_threshold <- 4 / n
dffits_threshold <- 2 * sqrt((p + 1) / n)

# 识别异常点
outliers <- diag_df %>%
  dplyr::filter(
    abs(student_resid) > 2 | 
    leverage > leverage_threshold | 
    cooks_d > cooks_threshold
  )

cat("\n========== 诊断阈值 ==========\n")
## 
## ========== 诊断阈值 ==========
cat(sprintf("杠杆值阈值: %.4f\n", leverage_threshold))
## 杠杆值阈值: 0.0400
cat(sprintf("Cook距离阈值: %.4f\n", cooks_threshold))
## Cook距离阈值: 0.0200
cat(sprintf("DFFITS阈值: %.4f\n", dffits_threshold))
## DFFITS阈值: 0.2828
cat(sprintf("学生化残差阈值: ±2\n"))
## 学生化残差阈值: ±2
cat("\n========== 识别的异常/影响点 ==========\n")
## 
## ========== 识别的异常/影响点 ==========
print(outliers)
##     obs   leverage      cooks_d      dffits student_resid
## 16   16 0.05795669 0.1021429675 -0.64864728    -2.6151238
## 27   27 0.04121236 0.0005244277  0.04568947     0.2203757
## 30   30 0.03022504 0.0401014066  0.40483420     2.2931331
## 56   56 0.04078906 0.0046058067 -0.13553537    -0.6572610
## 65   65 0.04194878 0.0639143466 -0.51201842    -2.4469230
## 72   72 0.04008630 0.0020377733 -0.09009767    -0.4408914
## 95   95 0.04024865 0.0262480857 -0.32528173    -1.5884128
## 96   96 0.01766982 0.0269213049  0.33243233     2.4786540
## 97   97 0.05095437 0.0005341461 -0.04610982    -0.1989969
## 108 108 0.04475884 0.0096045464 -0.19591513    -0.9050761
## 135 135 0.05075307 0.0006292271 -0.05004666    -0.2164380
## 143 143 0.03423459 0.0412255967  0.40993853     2.1773185
## 146 146 0.02723047 0.0298559444 -0.34850853    -2.0830076
## 147 147 0.02864242 0.0516775839  0.46182692     2.6894531
## 149 149 0.06438679 0.1093807809  0.67073383     2.5568190
## 159 159 0.04325478 0.0343106092 -0.37241140    -1.7514755
## 164 164 0.08211808 0.0620214403 -0.50036200    -1.6728552
## 171 171 0.04027479 0.0366646550 -0.38543386    -1.8815106
## 174 174 0.03617286 0.0226828184 -0.30231716    -1.5605258
## 196 196 0.04436346 0.0082159831  0.18114851     0.8407530
## 198 198 0.04007857 0.0024281990 -0.09836017    -0.4813722
# 可视化：Cook距离图
p1 <- ggplot2::ggplot(diag_df, ggplot2::aes(x = obs, y = cooks_d)) +
  ggplot2::geom_bar(stat = "identity", fill = "steelblue") +
  ggplot2::geom_hline(yintercept = cooks_threshold, color = "red", linetype = "dashed") +
  ggplot2::labs(title = "Cook距离", x = "观测编号", y = "Cook距离") +
  ggplot2::theme_minimal()

# 可视化：杠杆值 vs 学生化残差
p2 <- ggplot2::ggplot(diag_df, ggplot2::aes(x = leverage, y = student_resid)) +
  ggplot2::geom_point(alpha = 0.6) +
  ggplot2::geom_hline(yintercept = c(-2, 2), color = "blue", linetype = "dashed") +
  ggplot2::geom_vline(xintercept = leverage_threshold, color = "red", linetype = "dashed") +
  ggplot2::labs(title = "杠杆值 vs 学生化残差", x = "杠杆值", y = "学生化残差") +
  ggplot2::theme_minimal()

# 可视化：残差 vs 杠杆值（带Cook距离等高线）
p3 <- ggplot2::ggplot(diag_df, ggplot2::aes(x = leverage, y = student_resid, size = cooks_d)) +
  ggplot2::geom_point(alpha = 0.6, color = "steelblue") +
  ggplot2::scale_size_continuous(range = c(1, 8)) +
  ggplot2::geom_hline(yintercept = c(-2, 0, 2), color = "gray", linetype = "dashed") +
  ggplot2::geom_vline(xintercept = leverage_threshold, color = "red", linetype = "dashed") +
  ggplot2::labs(title = "残差-杠杆值图（点大小=Cook距离）", 
                x = "杠杆值", y = "学生化残差", size = "Cook距离") +
  ggplot2::theme_minimal()

gridExtra::grid.arrange(p1, p2, p3, ncol = 2)

# 使用car包绘制综合诊断图
car::influencePlot(model_ols, main = "影响点诊断图")

##       StudRes        Hat      CookD
## 16  -2.615124 0.05795669 0.10214297
## 147  2.689453 0.02864242 0.05167758
## 149  2.556819 0.06438679 0.10938078
## 164 -1.672855 0.08211808 0.06202144

1.8 多重共线性诊断

意义与使用场景

核心意义：多重共线性会导致回归系数估计不稳定、标准误增大，影响对变量重要性的判断。

举例：研究血压（收缩压）、舒张压、平均动脉压对心血管事件风险的影响

为什么这种数据适合用多重共线性诊断？

首先，三个血压指标之间存在数学关系：平均动脉压≈舒张压+1/3×脉压差，收缩压与舒张压高度相关（相关系数通常>0.7）。其次，当自变量高度相关时，回归模型难以区分各自的独立贡献，导致系数估计不稳定、标准误膨胀、符号可能反转。多重共线性诊断能够识别这些问题，指导变量选择或建模策略调整。

研究目的是什么？

本研究有三个层次的目的：1. 诊断共线性程度：计算VIF值，判断自变量之间是否存在严重的共线性问题；2. 评估影响：分析共线性对回归系数稳定性、标准误大小的影响；3. 指导解决方案：根据诊断结果决定是否删除变量、合并变量或采用其他建模方法。

可能得到什么样的结果？

假设VIF诊断结果显示：收缩压VIF=8.5，舒张压VIF=7.2，平均动脉压VIF=12.3。

  1. 共线性判断：平均动脉压VIF>10，存在严重共线性；收缩压和舒张压VIF在5-10之间，存在中度共线性。
  2. 原因分析：三个血压指标高度相关，平均动脉压可由收缩压和舒张压计算得出，信息高度重叠。
  3. 对模型的影响：回归系数标准误增大，t值变小，可能导致本应显著的变量变得不显著。
  4. 解决方案：删除平均动脉压，保留收缩压和舒张压；或使用主成分回归提取血压的综合指标。

需要注意什么？

多重共线性主要影响系数的解释和推断，对预测能力影响较小。如果研究目的是预测而非解释，可以容忍一定程度的共线性。解决共线性问题的方法包括：删除高度相关变量、主成分回归、岭回归、LASSO回归等，应根据研究目的选择。

数学基础

多重共线性：

自变量之间存在较强的线性关系，会导致回归系数估计不稳定、标准误增大。

方差膨胀因子（VIF）：

衡量每个自变量被其他自变量解释的程度。

\[VIF_j = \frac{1}{1-R_j^2}\]

参数说明： - \(R_j^2\)：以\(X_j\)为因变量，其他自变量为自变量进行回归的决定系数

VIF判断标准：

VIF值 共线性程度
VIF = 1 无共线性
1 < VIF < 5 轻度共线性
5 ≤ VIF < 10 中度共线性
VIF ≥ 10 严重共线性

条件数（Condition Number）：

\[\kappa = \sqrt{\frac{\lambda_{max}}{\lambda_{min}}}\]

参数说明： - \(\lambda_{max}\)、\(\lambda_{min}\)：设计矩阵\(\mathbf{X}'\mathbf{X}\)的最大、最小特征值 - \(\kappa > 30\)：存在严重共线性

容忍度（Tolerance）： \[TOL_j = 1 - R_j^2 = \frac{1}{VIF_j}\]

代码实现

# 计算VIF
vif_values <- car::vif(model_ols)
cat("========== 方差膨胀因子(VIF) ==========\n")
## ========== 方差膨胀因子(VIF) ==========
print(vif_values)
##      age      bmi      los 
## 1.001234 1.002648 1.002367
# 创建VIF数据框
vif_df <- data.frame(
  Variable = names(vif_values),
  VIF = as.numeric(vif_values),
  Tolerance = 1/as.numeric(vif_values)
)

# 判断共线性程度
vif_df$Collinearity <- cut(vif_df$VIF, 
                           breaks = c(0, 1, 5, 10, Inf),
                           labels = c("无", "轻度", "中度", "严重"))
print(vif_df)
##   Variable      VIF Tolerance Collinearity
## 1      age 1.001234 0.9987674         轻度
## 2      bmi 1.002648 0.9973592         轻度
## 3      los 1.002367 0.9976390         轻度
# 计算条件数
X <- model.matrix(~ age + bmi + los, data = medical_data)
eigenvalues <- eigen(t(X) %*% X)$values
condition_number <- sqrt(max(eigenvalues) / min(eigenvalues))
cat(sprintf("\n条件数: %.2f\n", condition_number))
## 
## 条件数: 533.63
if (condition_number > 30) {
  cat("结论：条件数 > 30，存在严重多重共线性\n")
} else if (condition_number > 15) {
  cat("结论：条件数 > 15，存在中度多重共线性\n")
} else {
  cat("结论：多重共线性问题不严重\n")
}
## 结论：条件数 > 30，存在严重多重共线性
# 模拟存在多重共线性的数据
cat("\n========== 模拟多重共线性示例 ==========\n")
## 
## ========== 模拟多重共线性示例 ==========
set.seed(456)
n_mc <- 100
x1 <- rnorm(n_mc, 50, 10)
x2 <- 2 * x1 + rnorm(n_mc, 0, 1)  # x2与x1高度相关
x3 <- rnorm(n_mc, 30, 5)
y_mc <- 100 + 5 * x1 + 3 * x2 + 2 * x3 + rnorm(n_mc, 0, 10)

data_mc <- data.frame(y = y_mc, x1 = x1, x2 = x2, x3 = x3)

# 查看相关系数矩阵
cor_matrix <- cor(data_mc[, c("x1", "x2", "x3")])
cat("\n相关系数矩阵：\n")
## 
## 相关系数矩阵：
print(round(cor_matrix, 3))
##       x1    x2    x3
## x1 1.000 0.999 0.126
## x2 0.999 1.000 0.127
## x3 0.126 0.127 1.000
# 拟合模型并计算VIF
model_mc <- lm(y ~ x1 + x2 + x3, data = data_mc)
vif_mc <- car::vif(model_mc)
cat("\n存在共线性时的VIF：\n")
## 
## 存在共线性时的VIF：
print(vif_mc)
##         x1         x2         x3 
## 425.683136 425.793113   1.016618
# 解决方法：删除高度相关的变量
model_mc_fixed <- lm(y ~ x1 + x3, data = data_mc)
vif_mc_fixed <- car::vif(model_mc_fixed)
cat("\n删除x2后的VIF：\n")
## 
## 删除x2后的VIF：
print(vif_mc_fixed)
##       x1       x3 
## 1.016031 1.016031

1.9 变量选择方法

意义与使用场景

核心意义：变量选择用于从众多候选变量中筛选出最重要的变量，构建简洁有效的预测模型。

举例：从20个临床指标中筛选出住院费用的关键预测因子

为什么这种数据适合用变量选择方法？

首先，临床数据中往往包含大量指标：人口学特征（年龄、性别）、生命体征（血压、心率）、实验室检查（血常规、生化）、既往病史等，其中部分变量可能与住院费用无关或相关性很弱。其次，纳入过多无关变量会导致模型过拟合、多重共线性、解释困难等问题。变量选择方法能够从候选变量中筛选出真正有预测价值的变量，在保证预测能力的前提下简化模型。

研究目的是什么？

本研究有三个层次的目的：1. 筛选关键变量：从20个候选变量中识别出对住院费用有显著影响的变量；2. 构建简洁模型：用最少的变量达到较好的预测效果，便于临床应用；3. 避免过拟合：通过AIC/BIC等准则惩罚复杂模型，提高模型的泛化能力。

可能得到什么样的结果？

假设逐步回归结果显示：最终模型包含5个变量（年龄、住院天数、手术类型、并发症数量、入院方式），AIC=2456。

  1. 变量筛选结果：从20个候选变量中筛选出5个，模型变量数减少75%。
  2. 预测能力：调整R²从0.72（全模型）下降到0.70（简化模型），损失很小。
  3. 系数稳定性：VIF值均小于3，共线性问题得到改善。
  4. 临床解释：年龄每增加1岁费用增加150元；住院天数每增加1天费用增加800元；手术类型和并发症数量是重要影响因素。

需要注意什么？

变量选择方法各有优劣：向前选择可能遗漏重要变量组合；向后消除要求样本量大于变量数；逐步选择最常用但可能陷入局部最优。AIC倾向于选择较大模型，BIC倾向于选择较小模型。建议结合专业知识，不要完全依赖统计方法，保留临床认为重要的变量。

数学基础

变量选择的目标：

在众多候选自变量中，选择最优的子集，使模型既简洁又有良好的预测能力。

逐步回归方法：

方法 过程 特点
向前选择 从空模型开始，逐步加入变量 可能遗漏重要变量组合
向后消除 从全模型开始，逐步删除变量 要求样本量大于变量数
逐步选择 结合向前和向后，每步可进可退 最常用方法

选择准则：

  1. 调整\(R^2\)：最大化调整\(R^2\)
  2. AIC（Akaike Information Criterion）： \[AIC = n\ln(RSS/n) + 2(p+1)\]
  3. BIC（Bayesian Information Criterion）： \[BIC = n\ln(RSS/n) + \ln(n)(p+1)\]

参数说明： - AIC倾向于选择较大模型 - BIC惩罚更重，倾向于选择较小模型 - 选择AIC/BIC最小的模型

代码实现

# 模拟更多变量的数据
set.seed(789)
n_var <- 200

# 生成候选自变量
x1 <- rnorm(n_var, 50, 10)
x2 <- rnorm(n_var, 25, 5)
x3 <- rnorm(n_var, 100, 20)
x4 <- rnorm(n_var, 30, 8)   # 与y无关的变量
x5 <- rnorm(n_var, 60, 15)  # 与y无关的变量
x6 <- rnorm(n_var, 45, 12)

# 生成因变量（只与x1, x2, x3, x6有关）
y_var <- 500 + 30 * x1 + 20 * x2 + 10 * x3 + 15 * x6 + rnorm(n_var, 0, 200)

data_var <- data.frame(y = y_var, x1 = x1, x2 = x2, x3 = x3, x4 = x4, x5 = x5, x6 = x6)

# 全模型
model_full <- lm(y ~ x1 + x2 + x3 + x4 + x5 + x6, data = data_var)
cat("========== 全模型摘要 ==========\n")
## ========== 全模型摘要 ==========
print(summary(model_full)$coefficients)
##                Estimate  Std. Error    t value     Pr(>|t|)
## (Intercept) 308.8386911 163.5684900  1.8881307 6.050872e-02
## x1           30.3179244   1.4502559 20.9052245 1.799174e-51
## x2           21.7679069   2.8716316  7.5803273 1.408946e-12
## x3           11.3657796   0.7896631 14.3932016 2.186730e-32
## x4            0.1047781   1.8227801  0.0574826 9.542202e-01
## x5            0.1095493   0.9127274  0.1200241 9.045889e-01
## x6           14.0714379   1.2499950 11.2571952 6.333436e-23
# 1. 向前选择
model_forward <- step(lm(y ~ 1, data = data_var), 
                      scope = ~ x1 + x2 + x3 + x4 + x5 + x6,
                      direction = "forward", 
                      trace = 0)
cat("\n========== 向前选择结果 ==========\n")
## 
## ========== 向前选择结果 ==========
print(summary(model_forward)$coefficients)
##              Estimate  Std. Error   t value     Pr(>|t|)
## (Intercept) 319.14958 138.7205506  2.300665 2.246826e-02
## x1           30.32355   1.4325139 21.168064 2.022762e-52
## x3           11.36879   0.7852374 14.478163 9.743120e-33
## x6           14.06194   1.2350110 11.386083 2.337435e-23
## x2           21.73477   2.8410956  7.650136 8.996289e-13
# 2. 向后消除
model_backward <- step(model_full, 
                       direction = "backward", 
                       trace = 0)
cat("\n========== 向后消除结果 ==========\n")
## 
## ========== 向后消除结果 ==========
print(summary(model_backward)$coefficients)
##              Estimate  Std. Error   t value     Pr(>|t|)
## (Intercept) 319.14958 138.7205506  2.300665 2.246826e-02
## x1           30.32355   1.4325139 21.168064 2.022762e-52
## x2           21.73477   2.8410956  7.650136 8.996289e-13
## x3           11.36879   0.7852374 14.478163 9.743120e-33
## x6           14.06194   1.2350110 11.386083 2.337435e-23
# 3. 逐步选择
model_stepwise <- step(model_full, 
                       direction = "both", 
                       trace = 0)
cat("\n========== 逐步选择结果 ==========\n")
## 
## ========== 逐步选择结果 ==========
print(summary(model_stepwise)$coefficients)
##              Estimate  Std. Error   t value     Pr(>|t|)
## (Intercept) 319.14958 138.7205506  2.300665 2.246826e-02
## x1           30.32355   1.4325139 21.168064 2.022762e-52
## x2           21.73477   2.8410956  7.650136 8.996289e-13
## x3           11.36879   0.7852374 14.478163 9.743120e-33
## x6           14.06194   1.2350110 11.386083 2.337435e-23
# 4. 最佳子集选择
best_subset <- leaps::regsubsets(y ~ x1 + x2 + x3 + x4 + x5 + x6, 
                                  data = data_var, 
                                  nbest = 1,      # 每个变量数选1个最佳模型
                                  nvmax = 6)      # 最多6个变量
best_summary <- summary(best_subset)

cat("\n========== 最佳子集选择结果 ==========\n")
## 
## ========== 最佳子集选择结果 ==========
cat("各变量数的最优模型：\n")
## 各变量数的最优模型：
for (i in 1:6) {
  vars <- names(which(best_summary$which[i, -1]))
  cat(sprintf("%d个变量: %s (调整R²=%.4f, BIC=%.2f)\n", 
              i, paste(vars, collapse = "+"), 
              best_summary$adjr2[i], best_summary$bic[i]))
}
## 1个变量: x1 (调整R²=0.4445, BIC=-107.98)
## 2个变量: x1+x3 (调整R²=0.6439, BIC=-192.65)
## 3个变量: x1+x3+x6 (调整R²=0.7587, BIC=-266.19)
## 4个变量: x1+x2+x3+x6 (调整R²=0.8135, BIC=-313.39)
## 5个变量: x1+x2+x3+x5+x6 (调整R²=0.8125, BIC=-308.10)
## 6个变量: x1+x2+x3+x4+x5+x6 (调整R²=0.8115, BIC=-302.81)
# 可视化最佳子集选择结果
par(mfrow = c(2, 2))
plot(best_subset, scale = "adjr2", main = "按调整R²选择")
plot(best_subset, scale = "bic", main = "按BIC选择")
par(mfrow = c(1, 1))

# 比较各模型的AIC和BIC
cat("\n========== 模型比较 ==========\n")
## 
## ========== 模型比较 ==========
cat(sprintf("全模型: AIC = %.2f, BIC = %.2f\n", AIC(model_full), BIC(model_full)))
## 全模型: AIC = 2704.37, BIC = 2730.75
cat(sprintf("向前选择: AIC = %.2f, BIC = %.2f\n", AIC(model_forward), BIC(model_forward)))
## 向前选择: AIC = 2700.38, BIC = 2720.17
cat(sprintf("向后消除: AIC = %.2f, BIC = %.2f\n", AIC(model_backward), BIC(model_backward)))
## 向后消除: AIC = 2700.38, BIC = 2720.17
cat(sprintf("逐步选择: AIC = %.2f, BIC = %.2f\n", AIC(model_stepwise), BIC(model_stepwise)))
## 逐步选择: AIC = 2700.38, BIC = 2720.17

1.10 信息准则

意义与使用场景

核心意义：信息准则用于在模型拟合优度与复杂度之间取得平衡，帮助选择最优模型。

举例：比较三个住院费用预测模型，选择最优模型

为什么这种数据适合用信息准则？

首先，模型比较面临一个核心矛盾：增加变量总能提高拟合优度（R²单调递增），但可能导致过拟合，降低泛化能力。其次，医疗费用预测可能涉及多个候选模型：仅含人口学特征的简单模型、加入临床指标的复杂模型、加入交互项的更复杂模型。信息准则通过惩罚项平衡拟合优度与模型复杂度，帮助选择在预测和简洁之间取得平衡的最优模型。

研究目的是什么？

本研究有三个层次的目的：1. 模型比较：客观比较不同复杂度模型的优劣，避免主观判断；2. 防止过拟合：通过惩罚项抑制过度复杂的模型，提高模型泛化能力；3. 指导变量选择：结合逐步回归等方法，自动筛选最优变量组合。

可能得到什么样的结果？

假设三个候选模型的比较结果：模型A（3个变量）AIC=2520，模型B（5个变量）AIC=2485，模型C（7个变量）AIC=2490。

  1. 最优模型选择：模型B的AIC值最小（2485），为最优模型。
  2. 复杂度惩罚：模型C虽然变量更多，但AIC反而比模型B大5，说明增加的2个变量带来的拟合改善不足以抵消复杂度惩罚。
  3. BIC比较：若使用BIC准则，模型A可能更优（BIC惩罚更重），适合以解释为主要目的的研究。
  4. 模型差异判断：AIC差值>10表示模型差异显著，模型B明显优于模型A（差值35）。

需要注意什么？

AIC偏向预测，倾向于选择较大模型；BIC偏向解释，倾向于选择较小模型。信息准则仅适用于同一样本、同一因变量的模型比较，不能跨数据集比较。AIC/BIC差值小于2时，模型差异不显著，可结合专业知识和简洁原则选择。

数学基础

信息准则：

用于模型比较和选择，平衡模型拟合优度与复杂度。

AIC（Akaike Information Criterion）： \[AIC = -2\ln(L) + 2k\]

对于线性回归： \[AIC = n\ln(RSS/n) + 2(p+1) + n + n\ln(2\pi)\]

BIC（Bayesian Information Criterion）： \[BIC = -2\ln(L) + k\ln(n)\]

对于线性回归： \[BIC = n\ln(RSS/n) + (p+1)\ln(n) + n + n\ln(2\pi)\]

参数说明： - \(L\)：模型的极大似然值 - \(k\)：参数个数（包括截距） - \(n\)：样本量 - \(p\)：自变量个数

HQIC（Hannan-Quinn Information Criterion）： \[HQIC = -2\ln(L) + 2k\ln(\ln(n))\]

准则比较：

准则 惩罚项 倾向 适用场景
AIC \(2k\) 较大模型 预测为目的
BIC \(k\ln(n)\) 较小模型 解释为目的、大样本
HQIC \(2k\ln(\ln(n))\) 介于AIC和BIC之间 中等样本

选择原则：选择信息准则值最小的模型。

代码实现

# 使用之前的医疗费用数据
# 比较不同模型的AIC、BIC

# 候选模型
model_1 <- lm(medical_cost ~ age, data = medical_data)
model_2 <- lm(medical_cost ~ age + bmi, data = medical_data)
model_3 <- lm(medical_cost ~ age + bmi + los, data = medical_data)
model_4 <- lm(medical_cost ~ age * bmi + los, data = medical_data)  # 含交互项

# 计算各模型的信息准则
compare_df <- data.frame(
  Model = c("age", "age+bmi", "age+bmi+los", "age*bmi+los"),
  AIC = c(AIC(model_1), AIC(model_2), AIC(model_3), AIC(model_4)),
  BIC = c(BIC(model_1), BIC(model_2), BIC(model_3), BIC(model_4)),
  Adj_R2 = c(summary(model_1)$adj.r.squared,
             summary(model_2)$adj.r.squared,
             summary(model_3)$adj.r.squared,
             summary(model_4)$adj.r.squared)
)

cat("========== 模型比较 ==========\n")
## ========== 模型比较 ==========
print(compare_df)
##         Model      AIC      BIC    Adj_R2
## 1         age 3665.081 3674.976 0.0318859
## 2     age+bmi 3636.672 3649.865 0.1642201
## 3 age+bmi+los 3509.785 3526.276 0.5590117
## 4 age*bmi+los 3510.523 3530.313 0.5595367
# 找出最优模型
best_aic_model <- compare_df$Model[which.min(compare_df$AIC)]
best_bic_model <- compare_df$Model[which.min(compare_df$BIC)]
best_adjr2_model <- compare_df$Model[which.max(compare_df$Adj_R2)]

cat(sprintf("\n按AIC最优: %s\n", best_aic_model))
## 
## 按AIC最优: age+bmi+los
cat(sprintf("按BIC最优: %s\n", best_bic_model))
## 按BIC最优: age+bmi+los
cat(sprintf("按调整R²最优: %s\n", best_adjr2_model))
## 按调整R²最优: age*bmi+los
# 使用AICc（小样本校正AIC）
# AICc = AIC + 2k(k+1)/(n-k-1)
n <- nrow(medical_data)

calc_aicc <- function(model) {
  k <- length(coef(model))
  aic <- AIC(model)
  aicc <- aic + 2 * k * (k + 1) / (n - k - 1)
  return(aicc)
}

compare_df$AICc <- c(calc_aicc(model_1), calc_aicc(model_2), 
                     calc_aicc(model_3), calc_aicc(model_4))

cat("\n========== 含AICc的模型比较 ==========\n")
## 
## ========== 含AICc的模型比较 ==========
print(compare_df)
##         Model      AIC      BIC    Adj_R2     AICc
## 1         age 3665.081 3674.976 0.0318859 3665.142
## 2     age+bmi 3636.672 3649.865 0.1642201 3636.794
## 3 age+bmi+los 3509.785 3526.276 0.5590117 3509.990
## 4 age*bmi+los 3510.523 3530.313 0.5595367 3510.833
# 可视化
compare_long <- compare_df %>%
  tidyr::pivot_longer(cols = c(AIC, BIC, AICc), 
                      names_to = "Criterion", values_to = "Value")

ggplot2::ggplot(compare_long, ggplot2::aes(x = Model, y = Value, fill = Criterion)) +
  ggplot2::geom_bar(stat = "identity", position = "dodge") +
  ggplot2::labs(title = "不同模型的信息准则比较", x = "模型", y = "信息准则值") +
  ggplot2::theme_minimal() +
  ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))

1.11 稳健标准误

意义与使用场景

核心意义：当经典假设（如同方差性）不满足时，稳健标准误可以提供有效的统计推断。

适用场景： - 概括：当数据存在异方差或聚类结构时，使用稳健标准误校正标准误估计 - 医学举例：多中心临床试验中，同一中心的患者可能相关，需用聚类稳健标准误 - 其他领域：面板数据分析；教育研究中同一学校学生的数据

核心优势：即使模型假设不完全满足，仍能得到可靠的置信区间和假设检验结果

数学基础

稳健标准误（Robust Standard Errors）：

当经典假设（如同方差性）不满足时，使用稳健标准误可以获得有效的统计推断。

异方差稳健标准误（HC标准误）：

White/Huber-White标准误： \[Var(\hat{\boldsymbol{\beta}})_{robust} = (\mathbf{X}'\mathbf{X})^{-1}\mathbf{X}'\hat{\Omega}\mathbf{X}(\mathbf{X}'\mathbf{X})^{-1}\]

其中\(\hat{\Omega}\)是对角矩阵，对角元素为\(\hat{\omega}_i = e_i^2\)。

HC类型：

类型 公式 特点
HC0 \(\hat{\omega}_i = e_i^2\) 原始White估计
HC1 \(\hat{\omega}_i = \frac{n}{n-p-1}e_i^2\) 小样本校正
HC2 \(\hat{\omega}_i = \frac{e_i^2}{1-h_{ii}}\) 考虑杠杆值
HC3 \(\hat{\omega}_i = \frac{e_i^2}{(1-h_{ii})^2}\) 更保守，推荐使用

聚类稳健标准误：

当观测值在组内相关时使用。

\[Var(\hat{\boldsymbol{\beta}})_{cluster} = (\mathbf{X}'\mathbf{X})^{-1}\left(\sum_{g=1}^{G}\mathbf{X}_g'\mathbf{e}_g\mathbf{e}_g'\mathbf{X}_g\right)(\mathbf{X}'\mathbf{X})^{-1}\]

参数说明： - \(G\)：聚类数量 - \(\mathbf{X}_g\)、\(\mathbf{e}_g\)：第\(g\)组的设计矩阵和残差向量

代码实现

# 模拟存在异方差的数据
set.seed(111)
n_het <- 200
x_het <- rnorm(n_het, 50, 15)
# 误差方差随x增大而增大
epsilon_het <- rnorm(n_het, 0, x_het / 10)
y_het <- 100 + 2 * x_het + epsilon_het

data_het <- data.frame(x = x_het, y = y_het)

# OLS回归
model_het <- lm(y ~ x, data = data_het)

# 普通标准误
summary_normal <- summary(model_het)

# 异方差稳健标准误（使用sandwich包）
# HC0
vcov_hc0 <- sandwich::vcovHC(model_het, type = "HC0")
# HC1（Stata默认）
vcov_hc1 <- sandwich::vcovHC(model_het, type = "HC1")
# HC2
vcov_hc2 <- sandwich::vcovHC(model_het, type = "HC2")
# HC3（推荐）
vcov_hc3 <- sandwich::vcovHC(model_het, type = "HC3")

# 使用lmtest包输出稳健标准误结果
cat("========== 普通标准误 ==========\n")
## ========== 普通标准误 ==========
print(lmtest::coeftest(model_het))
## 
## t test of coefficients:
## 
##              Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 100.95612    1.12573  89.681 < 2.2e-16 ***
## x             1.98626    0.02158  92.041 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
cat("\n========== HC0稳健标准误 ==========\n")
## 
## ========== HC0稳健标准误 ==========
print(lmtest::coeftest(model_het, vcov = vcov_hc0))
## 
## t test of coefficients:
## 
##               Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 100.956117   0.887777  113.72 < 2.2e-16 ***
## x             1.986265   0.019948   99.57 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
cat("\n========== HC1稳健标准误 ==========\n")
## 
## ========== HC1稳健标准误 ==========
print(lmtest::coeftest(model_het, vcov = vcov_hc1))
## 
## t test of coefficients:
## 
##               Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 100.956117   0.892249 113.148 < 2.2e-16 ***
## x             1.986265   0.020049  99.071 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
cat("\n========== HC3稳健标准误（推荐） ==========\n")
## 
## ========== HC3稳健标准误（推荐） ==========
print(lmtest::coeftest(model_het, vcov = vcov_hc3))
## 
## t test of coefficients:
## 
##               Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 100.956117   0.905385  111.51 < 2.2e-16 ***
## x             1.986265   0.020349   97.61 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
# 比较标准误
se_compare <- data.frame(
  Type = c("普通", "HC0", "HC1", "HC2", "HC3"),
  SE_intercept = c(
    sqrt(diag(vcov(model_het)))[1],
    sqrt(diag(vcov_hc0))[1],
    sqrt(diag(vcov_hc1))[1],
    sqrt(diag(vcov_hc2))[1],
    sqrt(diag(vcov_hc3))[1]
  ),
  SE_x = c(
    sqrt(diag(vcov(model_het)))[2],
    sqrt(diag(vcov_hc0))[2],
    sqrt(diag(vcov_hc1))[2],
    sqrt(diag(vcov_hc2))[2],
    sqrt(diag(vcov_hc3))[2]
  )
)

cat("\n========== 标准误比较 ==========\n")
## 
## ========== 标准误比较 ==========
print(se_compare)
##   Type SE_intercept       SE_x
## 1 普通    1.1257267 0.02158012
## 2  HC0    0.8877767 0.01994843
## 3  HC1    0.8922491 0.02004892
## 4  HC2    0.8965045 0.02014697
## 5  HC3    0.9053845 0.02034890
# 聚类稳健标准误示例
# 模拟聚类数据
set.seed(222)
n_clusters <- 20
n_per_cluster <- 10
n_cluster <- n_clusters * n_per_cluster

cluster_id <- rep(1:n_clusters, each = n_per_cluster)
x_cluster <- rnorm(n_cluster, 50, 10)
# 组内相关的误差
cluster_effect <- rnorm(n_clusters, 0, 5)[cluster_id]
epsilon_cluster <- rnorm(n_cluster, 0, 3) + cluster_effect
y_cluster <- 100 + 2 * x_cluster + epsilon_cluster

data_cluster <- data.frame(
  cluster = factor(cluster_id),
  x = x_cluster,
  y = y_cluster
)

model_cluster <- lm(y ~ x, data = data_cluster)

# 聚类稳健标准误
vcov_cl <- sandwich::vcovCL(model_cluster, cluster = data_cluster$cluster)

cat("\n========== 聚类稳健标准误 ==========\n")
## 
## ========== 聚类稳健标准误 ==========
cat("普通标准误：\n")
## 普通标准误：
print(lmtest::coeftest(model_cluster))
## 
## t test of coefficients:
## 
##              Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 98.437958   2.182343  45.106 < 2.2e-16 ***
## x            2.048868   0.042776  47.898 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
cat("\n聚类稳健标准误：\n")
## 
## 聚类稳健标准误：
print(lmtest::coeftest(model_cluster, vcov = vcov_cl))
## 
## t test of coefficients:
## 
##              Estimate Std. Error t value  Pr(>|t|)    
## (Intercept) 98.437958   3.719596  26.465 < 2.2e-16 ***
## x            2.048868   0.059659  34.343 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

1.12 加权最小二乘（WLS）

意义与使用场景

核心意义：加权最小二乘通过给予不同观测不同的权重，有效处理异方差问题，提高估计效率。

适用场景： - 概括：当数据存在异方差（不同观测的误差方差不同）时使用 - 医学举例：不同医院测量精度不同，精度高的医院给予更大权重 - 其他领域：调查数据中根据抽样权重加权；实验数据中根据测量精度加权

核心思想：精度高的数据贡献更大权重，精度低的数据贡献较小权重

数学基础

加权最小二乘（Weighted Least Squares, WLS）：

当存在异方差时，通过给予不同观测不同的权重来改进估计效率。

WLS估计量： \[\hat{\boldsymbol{\beta}}_{WLS} = (\mathbf{X}'\mathbf{W}\mathbf{X})^{-1}\mathbf{X}'\mathbf{W}\mathbf{Y}\]

参数说明： - \(\mathbf{W}\)：权重矩阵，为对角矩阵 - \(w_i\)：第\(i\)个观测的权重

权重选择原则： - 方差大的观测给予较小的权重 - 方差小的观测给予较大的权重 - 通常取 \(w_i = 1/\sigma_i^2\)

异方差形式已知时：

若\(Var(\varepsilon_i) = \sigma_i^2 = \sigma^2 \cdot v_i\)，则取\(w_i = 1/v_i\)。

异方差形式未知时：

  1. 先用OLS回归
  2. 估计异方差形式：\(\ln(e_i^2) = \gamma_0 + \gamma_1 X_i + \cdots\)
  3. 计算权重：\(w_i = 1/\exp(\hat{\gamma}_0 + \hat{\gamma}_1 X_i + \cdots)\)
  4. 进行WLS回归

代码实现

# 使用之前的异方差数据
# 异方差形式：误差方差与x成正比

# 方法1：已知异方差形式，直接使用权重
# 假设我们知道 Var(epsilon) 正比于 x
weights <- 1 / data_het$x

model_wls <- lm(y ~ x, data = data_het, weights = weights)
summary(model_wls)
## 
## Call:
## lm(formula = y ~ x, data = data_het, weights = weights)
## 
## Weighted Residuals:
##      Min       1Q   Median       3Q      Max 
## -1.89403 -0.41665  0.03369  0.41922  2.08344 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 1.001e+02  2.405e-01   416.1   <2e-16 ***
## x           2.004e+00  8.138e-03   246.3   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.6535 on 198 degrees of freedom
## Multiple R-squared:  0.9967, Adjusted R-squared:  0.9967 
## F-statistic: 6.064e+04 on 1 and 198 DF,  p-value: < 2.2e-16
# 方法2：估计异方差形式后确定权重
# 第一步：OLS回归
model_ols_het <- lm(y ~ x, data = data_het)

# 第二步：估计异方差形式
data_het$resid_sq <- residuals(model_ols_het)^2
model_var <- lm(log(resid_sq) ~ x, data = data_het)

# 第三步：计算权重
data_het$estimated_var <- exp(fitted(model_var))
data_het$weights_est <- 1 / data_het$estimated_var

# 第四步：WLS回归
model_wls_est <- lm(y ~ x, data = data_het, weights = weights_est)

# 比较OLS和WLS结果
cat("========== OLS结果 ==========\n")
## ========== OLS结果 ==========
print(summary(model_ols_het)$coefficients)
##               Estimate Std. Error  t value      Pr(>|t|)
## (Intercept) 100.956117 1.12572674 89.68084 2.805055e-162
## x             1.986265 0.02158012 92.04145 1.844286e-164
cat("\n========== WLS结果（已知异方差形式） ==========\n")
## 
## ========== WLS结果（已知异方差形式） ==========
print(summary(model_wls)$coefficients)
##               Estimate  Std. Error  t value      Pr(>|t|)
## (Intercept) 100.067763 0.240462691 416.1467 2.905524e-293
## x             2.004112 0.008138273 246.2576 3.078254e-248
cat("\n========== WLS结果（估计异方差形式） ==========\n")
## 
## ========== WLS结果（估计异方差形式） ==========
print(summary(model_wls_est)$coefficients)
##               Estimate Std. Error  t value      Pr(>|t|)
## (Intercept) 100.384623 0.69756233 143.9077 2.601207e-202
## x             1.998964 0.01648663 121.2476 9.622914e-188
# 可视化比较
compare_df <- data.frame(
  Method = c("OLS", "WLS(已知)", "WLS(估计)"),
  Intercept = c(coef(model_ols_het)[1], coef(model_wls)[1], coef(model_wls_est)[1]),
  Intercept_SE = c(summary(model_ols_het)$coefficients[1, 2],
                   summary(model_wls)$coefficients[1, 2],
                   summary(model_wls_est)$coefficients[1, 2]),
  Slope = c(coef(model_ols_het)[2], coef(model_wls)[2], coef(model_wls_est)[2]),
  Slope_SE = c(summary(model_ols_het)$coefficients[2, 2],
               summary(model_wls)$coefficients[2, 2],
               summary(model_wls_est)$coefficients[2, 2])
)

cat("\n========== 方法比较 ==========\n")
## 
## ========== 方法比较 ==========
print(compare_df)
##      Method Intercept Intercept_SE    Slope    Slope_SE
## 1       OLS  100.9561    1.1257267 1.986265 0.021580116
## 2 WLS(已知)  100.0678    0.2404627 2.004112 0.008138273
## 3 WLS(估计)  100.3846    0.6975623 1.998964 0.016486630
# 残差诊断比较
par(mfrow = c(2, 2))
plot(model_ols_het, which = 1, main = "OLS: 残差 vs 拟合值")
plot(model_wls, which = 1, main = "WLS: 残差 vs 拟合值")
par(mfrow = c(1, 1))

1.13 岭回归与LASSO

意义与使用场景

核心意义：正则化方法通过添加惩罚项解决多重共线性问题，防止过拟合，LASSO还能实现变量选择。

适用场景： - 概括：当自变量存在多重共线性，或变量数接近/超过样本量时使用 - 医学举例：基因表达数据分析中，从成千上万个基因中筛选出与疾病相关的关键基因 - 其他领域：高维数据分析；金融风控中的特征选择；文本挖掘中的词向量降维

方法选择：岭回归适合处理共线性，LASSO适合变量选择，弹性网络结合两者优势

数学基础

正则化方法：

通过在损失函数中添加惩罚项，解决多重共线性问题和进行变量选择。

岭回归（Ridge Regression）：

\[\hat{\boldsymbol{\beta}}_{ridge} = \arg\min_{\boldsymbol{\beta}} \left\{ \sum_{i=1}^{n}(Y_i - \mathbf{x}_i'\boldsymbol{\beta})^2 + \lambda \sum_{j=1}^{p}\beta_j^2 \right\}\]

解析解： \[\hat{\boldsymbol{\beta}}_{ridge} = (\mathbf{X}'\mathbf{X} + \lambda\mathbf{I})^{-1}\mathbf{X}'\mathbf{Y}\]

LASSO（Least Absolute Shrinkage and Selection Operator）：

\[\hat{\boldsymbol{\beta}}_{lasso} = \arg\min_{\boldsymbol{\beta}} \left\{ \sum_{i=1}^{n}(Y_i - \mathbf{x}_i'\boldsymbol{\beta})^2 + \lambda \sum_{j=1}^{p}|\beta_j| \right\}\]

参数说明： - \(\lambda \geq 0\)：惩罚参数，控制正则化强度 - \(\lambda = 0\)：退化为OLS - \(\lambda \to \infty\)：系数趋向于0

岭回归 vs LASSO：

特性 岭回归 LASSO
惩罚项 \(L_2\)范数：\(\sum\beta_j^2\) \(L_1\)范数：\(\sum|\beta_j|\)
系数收缩 收缩至接近0但不为0 可收缩至精确为0
变量选择 不能 能
解析解 有 无（需迭代求解）
适用场景 多重共线性 变量选择、稀疏模型

弹性网络（Elastic Net）：

结合岭回归和LASSO： \[\hat{\boldsymbol{\beta}}_{enet} = \arg\min_{\boldsymbol{\beta}} \left\{ \sum_{i=1}^{n}(Y_i - \mathbf{x}_i'\boldsymbol{\beta})^2 + \lambda_1 \sum_{j=1}^{p}|\beta_j| + \lambda_2 \sum_{j=1}^{p}\beta_j^2 \right\}\]

代码实现

# 使用glmnet包进行岭回归和LASSO
# 准备数据矩阵
x_matrix <- as.matrix(medical_data[, c("age", "bmi", "los")])
y_vector <- medical_data$medical_cost

# 岭回归（alpha = 0）
ridge_model <- glmnet::glmnet(x_matrix, y_vector, alpha = 0)

# LASSO（alpha = 1）
lasso_model <- glmnet::glmnet(x_matrix, y_vector, alpha = 1)

# 弹性网络（alpha = 0.5）
enet_model <- glmnet::glmnet(x_matrix, y_vector, alpha = 0.5)

# 查看不同lambda下的系数
cat("========== 岭回归系数路径 ==========\n")
## ========== 岭回归系数路径 ==========
print(coef(ridge_model)[, 1:5])  # 前5个lambda值
## 4 x 5 sparse Matrix of class "dgCMatrix"
##                       s0           s1           s2           s3           s4
## (Intercept) 1.229883e+04 1.227890e+04 1.227696e+04 1.227484e+04 1.227250e+04
## age         3.969296e-35 7.105282e-02 7.796826e-02 8.555548e-02 9.387946e-02
## bmi         2.137590e-34 3.826195e-01 4.198567e-01 4.607108e-01 5.055315e-01
## los         5.024985e-34 8.993634e-01 9.868820e-01 1.082899e+00 1.188236e+00
cat("\n========== LASSO系数路径 ==========\n")
## 
## ========== LASSO系数路径 ==========
print(coef(lasso_model)[, 1:5])
## 4 x 5 sparse Matrix of class "dgCMatrix"
##                   s0          s1          s2        s3         s4
## (Intercept) 12298.83 11984.60443 11698.29834 11437.427 11199.7306
## age             .        .           .           .         .     
## bmi             .        .           .           .         .     
## los             .       44.19417    84.46226   121.153   154.5843
# 使用交叉验证选择最优lambda
set.seed(333)

# 岭回归交叉验证
cv_ridge <- glmnet::cv.glmnet(x_matrix, y_vector, alpha = 0)

# LASSO交叉验证
cv_lasso <- glmnet::cv.glmnet(x_matrix, y_vector, alpha = 1)

# 弹性网络交叉验证
cv_enet <- glmnet::cv.glmnet(x_matrix, y_vector, alpha = 0.5)

# 最优lambda
cat("\n========== 最优lambda ==========\n")
## 
## ========== 最优lambda ==========
cat(sprintf("岭回归最优lambda: %.2f\n", cv_ridge$lambda.min))
## 岭回归最优lambda: 140.34
cat(sprintf("LASSO最优lambda: %.4f\n", cv_lasso$lambda.min))
## LASSO最优lambda: 6.9846
cat(sprintf("弹性网络最优lambda: %.4f\n", cv_enet$lambda.min))
## 弹性网络最优lambda: 9.6284
# 最优模型系数
cat("\n========== 最优模型系数 ==========\n")
## 
## ========== 最优模型系数 ==========
cat("岭回归：\n")
## 岭回归：
print(coef(cv_ridge, s = "lambda.min"))
## 4 x 1 sparse Matrix of class "dgCMatrix"
##             lambda.min
## (Intercept) 1130.98077
## age           41.41425
## bmi          216.51547
## los          484.77265
cat("\nLASSO：\n")
## 
## LASSO：
print(coef(cv_lasso, s = "lambda.min"))
## 4 x 1 sparse Matrix of class "dgCMatrix"
##             lambda.min
## (Intercept)  503.15025
## age           43.57087
## bmi          228.89651
## los          512.60998
cat("\n弹性网络：\n")
## 
## 弹性网络：
print(coef(cv_enet, s = "lambda.min"))
## 4 x 1 sparse Matrix of class "dgCMatrix"
##             lambda.min
## (Intercept)  497.89086
## age           43.67149
## bmi          228.96603
## los          512.32706
# OLS系数比较
cat("\nOLS系数：\n")
## 
## OLS系数：
print(coef(model_ols))
## (Intercept)         age         bmi         los 
##   401.12895    44.22123   230.78488   515.25594
# 可视化交叉验证结果
par(mfrow = c(1, 3))
plot(cv_ridge, main = "岭回归交叉验证")
plot(cv_lasso, main = "LASSO交叉验证")
plot(cv_enet, main = "弹性网络交叉验证")

par(mfrow = c(1, 1))

# 可视化系数路径
par(mfrow = c(1, 3))
plot(ridge_model, xvar = "lambda", main = "岭回归系数路径")
plot(lasso_model, xvar = "lambda", main = "LASSO系数路径")
plot(enet_model, xvar = "lambda", main = "弹性网络系数路径")

par(mfrow = c(1, 1))

1.14 分段回归与样条回归

意义与使用场景

核心意义：分段回归和样条回归用于处理自变量与因变量之间的非线性关系，提供更灵活的建模方式。

适用场景： - 概括：当变量间关系呈现非线性（如阈值效应、拐点）时使用 - 医学举例：药物剂量-效应关系中存在阈值效应；年龄与疾病风险呈U型关系 - 其他领域：经济学中的恩格尔曲线；环境科学中污染物浓度与生态效应的关系

方法选择：分段回归适合已知断点的情况，样条回归适合未知断点或需要光滑曲线的情况

数学基础

分段回归（Piecewise Regression）：

在自变量的不同区间使用不同的线性函数拟合。

模型形式（以一个断点为例）： \[Y_i = \beta_0 + \beta_1 X_i + \beta_2 (X_i - c)_+ + \varepsilon_i\]

其中 \((X_i - c)_+ = \max(0, X_i - c)\)，\(c\)为断点。

样条回归（Spline Regression）：

使用分段多项式函数，且在断点处光滑连接。

B样条（B-spline）：

使用基函数的线性组合： \[f(X) = \sum_{j=1}^{k} \beta_j B_j(X)\]

参数说明： - \(B_j(X)\)：第\(j\)个B样条基函数 - \(k\)：基函数个数，由节点数和多项式阶数决定

自然样条（Natural Spline）：

在边界处强制线性，减少边界效应。

光滑样条（Smoothing Spline）：

\[\hat{f} = \arg\min_f \left\{ \sum_{i=1}^{n}(Y_i - f(X_i))^2 + \lambda \int [f''(x)]^2 dx \right\}\]

参数说明： - \(\lambda\)：光滑参数，控制拟合程度与光滑程度的平衡 - \(\int [f''(x)]^2 dx\)：曲率的积分，衡量函数的光滑程度

有效自由度： \[df_{\lambda} = trace(\mathbf{S}_\lambda)\]

其中\(\mathbf{S}_\lambda\)为光滑矩阵。

代码实现

# 模拟非线性关系数据
set.seed(444)
n_spline <- 150
x_spline <- runif(n_spline, 0, 10)
# 真实函数：分段线性
y_true <- ifelse(x_spline < 5, 10 + 2 * x_spline, 20 + 1 * (x_spline - 5))
y_spline <- y_true + rnorm(n_spline, 0, 2)

data_spline <- data.frame(x = x_spline, y = y_spline)

# 1. 线性回归（基准）
model_linear <- lm(y ~ x, data = data_spline)

# 2. 分段回归（已知断点c=5）
data_spline$x_minus_c <- pmax(data_spline$x - 5, 0)
model_piecewise <- lm(y ~ x + x_minus_c, data = data_spline)
summary(model_piecewise)
## 
## Call:
## lm(formula = y ~ x + x_minus_c, data = data_spline)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -5.4531 -1.2837 -0.2629  1.1029  5.9187 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  10.9130     0.4452  24.510  < 2e-16 ***
## x             1.7788     0.1337  13.304  < 2e-16 ***
## x_minus_c    -0.7688     0.2383  -3.226  0.00155 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 2.018 on 147 degrees of freedom
## Multiple R-squared:  0.7927, Adjusted R-squared:  0.7898 
## F-statistic:   281 on 2 and 147 DF,  p-value: < 2.2e-16
# 3. 多项式回归
model_poly <- lm(y ~ poly(x, degree = 3), data = data_spline)

# 4. B样条回归
model_bspline <- lm(y ~ splines::bs(x, knots = c(3, 5, 7)), data = data_spline)

# 5. 自然样条回归
model_nspline <- lm(y ~ splines::ns(x, knots = c(3, 5, 7)), data = data_spline)

# 6. 光滑样条回归
smooth_spline <- smooth.spline(data_spline$x, data_spline$y, df = 6)

# 预测新数据
new_x <- seq(0, 10, length.out = 100)
new_data <- data.frame(x = new_x, x_minus_c = pmax(new_x - 5, 0))

pred_linear <- predict(model_linear, newdata = new_data)
pred_piecewise <- predict(model_piecewise, newdata = new_data)
pred_poly <- predict(model_poly, newdata = new_data)
pred_bspline <- predict(model_bspline, newdata = new_data)
pred_nspline <- predict(model_nspline, newdata = new_data)
pred_smooth <- predict(smooth_spline, new_x)$y

# 可视化比较
plot_df <- data.frame(
  x = rep(new_x, 6),
  y = c(pred_linear, pred_piecewise, pred_poly, pred_bspline, pred_nspline, pred_smooth),
  Method = rep(c("线性回归", "分段回归", "多项式回归", "B样条", "自然样条", "光滑样条"), each = 100)
)

ggplot2::ggplot() +
  ggplot2::geom_point(data = data_spline, ggplot2::aes(x = x, y = y), alpha = 0.5) +
  ggplot2::geom_line(data = plot_df, ggplot2::aes(x = x, y = y, color = Method), linewidth = 1) +
  ggplot2::labs(title = "不同回归方法的拟合比较", x = "x", y = "y") +
  ggplot2::theme_minimal() +
  ggplot2::theme(legend.position = "bottom")

# 模型比较
cat("========== 模型比较 ==========\n")
## ========== 模型比较 ==========
cat(sprintf("线性回归: R² = %.4f, AIC = %.2f\n", 
            summary(model_linear)$r.squared, AIC(model_linear)))
## 线性回归: R² = 0.7780, AIC = 649.50
cat(sprintf("分段回归: R² = %.4f, AIC = %.2f\n", 
            summary(model_piecewise)$r.squared, AIC(model_piecewise)))
## 分段回归: R² = 0.7927, AIC = 641.24
cat(sprintf("多项式回归: R² = %.4f, AIC = %.2f\n", 
            summary(model_poly)$r.squared, AIC(model_poly)))
## 多项式回归: R² = 0.7912, AIC = 644.30
cat(sprintf("B样条: R² = %.4f, AIC = %.2f\n", 
            summary(model_bspline)$r.squared, AIC(model_bspline)))
## B样条: R² = 0.7965, AIC = 646.46
cat(sprintf("自然样条: R² = %.4f, AIC = %.2f\n", 
            summary(model_nspline)$r.squared, AIC(model_nspline)))
## 自然样条: R² = 0.7938, AIC = 644.44

第一章小结

核心知识点总结

主题 核心内容 关键函数
OLS估计 最小化残差平方和 lm()
系数解释 控制其他变量时的边际效应 coef(), tidy()
R² 模型解释变异的比例 summary()$r.squared
ANOVA 变异分解与整体检验 anova()
残差诊断 正态性、异方差性检验 plot(), bptest()
影响点诊断 Cook距离、杠杆值 cooks.distance(), hatvalues()
多重共线性 VIF、条件数 car::vif()
变量选择 逐步回归、最佳子集 step(), regsubsets()
稳健标准误 HC0-HC3、聚类稳健 sandwich::vcovHC()
正则化 岭回归、LASSO glmnet::glmnet()
样条回归 B样条、自然样条 splines::bs(), splines::ns()

第二章：广义线性模型

广义线性模型（Generalized Linear Models, GLM）是线性回归的重要扩展，可以处理非正态分布的因变量，如二分类数据、计数数据等。本章将系统讲解GLM的理论框架及其在医学研究中的应用。

2.1 指数族分布

意义与使用场景

核心意义：指数族分布是广义线性模型的理论基础，统一了多种常见分布的数学框架，使得不同类型的因变量可以用统一的方法建模。

举例：研究患者是否患糖尿病（是/否）与年龄、BMI、家族史的关系

为什么这种数据适合用广义线性模型？

因变量”是否患糖尿病”是二分类变量（0=否，1=是），取值只能是0或1，不符合正态分布的连续性假设。如果强行用普通线性回归，预测值可能超出[0,1]区间，且残差不满足正态性和同方差性。此时应选择二项分布作为因变量的分布类型，配合logit链接函数，构建逻辑回归模型。这种”二分类因变量+二项分布假设+logit链接”的组合，正是广义线性模型处理二分类数据的标准方案。

研究目的是什么？

  1. 估计患病风险：计算给定特征下患糖尿病的概率。
  2. 识别危险因素：判断哪些因素显著影响患病风险。
  3. 风险预测：建立预测模型，筛查高危人群。

可能得到什么样的结果？

假设逻辑回归结果为：logit(P) = -5 + 0.05×年龄 + 0.1×BMI + 1.2×家族史

  1. 系数解释：年龄系数0.05表示，在BMI和家族史不变的情况下，年龄每增加1岁，患糖尿病的odds（ odds = P/(1-P) ）增加约5%（OR = e^0.05 ≈ 1.05）。
  2. 家族史效应：有家族史者的患病odds是无家族史者的e^1.2 ≈ 3.32倍。
  3. 预测示例：一位50岁、BMI=28、有家族史的患者，logit(P) = -5 + 0.05×50 + 0.1×28 + 1.2 = 2.5，患病概率P = 1/(1+e^(-2.5)) ≈ 92.4%。

需要注意什么？

二分类数据需要足够的样本量和事件数（通常每组至少10个事件）。如果存在过度离散（方差大于理论值），需要使用准似然或负二项模型。此外，逻辑回归的系数解释是odds ratio而非risk ratio，两者在概率较高时有差异。

数学基础

指数族分布：

广义线性模型要求因变量的分布属于指数族，其概率密度函数可表示为：

\[f(y; \theta, \phi) = \exp\left\{ \frac{y\theta - b(\theta)}{a(\phi)} + c(y, \phi) \right\}\]

参数说明： - \(\theta\)：自然参数（canonical parameter） - \(\phi\)：离散参数（dispersion parameter） - \(b(\theta)\)：累积函数 - \(a(\phi)\)：尺度函数 - \(c(y, \phi)\)：归一化常数

常见指数族分布：

分布 \(\theta\) \(b(\theta)\) \(a(\phi)\) 均值 \(E(Y)\) 方差 \(Var(Y)\)
正态 \(\mu\) \(\theta^2/2\) \(\sigma^2\) \(\mu\) \(\sigma^2\)
二项 \(\log(p/(1-p))\) \(\log(1+e^\theta)\) 1 \(np\) \(np(1-p)\)
泊松 \(\log(\lambda)\) \(e^\theta\) 1 \(\lambda\) \(\lambda\)
Gamma \(-1/\mu\) \(-\log(-\theta)\) \(1/\nu\) \(\mu\) \(\mu^2/\nu\)

均值与方差的关系：

\[E(Y) = \mu = b'(\theta)\] \[Var(Y) = b''(\theta) \cdot a(\phi) = V(\mu) \cdot a(\phi)\]

其中\(V(\mu)\)称为方差函数。

代码实现

# 演示指数族分布的性质

# 1. 正态分布
mu_normal <- 50
sigma <- 10
x_normal <- seq(20, 80, length.out = 100)
y_normal <- dnorm(x_normal, mean = mu_normal, sd = sigma)

# 2. 二项分布（n=10, p=0.3）
n_binom <- 10
p_binom <- 0.3
x_binom <- 0:n_binom
y_binom <- dbinom(x_binom, size = n_binom, prob = p_binom)

# 3. 泊松分布（lambda=5）
lambda_pois <- 5
x_pois <- 0:20
y_pois <- dpois(x_pois, lambda = lambda_pois)

# 4. Gamma分布（shape=2, rate=0.5）
shape_gamma <- 2
rate_gamma <- 0.5
x_gamma <- seq(0.1, 15, length.out = 100)
y_gamma <- dgamma(x_gamma, shape = shape_gamma, rate = rate_gamma)

# 可视化
par(mfrow = c(2, 2))
plot(x_normal, y_normal, type = "l", main = "正态分布 (μ=50, σ=10)", 
     xlab = "x", ylab = "密度", col = "blue", lwd = 2)
plot(x_binom, y_binom, type = "h", main = "二项分布 (n=10, p=0.3)", 
     xlab = "x", ylab = "概率", col = "red", lwd = 2)
plot(x_pois, y_pois, type = "h", main = "泊松分布 (λ=5)", 
     xlab = "x", ylab = "概率", col = "green", lwd = 2)
plot(x_gamma, y_gamma, type = "l", main = "Gamma分布 (shape=2, rate=0.5)", 
     xlab = "x", ylab = "密度", col = "purple", lwd = 2)

par(mfrow = c(1, 1))

# 验证均值-方差关系
cat("========== 均值-方差关系验证 ==========\n")
## ========== 均值-方差关系验证 ==========
cat(sprintf("正态分布: 均值=%.1f, 方差=%.1f\n", mu_normal, sigma^2))
## 正态分布: 均值=50.0, 方差=100.0
cat(sprintf("二项分布: 均值=%.1f, 方差=%.1f (理论: np(1-p)=%.1f)\n", 
            n_binom * p_binom, n_binom * p_binom * (1 - p_binom), 
            n_binom * p_binom * (1 - p_binom)))
## 二项分布: 均值=3.0, 方差=2.1 (理论: np(1-p)=2.1)
cat(sprintf("泊松分布: 均值=%.1f, 方差=%.1f (理论: λ=%.1f)\n", 
            lambda_pois, lambda_pois, lambda_pois))
## 泊松分布: 均值=5.0, 方差=5.0 (理论: λ=5.0)
cat(sprintf("Gamma分布: 均值=%.1f, 方差=%.1f\n", 
            shape_gamma/rate_gamma, shape_gamma/rate_gamma^2))
## Gamma分布: 均值=4.0, 方差=8.0

2.2 链接函数

意义与使用场景

核心意义：链接函数是广义线性模型的核心组件，它将因变量的均值与线性预测器连接起来，使得非线性关系可以用线性模型框架处理。

举例：比较logit和probit链接函数在疾病风险预测中的选择

为什么需要链接函数？

在疾病风险预测中，因变量是患病概率P，取值范围是[0,1]，而线性预测器η = β₀ + β₁X₁ + … 的取值范围是(-∞, +∞)。两者无法直接等价，需要一个”桥梁”函数将概率映射到整个实数轴。logit函数g(P) = log(P/(1-P))将[0,1]映射到(-∞, +∞)，probit函数g(P) = Φ⁻¹(P)利用标准正态分布的逆函数实现同样的映射。选择不同的链接函数，相当于对概率做不同的变换后再建模。

研究目的是什么？

  1. 选择最佳链接函数：比较logit、probit、cloglog等链接函数的拟合效果。
  2. 确保预测合理性：保证预测概率始终在[0,1]区间内。
  3. 便于结果解释：logit链接的结果可直接解释为优势比（OR）。

可能得到什么样的结果？

对于同一数据集，不同链接函数的拟合结果：

  1. 系数差异：logit和probit的系数数值不同（probit系数通常约为logit的0.6倍），但统计显著性一致。
  2. 预测概率：三种链接函数预测的概率在中间区域接近，在极端概率区域有差异。
  3. 选择建议：如果需要解释为OR，选logit；如果假设潜在变量服从正态分布，选probit；如果事件发生概率很低，考虑cloglog。

需要注意什么？

logit和probit在大多数情况下结果相似，选择主要基于解释便利性。cloglog是非对称链接函数，适用于稀有事件。链接函数选择不当可能导致预测概率超出合理范围或拟合效果不佳。

数学基础

链接函数（Link Function）：

连接均值\(\mu\)与线性预测器\(\eta = \mathbf{X}\boldsymbol{\beta}\)的函数。

\[g(\mu) = \eta = \mathbf{X}\boldsymbol{\beta}\]

常见链接函数：

分布 典型链接函数 \(g(\mu)\) \(g^{-1}(\eta)\)
正态 identity \(\mu\) \(\eta\)
二项 logit \(\log(\mu/(1-\mu))\) \(e^\eta/(1+e^\eta)\)
二项 probit \(\Phi^{-1}(\mu)\) \(\Phi(\eta)\)
二项 cloglog \(\log(-\log(1-\mu))\) \(1-\exp(-e^\eta)\)
泊松 log \(\log(\mu)\) \(e^\eta\)
Gamma inverse \(1/\mu\) \(1/\eta\)

典型链接函数（Canonical Link）：

当\(g(\mu) = \theta\)时，即链接函数等于自然参数，称为典型链接函数。使用典型链接函数可以简化估计过程。

链接函数的选择原则：

  1. 理论依据：根据因变量的分布特性选择
  2. 解释便利：logit链接便于解释为优势比
  3. 拟合效果：比较不同链接函数的拟合优度

代码实现

# 演示不同链接函数的性质

# 定义链接函数
logit_link <- function(p) log(p / (1 - p))
logit_inv <- function(eta) exp(eta) / (1 + exp(eta))

probit_link <- function(p) qnorm(p)
probit_inv <- function(eta) pnorm(eta)

cloglog_link <- function(p) log(-log(1 - p))
cloglog_inv <- function(eta) 1 - exp(-exp(eta))

log_link <- function(mu) log(mu)
log_inv <- function(eta) exp(eta)

# 可视化二分类数据的链接函数
p_seq <- seq(0.01, 0.99, length.out = 100)

plot_df <- data.frame(
  p = rep(p_seq, 3),
  eta = c(logit_link(p_seq), probit_link(p_seq), cloglog_link(p_seq)),
  Link = rep(c("logit", "probit", "cloglog"), each = 100)
)

ggplot2::ggplot(plot_df, ggplot2::aes(x = p, y = eta, color = Link)) +
  ggplot2::geom_line(linewidth = 1) +
  ggplot2::labs(title = "二分类数据的链接函数比较", 
                x = "概率 p", y = "线性预测器 η") +
  ggplot2::theme_minimal()

# 比较反函数（从η到p）
eta_seq <- seq(-3, 3, length.out = 100)

inv_df <- data.frame(
  eta = rep(eta_seq, 3),
  p = c(logit_inv(eta_seq), probit_inv(eta_seq), cloglog_inv(eta_seq)),
  Link = rep(c("logit", "probit", "cloglog"), each = 100)
)

ggplot2::ggplot(inv_df, ggplot2::aes(x = eta, y = p, color = Link)) +
  ggplot2::geom_line(linewidth = 1) +
  ggplot2::labs(title = "链接函数的反函数（响应函数）", 
                x = "线性预测器 η", y = "概率 p") +
  ggplot2::theme_minimal()

2.3 逻辑回归（二分类）

意义与使用场景

核心意义：逻辑回归是处理二分类因变量的标准方法，通过logit变换将概率映射到实数域，便于建模和解释。

举例：研究年龄、BMI、家族史对糖尿病发病的影响

为什么这种数据适合用逻辑回归？

首先，因变量”是否患糖尿病”是典型的二分类变量（患病=1，未患病=0），取值只有两种可能。其次，我们需要研究的是”患病概率”与自变量的关系，而不是患病与否的简单预测。逻辑回归通过logit变换将概率（0到1之间）映射到实数域（负无穷到正无穷），使得可以用线性模型建模。这种”二分类因变量+概率建模需求”的场景，正是逻辑回归的典型应用。

研究目的是什么？

本研究有三个层次的目的：1. 识别危险因素：判断哪些因素与糖尿病发病显著相关；2. 量化风险程度：计算优势比（OR），回答”年龄每增加10岁，糖尿病风险增加多少倍”；3. 预测应用：建立风险预测模型，识别高危人群进行早期干预。

可能得到什么样的结果？

假设回归结果为：logit(p) = -5.2 + 0.05×年龄 + 0.12×BMI + 1.3×家族史

  1. 年龄效应：OR=1.05，年龄每增加1岁，糖尿病风险增加5%；增加10岁风险增加63%。
  2. BMI效应：OR=1.13，BMI每增加1个单位，糖尿病风险增加13%。
  3. 家族史效应：OR=3.67，有家族史者糖尿病风险是无家族史者的3.67倍。
  4. 预测应用：一位60岁、BMI=28、有家族史的患者，患病概率约为35%。

需要注意什么？

逻辑回归假设自变量与logit(p)呈线性关系，实际中可能存在非线性关系（如年龄与患病风险可能呈U型）。此外，样本量要求：每个自变量至少需要10个阳性事件。当事件发生率很低时（如罕见病），需要考虑稀疏数据问题。

数学基础

逻辑回归模型：

用于二分类因变量的回归模型，使用logit链接函数。

模型形式： \[\log\left(\frac{p}{1-p}\right) = \beta_0 + \beta_1 X_1 + \cdots + \beta_p X_p\]

等价于： \[p = \frac{\exp(\beta_0 + \beta_1 X_1 + \cdots + \beta_p X_p)}{1 + \exp(\beta_0 + \beta_1 X_1 + \cdots + \beta_p X_p)}\]

参数估计：

使用极大似然估计（Maximum Likelihood Estimation, MLE）。

似然函数： \[L(\boldsymbol{\beta}) = \prod_{i=1}^{n} p_i^{y_i} (1-p_i)^{1-y_i}\]

对数似然函数： \[\ell(\boldsymbol{\beta}) = \sum_{i=1}^{n} \left[ y_i \log(p_i) + (1-y_i)\log(1-p_i) \right]\]

优势比（Odds Ratio, OR）：

\[OR = \frac{p_1/(1-p_1)}{p_0/(1-p_0)} = e^{\beta}\]

参数说明： - \(p\)：事件发生的概率 - \(p/(1-p)\)：优势（odds） - \(OR\)：暴露组与对照组优势之比

OR的解释： - \(OR = 1\)：无关联 - \(OR > 1\)：正向关联（风险因素） - \(OR < 1\)：负向关联（保护因素）

代码实现

# 模拟疾病诊断数据
# 场景：研究年龄、BMI、家族史对糖尿病发病的影响

set.seed(456)
n_glm <- 300

# 生成自变量
age_glm <- round(rnorm(n_glm, mean = 50, sd = 12))
bmi_glm <- round(rnorm(n_glm, mean = 26, sd = 4), 1)
family_history <- rbinom(n_glm, 1, 0.3)  # 家族史（0=无，1=有）

# 生成因变量：糖尿病（0=无，1=有）
# 真实模型：logit(p) = -5 + 0.05*年龄 + 0.1*BMI + 1.2*家族史
linear_pred <- -5 + 0.05 * age_glm + 0.1 * bmi_glm + 1.2 * family_history
prob_diabetes <- exp(linear_pred) / (1 + exp(linear_pred))
diabetes <- rbinom(n_glm, 1, prob_diabetes)

# 创建数据框
diabetes_data <- data.frame(
  patient_id = 1:n_glm,
  age = age_glm,
  bmi = bmi_glm,
  family_history = factor(family_history, levels = c(0, 1), labels = c("无", "有")),
  diabetes = factor(diabetes, levels = c(0, 1), labels = c("无", "有"))
)

# 查看数据结构
str(diabetes_data)
## 'data.frame':    300 obs. of  5 variables:
##  $ patient_id    : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ age           : num  34 57 60 33 41 46 58 53 62 57 ...
##  $ bmi           : num  21.5 27.6 23.3 34.5 24.9 27 21.7 20.7 31.2 25.3 ...
##  $ family_history: Factor w/ 2 levels "无","有": 1 1 1 1 1 2 1 1 2 1 ...
##  $ diabetes      : Factor w/ 2 levels "无","有": 1 1 1 2 1 2 1 2 2 2 ...
# 描述性统计
table(diabetes_data$diabetes)
## 
##  无  有 
## 107 193
prop.table(table(diabetes_data$diabetes))
## 
##        无        有 
## 0.3566667 0.6433333
# 拟合逻辑回归模型
model_logit <- glm(diabetes ~ age + bmi + family_history, 
                   data = diabetes_data, 
                   family = binomial(link = "logit"))

# 查看模型摘要
summary(model_logit)
## 
## Call:
## glm(formula = diabetes ~ age + bmi + family_history, family = binomial(link = "logit"), 
##     data = diabetes_data)
## 
## Coefficients:
##                  Estimate Std. Error z value Pr(>|z|)    
## (Intercept)      -5.87119    1.19649  -4.907 9.25e-07 ***
## age               0.04896    0.01175   4.166 3.10e-05 ***
## bmi               0.14412    0.03570   4.037 5.42e-05 ***
## family_history有  0.92870    0.30945   3.001  0.00269 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 390.89  on 299  degrees of freedom
## Residual deviance: 349.43  on 296  degrees of freedom
## AIC: 357.43
## 
## Number of Fisher Scoring iterations: 3
# 提取系数和优势比
coef_logit <- broom::tidy(model_logit, conf.int = TRUE, exponentiate = TRUE)
cat("\n========== 优势比（OR）及95%%置信区间 ==========\n")
## 
## ========== 优势比（OR）及95%%置信区间 ==========
print(coef_logit)
## # A tibble: 4 × 7
##   term             estimate std.error statistic     p.value conf.low conf.high
##   <chr>               <dbl>     <dbl>     <dbl>       <dbl>    <dbl>     <dbl>
## 1 (Intercept)       0.00282    1.20       -4.91 0.000000925 0.000249    0.0274
## 2 age               1.05       0.0118      4.17 0.0000310   1.03        1.08  
## 3 bmi               1.16       0.0357      4.04 0.0000542   1.08        1.24  
## 4 family_history有  2.53       0.309       3.00 0.00269     1.40        4.74
# 解释优势比
cat("\n========== 优势比解释 ==========\n")
## 
## ========== 优势比解释 ==========
cat(sprintf("年龄: OR = %.3f，年龄每增加1岁，糖尿病风险增加%.1f%%\n", 
            coef_logit$estimate[2], (coef_logit$estimate[2] - 1) * 100))
## 年龄: OR = 1.050，年龄每增加1岁，糖尿病风险增加5.0%
cat(sprintf("BMI: OR = %.3f，BMI每增加1，糖尿病风险增加%.1f%%\n", 
            coef_logit$estimate[3], (coef_logit$estimate[3] - 1) * 100))
## BMI: OR = 1.155，BMI每增加1，糖尿病风险增加15.5%
cat(sprintf("家族史: OR = %.3f，有家族史者糖尿病风险是无家族史者的%.2f倍\n", 
            coef_logit$estimate[4], coef_logit$estimate[4]))
## 家族史: OR = 2.531，有家族史者糖尿病风险是无家族史者的2.53倍
# 预测概率
diabetes_data$pred_prob <- predict(model_logit, type = "response")

# 绘制预测概率分布
ggplot2::ggplot(diabetes_data, ggplot2::aes(x = pred_prob, fill = diabetes)) +
  ggplot2::geom_histogram(bins = 30, alpha = 0.7, position = "identity") +
  ggplot2::labs(title = "预测概率分布", x = "预测概率", y = "频数", fill = "糖尿病") +
  ggplot2::theme_minimal()

# ROC曲线
library(pROC)
roc_curve <- pROC::roc(diabetes_data$diabetes, diabetes_data$pred_prob, quiet = TRUE)
plot(roc_curve, main = sprintf("ROC曲线 (AUC = %.3f)", pROC::auc(roc_curve)))

2.4 多项逻辑回归

意义与使用场景

核心意义：多项逻辑回归用于处理多分类无序因变量，是二分类逻辑回归的自然扩展。

举例：研究年龄、BMI对疾病分型（I型、II型、III型）的影响

为什么这种数据适合用多项逻辑回归？

首先，因变量”疾病分型”有三个类别（I型、II型、III型），且类别之间没有等级关系（I型不一定比II型轻或重）。其次，二分类逻辑回归无法处理三个及以上类别的问题，需要扩展方法。多项逻辑回归通过设定参照类别，将多分类问题转化为多个二分类比较：I型vs III型、II型vs III型，从而实现对多分类因变量的建模。

研究目的是什么？

本研究有三个层次的目的：1. 识别分型相关因素：判断哪些因素与疾病分型相关；2. 量化相对风险：计算相对风险比（RRR），回答”年龄每增加10岁，患II型而非III型的相对风险是多少”；3. 预测应用：根据患者特征预测最可能的疾病分型，指导个体化治疗。

可能得到什么样的结果？

假设回归结果（以III型为参照）：I型vs III型的年龄RRR=0.85，II型vs III型的年龄RRR=0.92。

  1. 年龄效应解读：年龄每增加1岁，患I型而非III型的相对风险降低15%；患II型而非III型的相对风险降低8%。
  2. 分型趋势：年龄越大，越倾向于患III型（最严重）疾病。
  3. 预测应用：一位70岁、BMI=30的患者，预测为III型的概率最高（约55%）。
  4. 临床意义：年轻患者更可能患I型疾病，治疗方案应有所区别。

需要注意什么？

参照类别的选择会影响结果解释，应选择临床意义明确或样本量较大的类别作为参照。当类别数较多时，模型参数会急剧增加，需要足够的样本量。如果类别之间存在顺序关系（如轻、中、重），应考虑使用序数逻辑回归以提高效率。

数学基础

多项逻辑回归（Multinomial Logistic Regression）：

用于因变量有多个无序分类的情况。

模型形式：

以第\(J\)类为参照组： \[\log\left(\frac{P(Y=k)}{P(Y=J)}\right) = \beta_{k0} + \beta_{k1} X_1 + \cdots + \beta_{kp} X_p\]

概率计算： \[P(Y=k) = \frac{\exp(\beta_{k0} + \beta_{k1} X_1 + \cdots)}{\sum_{j=1}^{J} \exp(\beta_{j0} + \beta_{j1} X_1 + \cdots)}\]

相对风险比（RRR）： \[RRR_k = e^{\beta_k} = \frac{P(Y=k|X)/P(Y=J|X)}{P(Y=k|X')/P(Y=J|X')}\]

代码实现

# 模拟疾病严重程度数据（轻、中、重）
set.seed(567)
n_multi <- 200

# 生成自变量
age_multi <- round(rnorm(n_multi, mean = 55, sd = 10))
bmi_multi <- round(rnorm(n_multi, mean = 27, sd = 4), 1)

# 生成因变量：疾病严重程度
# 真实模型参数
beta_mild <- c(-2, 0.02, 0.05)      # 轻度 vs 重度
beta_moderate <- c(-1, 0.03, 0.08)  # 中度 vs 重度

linear_mild <- beta_mild[1] + beta_mild[2] * age_multi + beta_mild[3] * bmi_multi
linear_moderate <- beta_moderate[1] + beta_moderate[2] * age_multi + beta_moderate[3] * bmi_multi

# 计算概率（以重度为参照）
p_mild <- exp(linear_mild) / (1 + exp(linear_mild) + exp(linear_moderate))
p_moderate <- exp(linear_moderate) / (1 + exp(linear_mild) + exp(linear_moderate))
p_severe <- 1 - p_mild - p_moderate

# 生成分类结果
prob_matrix <- cbind(p_mild, p_moderate, p_severe)
severity <- apply(prob_matrix, 1, function(p) sample(1:3, 1, prob = p))

# 创建数据框
severity_data <- data.frame(
  age = age_multi,
  bmi = bmi_multi,
  severity = factor(severity, levels = 1:3, labels = c("轻度", "中度", "重度"))
)

# 查看分布
table(severity_data$severity)
## 
## 轻度 中度 重度 
##   23  163   14
# 使用nnet包进行多项逻辑回归
library(nnet)
model_multi <- nnet::multinom(severity ~ age + bmi, data = severity_data, trace = FALSE)

# 查看结果
summary(model_multi)
## Call:
## nnet::multinom(formula = severity ~ age + bmi, data = severity_data, 
##     trace = FALSE)
## 
## Coefficients:
##      (Intercept)          age         bmi
## 中度    2.255785  0.005712371 -0.02230257
## 重度    3.443118 -0.037602609 -0.07479578
## 
## Std. Errors:
##      (Intercept)        age        bmi
## 中度    1.932305 0.02159939 0.05815893
## 重度    2.825002 0.03217397 0.08783445
## 
## Residual Deviance: 237.0525 
## AIC: 249.0525
# 提取系数
coef_multi <- coef(model_multi)
cat("\n========== 多项逻辑回归系数 ==========\n")
## 
## ========== 多项逻辑回归系数 ==========
print(coef_multi)
##      (Intercept)          age         bmi
## 中度    2.255785  0.005712371 -0.02230257
## 重度    3.443118 -0.037602609 -0.07479578
# 计算相对风险比
rrr <- exp(coef_multi)
cat("\n========== 相对风险比（RRR） ==========\n")
## 
## ========== 相对风险比（RRR） ==========
print(rrr)
##      (Intercept)       age       bmi
## 中度    9.542784 1.0057287 0.9779443
## 重度   31.284338 0.9630956 0.9279330
# 预测
severity_data$pred_class <- predict(model_multi)
severity_data$pred_prob <- predict(model_multi, type = "probs")

# 混淆矩阵
cat("\n========== 混淆矩阵 ==========\n")
## 
## ========== 混淆矩阵 ==========
print(table(实际 = severity_data$severity, 预测 = severity_data$pred_class))
##       预测
## 实际 轻度 中度 重度
##   轻度    0   23    0
##   中度    0  163    0
##   重度    0   14    0
# 计算准确率
accuracy <- mean(severity_data$severity == severity_data$pred_class)
cat(sprintf("\n预测准确率: %.2f%%\n", accuracy * 100))
## 
## 预测准确率: 81.50%

2.5 序数逻辑回归

意义与使用场景

核心意义：序数逻辑回归用于处理有序分类因变量，利用类别间的顺序信息提高估计效率。

举例：研究年龄、BMI对疾病严重程度（轻度、中度、重度）的影响

为什么这种数据适合用序数逻辑回归？

首先，因变量”疾病严重程度”有三个类别（轻度、中度、重度），且类别之间存在明确的顺序关系：轻度<中度<重度。其次，多项逻辑回归忽略了类别间的顺序信息，会损失估计效率。序数逻辑回归通过累积logit模型，假设自变量对不同切分点（轻度vs中重度、轻中度vs重度）的影响相同，从而减少参数数量，提高估计效率。

研究目的是什么？

本研究有三个层次的目的：1. 识别严重程度相关因素：判断哪些因素与疾病严重程度相关；2. 量化累积效应：计算优势比，回答”年龄每增加10岁，疾病处于更严重等级的优势是多少”；3. 验证比例优势假设：检验自变量对不同切分点的影响是否一致。

可能得到什么样的结果？

假设回归结果为：年龄OR=1.08，BMI OR=1.15，比例优势假设检验p值=0.35。

  1. 年龄效应：年龄每增加1岁，疾病处于更严重等级的优势增加8%；增加10岁优势增加116%。
  2. BMI效应：BMI每增加1个单位，疾病处于更严重等级的优势增加15%。
  3. 比例优势假设：p值>0.05，假设成立，年龄和BMI对轻度vs中重度、轻中度vs重度的影响一致。
  4. 预测应用：一位70岁、BMI=30的患者，预测为重度的概率最高（约60%）。

需要注意什么？

序数逻辑回归的核心假设是比例优势假设，即自变量对不同切分点的影响相同。当假设不成立时（p值<0.05），需要考虑使用偏比例优势模型或退回到多项逻辑回归。此外，序数逻辑回归的系数解释是”累积”效应，而非针对某一特定类别的效应。

数学基础

序数逻辑回归（Ordinal Logistic Regression）：

用于因变量有有序分类的情况，常用累积logit模型。

累积logit模型： \[\log\left(\frac{P(Y \leq j)}{P(Y > j)}\right) = \alpha_j - (\beta_1 X_1 + \cdots + \beta_p X_p)\]

比例优势假设（Proportional Odds Assumption）：

自变量对不同切分点的影响相同，即\(\beta\)在各累积logit中保持不变。

概率计算： \[P(Y \leq j) = \frac{1}{1 + \exp(-(\alpha_j - \mathbf{X}\boldsymbol{\beta}))}\] \[P(Y = j) = P(Y \leq j) - P(Y \leq j-1)\]

代码实现

# 使用MASS包的polr函数进行序数逻辑回归
library(MASS)

# 使用之前的严重程度数据
model_ordinal <- MASS::polr(severity ~ age + bmi, data = severity_data, method = "logistic")

# 查看结果
summary(model_ordinal)
## Call:
## MASS::polr(formula = severity ~ age + bmi, data = severity_data, 
##     method = "logistic")
## 
## Coefficients:
##        Value Std. Error t value
## age -0.01543    0.01756 -0.8791
## bmi -0.03761    0.04738 -0.7940
## 
## Intercepts:
##           Value   Std. Error t value
## 轻度|中度 -3.9107  1.5903    -2.4590
## 中度|重度  0.7571  1.5415     0.4912
## 
## Residual Deviance: 239.1523 
## AIC: 247.1523
# 提取系数
coef_ordinal <- coef(model_ordinal)
cat("\n========== 序数逻辑回归系数 ==========\n")
## 
## ========== 序数逻辑回归系数 ==========
print(coef_ordinal)
##         age         bmi 
## -0.01543382 -0.03761387
# 计算优势比
or_ordinal <- exp(coef_ordinal)
cat("\n========== 优势比（OR） ==========\n")
## 
## ========== 优势比（OR） ==========
print(or_ordinal)
##       age       bmi 
## 0.9846847 0.9630847
# 预测
severity_data$pred_ordinal <- predict(model_ordinal)

# 混淆矩阵
cat("\n========== 混淆矩阵 ==========\n")
## 
## ========== 混淆矩阵 ==========
print(table(实际 = severity_data$severity, 预测 = severity_data$pred_ordinal))
##       预测
## 实际 轻度 中度 重度
##   轻度    0   23    0
##   中度    0  163    0
##   重度    0   14    0
# 比例优势假设检验
library(brant)
brant_test <- brant::brant(model_ordinal)
## -------------------------------------------- 
## Test for X2  df  probability 
## -------------------------------------------- 
## Omnibus      2.12    2   0.35
## age      1.97    1   0.16
## bmi      0.11    1   0.74
## -------------------------------------------- 
## 
## H0: Parallel Regression Assumption holds
print(brant_test)
##                X2 df probability
## Omnibus 2.1176179  2   0.3468687
## age     1.9653524  1   0.1609420
## bmi     0.1094645  1   0.7407546

2.6 泊松回归

意义与使用场景

核心意义：泊松回归用于处理计数数据，假设因变量服从泊松分布，均值等于方差。

举例：研究年龄、慢性病对年门诊就诊次数的影响

为什么这种数据适合用泊松回归？

首先，因变量”年门诊就诊次数”是典型的计数数据，取值为非负整数（0, 1, 2, …）。其次，泊松分布假设计数变量的均值等于方差，当这一假设满足时，泊松回归是最有效的建模方法。门诊就诊次数在一般人群中通常满足这一条件：年均就诊次数约5次，方差也约为5。这种”计数因变量+均值≈方差”的数据结构，正是泊松回归的典型适用场景。

研究目的是什么？

本研究有三个层次的目的：1. 识别就诊相关因素：判断哪些因素与门诊就诊次数相关；2. 量化发生率差异：计算发生率比（IRR），回答”有慢性病者就诊次数是无慢性病者的多少倍”；3. 预测应用：根据患者特征预测年均就诊次数，用于医疗资源规划。

可能得到什么样的结果？

假设回归结果为：log(λ) = 1.0 + 0.02×年龄 + 0.8×慢性病

  1. 年龄效应：IRR=1.02，年龄每增加1岁，就诊次数增加2%；增加10岁增加22%。
  2. 慢性病效应：IRR=2.23，有慢性病者就诊次数是无慢性病者的2.23倍。
  3. 预测应用：一位60岁有慢性病的患者，预计年均就诊次数 = exp(1.0 + 0.02×60 + 0.8) = 11.0次。
  4. 模型检验：残差偏差/自由度≈1，均值≈方差，泊松假设满足。

需要注意什么？

泊松回归的核心假设是均值等于方差。当数据存在过度离散（方差>均值）时，泊松回归会低估标准误，导致假阳性结果。诊断方法：计算方差/均值比，若明显大于1，应考虑负二项回归或准泊松模型。此外，计数数据中若存在大量零值，需考虑零膨胀模型。

数学基础

泊松回归：

用于计数数据，假设因变量服从泊松分布。

模型形式： \[\log(\lambda) = \beta_0 + \beta_1 X_1 + \cdots + \beta_p X_p\]

等价于： \[\lambda = \exp(\beta_0 + \beta_1 X_1 + \cdots + \beta_p X_p)\]

参数说明： - \(\lambda\)：泊松分布的均值（也是方差） - \(\beta_j\)：\(X_j\)每增加1个单位，\(\lambda\)乘以\(e^{\beta_j}\)

发生率比（Incidence Rate Ratio, IRR）： \[IRR = e^{\beta} = \frac{\lambda_1}{\lambda_0}\]

代码实现

# 模拟门诊就诊次数数据
set.seed(678)
n_pois <- 200

# 生成自变量
age_pois <- round(rnorm(n_pois, mean = 45, sd = 12))
chronic_disease <- rbinom(n_pois, 1, 0.4)  # 慢性病（0=无，1=有）

# 生成因变量：年门诊就诊次数
# 真实模型：log(lambda) = 1 + 0.02*年龄 + 0.8*慢性病
lambda <- exp(1 + 0.02 * age_pois + 0.8 * chronic_disease)
visits <- rpois(n_pois, lambda)

# 创建数据框
visit_data <- data.frame(
  age = age_pois,
  chronic_disease = factor(chronic_disease, levels = c(0, 1), labels = c("无", "有")),
  visits = visits
)

# 描述性统计
summary(visit_data$visits)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1.00    6.00    8.00    9.79   13.00   29.00
cat(sprintf("均值 = %.2f, 方差 = %.2f\n", mean(visit_data$visits), var(visit_data$visits)))
## 均值 = 9.79, 方差 = 30.81
# 拟合泊松回归
model_pois <- glm(visits ~ age + chronic_disease, 
                  data = visit_data, 
                  family = poisson(link = "log"))

# 查看结果
summary(model_pois)
## 
## Call:
## glm(formula = visits ~ age + chronic_disease, family = poisson(link = "log"), 
##     data = visit_data)
## 
## Coefficients:
##                   Estimate Std. Error z value Pr(>|z|)    
## (Intercept)       1.060904   0.100882   10.52   <2e-16 ***
## age               0.018698   0.002019    9.26   <2e-16 ***
## chronic_disease有 0.803484   0.045542   17.64   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 582.81  on 199  degrees of freedom
## Residual deviance: 192.74  on 197  degrees of freedom
## AIC: 995.79
## 
## Number of Fisher Scoring iterations: 4
# 提取系数和IRR
coef_pois <- broom::tidy(model_pois, conf.int = TRUE, exponentiate = TRUE)
cat("\n========== 发生率比（IRR）及95%%置信区间 ==========\n")
## 
## ========== 发生率比（IRR）及95%%置信区间 ==========
print(coef_pois)
## # A tibble: 3 × 7
##   term              estimate std.error statistic  p.value conf.low conf.high
##   <chr>                <dbl>     <dbl>     <dbl>    <dbl>    <dbl>     <dbl>
## 1 (Intercept)           2.89   0.101       10.5  7.27e-26     2.37      3.52
## 2 age                   1.02   0.00202      9.26 2.04e-20     1.01      1.02
## 3 chronic_disease有     2.23   0.0455      17.6  1.16e-69     2.04      2.44
# 解释IRR
cat("\n========== IRR解释 ==========\n")
## 
## ========== IRR解释 ==========
cat(sprintf("年龄: IRR = %.3f，年龄每增加1岁，就诊次数增加%.1f%%\n", 
            coef_pois$estimate[2], (coef_pois$estimate[2] - 1) * 100))
## 年龄: IRR = 1.019，年龄每增加1岁，就诊次数增加1.9%
cat(sprintf("慢性病: IRR = %.3f，有慢性病者就诊次数是无慢性病者的%.2f倍\n", 
            coef_pois$estimate[3], coef_pois$estimate[3]))
## 慢性病: IRR = 2.233，有慢性病者就诊次数是无慢性病者的2.23倍
# 预测
visit_data$pred_visits <- predict(model_pois, type = "response")

# 可视化
ggplot2::ggplot(visit_data, ggplot2::aes(x = age, y = visits, color = chronic_disease)) +
  ggplot2::geom_point(alpha = 0.5) +
  ggplot2::geom_smooth(method = "glm", method.args = list(family = "poisson"), se = TRUE) +
  ggplot2::labs(title = "泊松回归拟合", x = "年龄", y = "就诊次数", color = "慢性病") +
  ggplot2::theme_minimal()

2.7 负二项回归

意义与使用场景

核心意义：负二项回归用于处理过度离散的计数数据（方差大于均值），是泊松回归的重要扩展。

举例：研究年龄、慢性病对急诊就诊次数的影响

为什么这种数据适合用负二项回归？

首先，因变量”急诊就诊次数”是计数数据，但急诊就诊行为存在较大异质性：大多数患者一年内急诊就诊0-1次，少数患者因病情复杂频繁就诊（10次以上）。其次，这种异质性导致方差远大于均值（如均值=2，方差=15），违反泊松分布假设。负二项回归通过引入离散参数，允许方差大于均值，能够更好地拟合这种过度离散的计数数据。

研究目的是什么？

本研究有三个层次的目的：1. 识别就诊相关因素：判断哪些因素与急诊就诊次数相关；2. 处理过度离散：通过负二项回归正确估计标准误，避免假阳性结果；3. 比较模型优劣：通过AIC比较泊松回归与负二项回归，选择更优模型。

可能得到什么样的结果？

假设数据诊断显示：均值=2.3，方差=12.8，方差/均值=5.6（明显过度离散）。

  1. 泊松回归AIC=1250，负二项回归AIC=980，负二项回归更优。
  2. 年龄效应：IRR=1.03，年龄每增加1岁，急诊就诊次数增加3%。
  3. 慢性病效应：IRR=2.5，有慢性病者急诊就诊次数是无慢性病者的2.5倍。
  4. 离散参数：θ=1.5，表明存在显著的过度离散，负二项回归的选择是正确的。

需要注意什么？

负二项回归适用于过度离散的计数数据，但需要正确识别过度离散。诊断方法：方差/均值比>1，残差偏差/自由度>>1，或使用Cameron-Trivedi检验。当离散参数θ趋向无穷大时，负二项回归退化为泊松回归。若数据不存在过度离散，使用泊松回归即可。

数学基础

负二项回归：

当计数数据存在过度离散（方差 > 均值）时，泊松回归不再适用，应使用负二项回归。

负二项分布： \[P(Y = y) = \frac{\Gamma(y + \theta)}{\Gamma(\theta) y!} \left(\frac{\theta}{\theta + \mu}\right)^\theta \left(\frac{\mu}{\theta + \mu}\right)^y\]

参数说明： - \(\mu\)：均值 - \(\theta\)：离散参数（\(\theta \to \infty\)时退化为泊松分布） - \(Var(Y) = \mu + \mu^2/\theta\)

模型形式： \[\log(\mu) = \beta_0 + \beta_1 X_1 + \cdots + \beta_p X_p\]

代码实现

# 模拟过度离散的计数数据
set.seed(789)
n_nb <- 200

# 生成自变量
age_nb <- round(rnorm(n_nb, mean = 45, sd = 12))
chronic_nb <- rbinom(n_nb, 1, 0.4)

# 生成过度离散的计数数据
# 使用负二项分布
theta <- 2  # 离散参数
mu <- exp(1 + 0.02 * age_nb + 0.8 * chronic_nb)
visits_nb <- rnbinom(n_nb, size = theta, mu = mu)

# 创建数据框
visit_nb_data <- data.frame(
  age = age_nb,
  chronic_disease = factor(chronic_nb, levels = c(0, 1), labels = c("无", "有")),
  visits = visits_nb
)

# 检查过度离散
cat("========== 过度离散检验 ==========\n")
## ========== 过度离散检验 ==========
cat(sprintf("均值 = %.2f, 方差 = %.2f\n", mean(visit_nb_data$visits), var(visit_nb_data$visits)))
## 均值 = 10.39, 方差 = 102.03
cat(sprintf("方差/均值 = %.2f (> 1 表示过度离散)\n", var(visit_nb_data$visits) / mean(visit_nb_data$visits)))
## 方差/均值 = 9.82 (> 1 表示过度离散)
# 拟合泊松回归（用于比较）
model_pois_nb <- glm(visits ~ age + chronic_disease, 
                      data = visit_nb_data, 
                      family = poisson(link = "log"))

# 拟合负二项回归
library(MASS)
model_nb <- MASS::glm.nb(visits ~ age + chronic_disease, data = visit_nb_data)

# 比较两个模型
cat("\n========== 泊松回归 vs 负二项回归 ==========\n")
## 
## ========== 泊松回归 vs 负二项回归 ==========
cat(sprintf("泊松回归 AIC: %.2f\n", AIC(model_pois_nb)))
## 泊松回归 AIC: 1762.00
cat(sprintf("负二项回归 AIC: %.2f\n", AIC(model_nb)))
## 负二项回归 AIC: 1268.48
# 负二项回归结果
summary(model_nb)
## 
## Call:
## MASS::glm.nb(formula = visits ~ age + chronic_disease, data = visit_nb_data, 
##     init.theta = 2.438268553, link = log)
## 
## Coefficients:
##                   Estimate Std. Error z value Pr(>|z|)    
## (Intercept)       0.842826   0.211872   3.978 6.95e-05 ***
## age               0.022689   0.004335   5.234 1.66e-07 ***
## chronic_disease有 0.905569   0.104174   8.693  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for Negative Binomial(2.4383) family taken to be 1)
## 
##     Null deviance: 317.37  on 199  degrees of freedom
## Residual deviance: 216.24  on 197  degrees of freedom
## AIC: 1268.5
## 
## Number of Fisher Scoring iterations: 1
## 
## 
##               Theta:  2.438 
##           Std. Err.:  0.312 
## 
##  2 x log-likelihood:  -1260.484
# 提取系数和IRR
coef_nb <- broom::tidy(model_nb, conf.int = TRUE, exponentiate = TRUE)
cat("\n========== 负二项回归IRR ==========\n")
## 
## ========== 负二项回归IRR ==========
print(coef_nb)
## # A tibble: 3 × 7
##   term              estimate std.error statistic  p.value conf.low conf.high
##   <chr>                <dbl>     <dbl>     <dbl>    <dbl>    <dbl>     <dbl>
## 1 (Intercept)           2.32   0.212        3.98 6.95e- 5     1.56      3.45
## 2 age                   1.02   0.00434      5.23 1.66e- 7     1.01      1.03
## 3 chronic_disease有     2.47   0.104        8.69 3.53e-18     2.02      3.04
# 离散参数
cat(sprintf("\n离散参数 theta = %.3f\n", model_nb$theta))
## 
## 离散参数 theta = 2.438

2.8 准似然与过度离散

意义与使用场景

核心意义：准似然方法通过引入离散参数，放宽对分布的严格假设，提供更稳健的标准误估计。

举例：临床试验中研究治疗组对不良事件发生次数的影响

为什么这种数据适合用准似然方法？

首先，临床试验中的不良事件计数数据可能存在轻度过度离散（方差略大于均值），但样本量有限，难以精确估计离散参数。其次，负二项回归需要估计额外的离散参数，在小样本情况下可能不稳定。准泊松模型保持泊松回归的结构，仅通过离散参数调整标准误估计，是一种更稳健的折中方案。这种”轻度过度离散+小样本”的场景，适合使用准似然方法。

研究目的是什么？

本研究有三个层次的目的：1. 检验过度离散：判断数据是否存在过度离散，程度如何；2. 稳健推断：通过准泊松模型获得稳健的标准误和置信区间；3. 模型比较：比较泊松、准泊松、负二项三种方法的适用性。

可能得到什么样的结果？

假设数据诊断显示：均值=3.5，方差=5.8，残差偏差/自由度=1.65（轻度过度离散）。

  1. 过度离散检验：离散参数φ=1.65，存在轻度过度离散。
  2. 标准误调整：准泊松模型的标准误是泊松模型的√1.65=1.28倍，置信区间更宽。
  3. 系数比较：泊松回归和准泊松回归的点估计相同，但准泊松的p值更大（更保守）。
  4. 方法选择：轻度过度离散时，准泊松模型足够稳健；重度过度离散时，负二项回归更优。

需要注意什么？

准泊松模型仅调整标准误估计，不改变点估计，适用于轻度过度离散的情况。当过度离散严重时（φ>2），建议使用负二项回归。准泊松模型无法用于预测（没有完整的似然函数），仅适用于推断目的。此外，准似然方法也可用于二项分布的过度离散问题（准二项模型）。

数学基础

过度离散（Overdispersion）：

当数据的方差大于模型假设的方差时，称为过度离散。

检验方法：

  1. 偏差/自由度比：若\(Deviance/df >> 1\)，存在过度离散
  2. Pearson卡方/自由度比：若\(\chi^2/df >> 1\)，存在过度离散
  3. Cameron-Trivedi检验

准泊松模型：

引入离散参数\(\phi\)： \[Var(Y) = \phi \cdot \mu\]

参数说明： - \(\phi = 1\)：泊松模型 - \(\phi > 1\)：过度离散 - \(\phi < 1\)：欠离散

代码实现

# 检验泊松回归的过度离散
# 计算偏差/自由度比
deviance_df <- deviance(model_pois_nb) / model_pois_nb$df.residual
cat(sprintf("偏差/自由度 = %.2f\n", deviance_df))
## 偏差/自由度 = 5.10
# Pearson卡方/自由度比
pearson_chi2 <- sum(residuals(model_pois_nb, type = "pearson")^2)
pearson_df <- pearson_chi2 / model_pois_nb$df.residual
cat(sprintf("Pearson卡方/自由度 = %.2f\n", pearson_df))
## Pearson卡方/自由度 = 5.40
# 拟合准泊松模型
model_quasi <- glm(visits ~ age + chronic_disease, 
                   data = visit_nb_data, 
                   family = quasipoisson(link = "log"))

summary(model_quasi)
## 
## Call:
## glm(formula = visits ~ age + chronic_disease, family = quasipoisson(link = "log"), 
##     data = visit_nb_data)
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)       0.712800   0.219886   3.242   0.0014 ** 
## age               0.025531   0.004192   6.091 5.78e-09 ***
## chronic_disease有 0.903635   0.104709   8.630 2.05e-15 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for quasipoisson family taken to be 5.395892)
## 
##     Null deviance: 1569.2  on 199  degrees of freedom
## Residual deviance: 1005.5  on 197  degrees of freedom
## AIC: NA
## 
## Number of Fisher Scoring iterations: 5
# 提取离散参数
dispersion <- summary(model_quasi)$dispersion
cat(sprintf("\n离散参数 phi = %.2f\n", dispersion))
## 
## 离散参数 phi = 5.40
# 比较标准误
se_compare <- data.frame(
  Variable = c("age", "chronic_disease有"),
  Poisson_SE = summary(model_pois_nb)$coefficients[2:3, 2],
  QuasiPoisson_SE = summary(model_quasi)$coefficients[2:3, 2],
  NegBin_SE = summary(model_nb)$coefficients[2:3, 2]
)
cat("\n========== 标准误比较 ==========\n")
## 
## ========== 标准误比较 ==========
print(se_compare)
##                            Variable  Poisson_SE QuasiPoisson_SE   NegBin_SE
## age                             age 0.001804453     0.004191574 0.004335222
## chronic_disease有 chronic_disease有 0.045076728     0.104708996 0.104173940

2.9 模型诊断

意义与使用场景

核心意义：GLM诊断用于评估模型拟合质量、识别异常值和影响点，确保模型结论的可靠性。

举例：对糖尿病预测的逻辑回归模型进行诊断

为什么这种数据适合用模型诊断？

首先，GLM模型（如逻辑回归）虽然放宽了线性回归的部分假设，但仍需满足一些条件：链接函数正确、无严重异常值、无高影响点。其次，医疗数据中可能存在数据录入错误、特殊病例或极端特征患者，这些异常观测可能扭曲模型结果。模型诊断能够系统性地识别这些问题，确保模型结论的可靠性。

研究目的是什么？

本研究有三个层次的目的：1. 评估拟合质量：通过偏差残差、伪R²等指标评估模型整体拟合效果；2. 识别异常观测：发现偏离模型预测较大的数据点，可能是数据错误或特殊病例；3. 识别影响点：判断哪些观测对模型参数估计有重大影响。

可能得到什么样的结果？

假设诊断结果显示：偏差残差范围[-2.5, 3.2]，伪R²=0.45，第156号观测Cook距离=0.8。

  1. 拟合质量：伪R²=0.45，模型解释了45%的变异，拟合效果中等。
  2. 异常值识别：3个观测的偏差残差绝对值>2，需要检查是否为数据错误。
  3. 影响点诊断：第156号观测Cook距离=0.8（阈值4/n=0.013），删除后年龄系数从0.05变为0.03。
  4. 改进建议：检查第156号观测的数据质量，考虑是否需要特殊处理。

需要注意什么？

GLM诊断与线性回归诊断有所不同：残差的正态性不再是核心假设，但偏差残差的分布仍可用于识别异常值。伪R²的解释与线性回归的R²不同，不能直接比较。Cook距离在GLM中的阈值需要谨慎设定，通常使用4/n或更严格的1/n。

数学基础

GLM诊断指标：

指标 公式 用途
偏差残差 \(r_D = \text{sign}(y-\hat{\mu})\sqrt{d_i}\) 整体拟合评估
Pearson残差 \(r_P = \frac{y-\hat{\mu}}{\sqrt{V(\hat{\mu})}}\) 异常值识别
帽子值 \(h_{ii}\) 杠杆值

偏差（Deviance）： \[D = 2\sum_{i=1}^{n} \left[ y_i \log\left(\frac{y_i}{\hat{\mu}_i}\right) - (y_i - \hat{\mu}_i) \right]\]

拟合优度检验： \[\chi^2 = \frac{D}{\phi} \sim \chi^2_{n-p-1}\]

代码实现

# 使用逻辑回归模型进行诊断
# 偏差残差
dev_resid <- residuals(model_logit, type = "deviance")
# Pearson残差
pear_resid <- residuals(model_logit, type = "pearson")
# 帽子值
hat_values <- hatvalues(model_logit)
# Cook距离
cook_d <- cooks.distance(model_logit)

# 创建诊断数据框
diag_glm <- data.frame(
  obs = 1:length(dev_resid),
  dev_resid = dev_resid,
  pear_resid = pear_resid,
  hat = hat_values,
  cook_d = cook_d
)

# 可视化
p1 <- ggplot2::ggplot(diag_glm, ggplot2::aes(x = obs, y = dev_resid)) +
  ggplot2::geom_point(alpha = 0.6) +
  ggplot2::geom_hline(yintercept = c(-2, 2), color = "red", linetype = "dashed") +
  ggplot2::labs(title = "偏差残差", x = "观测编号", y = "偏差残差") +
  ggplot2::theme_minimal()

p2 <- ggplot2::ggplot(diag_glm, ggplot2::aes(x = hat, y = dev_resid)) +
  ggplot2::geom_point(alpha = 0.6) +
  ggplot2::geom_hline(yintercept = c(-2, 2), color = "red", linetype = "dashed") +
  ggplot2::labs(title = "残差 vs 杠杆值", x = "杠杆值", y = "偏差残差") +
  ggplot2::theme_minimal()

p3 <- ggplot2::ggplot(diag_glm, ggplot2::aes(x = obs, y = cook_d)) +
  ggplot2::geom_bar(stat = "identity", fill = "steelblue") +
  ggplot2::geom_hline(yintercept = 4/nrow(diag_glm), color = "red", linetype = "dashed") +
  ggplot2::labs(title = "Cook距离", x = "观测编号", y = "Cook距离") +
  ggplot2::theme_minimal()

gridExtra::grid.arrange(p1, p2, p3, ncol = 2)

# 模型拟合优度
cat("========== 模型拟合优度 ==========\n")
## ========== 模型拟合优度 ==========
cat(sprintf("空模型偏差: %.2f (df = %d)\n", model_logit$null.deviance, model_logit$df.null))
## 空模型偏差: 390.89 (df = 299)
cat(sprintf("残差偏差: %.2f (df = %d)\n", deviance(model_logit), model_logit$df.residual))
## 残差偏差: 349.43 (df = 296)
cat(sprintf("偏差减少: %.2f%%\n", 
            (model_logit$null.deviance - deviance(model_logit)) / model_logit$null.deviance * 100))
## 偏差减少: 10.60%
# 伪R²
library(DescTools)
pseudo_r2 <- DescTools::PseudoR2(model_logit, which = "all")
cat("\n========== 伪R² ==========\n")
## 
## ========== 伪R² ==========
print(pseudo_r2)
##        McFadden     McFaddenAdj        CoxSnell      Nagelkerke   AldrichNelson 
##      0.10604569      0.08557935      0.12905154      0.17720249      0.12139854 
## VeallZimmermann           Efron McKelveyZavoina            Tjur             AIC 
##      0.21457044      0.13102015      0.18490199      0.13155901    357.43395741 
##             BIC          logLik         logLik0              G2 
##    372.24908731   -174.71697871   -195.44285065     41.45174389

2.10 零膨胀模型

意义与使用场景

核心意义：零膨胀模型用于处理零值比例过高的计数数据，将零值分解为”结构性零”和”抽样零”两部分。

举例：研究年龄、吸烟状态对每日吸烟支数的影响

为什么这种数据适合用零膨胀模型？

首先，因变量”每日吸烟支数”是计数数据，但存在大量零值：非吸烟者每日吸烟支数为0（结构性零），吸烟者偶尔也可能某天不吸烟（抽样零）。其次，标准泊松/负二项回归无法解释过多的零值，会低估零的概率，导致模型拟合不佳。零膨胀模型将零值分解为两部分：结构性零（从不吸烟者）由logit模型解释，抽样零（吸烟者偶尔不吸烟）由计数模型解释。

研究目的是什么？

本研究有三个层次的目的：1. 区分零的来源：识别哪些零是结构性零（非吸烟者），哪些是抽样零（吸烟者偶尔不吸烟）；2. 分析影响因素：分别分析影响”是否吸烟”和”吸烟量”的因素；3. 改善模型拟合：通过零膨胀模型更好地拟合零值过多的计数数据。

可能得到什么样的结果？

假设ZIP模型结果显示：零膨胀部分年龄OR=0.95，计数部分年龄IRR=1.02。

  1. 零膨胀部分：年龄OR=0.95，年龄越大，成为吸烟者的概率越低（结构性零概率越高）。
  2. 计数部分：年龄IRR=1.02，在吸烟者中，年龄越大，每日吸烟支数越多。
  3. 模型比较：ZIP模型AIC=850，泊松回归AIC=1200，ZIP模型拟合更优。
  4. 临床意义：年龄对吸烟行为有双重作用——降低吸烟概率，但增加吸烟量。

需要注意什么？

零膨胀模型适用于零值比例远高于理论预期的情况。诊断方法：比较实际零值比例与泊松/负二项分布预测的零值比例。若零值比例接近理论预期，使用标准计数模型即可。此外，零膨胀模型需要足够样本量来同时估计两部分参数。模型选择：ZIP适用于无过度离散的数据，ZINB适用于过度离散的数据。

数学基础

零膨胀模型（Zero-Inflated Models）：

当计数数据中零值比例过高时使用，由两部分组成： 1. 零膨胀部分：Logit/Probit模型预测零的概率 2. 计数部分：泊松/负二项模型预测计数

零膨胀泊松模型（ZIP）： \[P(Y = 0) = \pi + (1-\pi)e^{-\lambda}\] \[P(Y = y) = (1-\pi)\frac{e^{-\lambda}\lambda^y}{y!}, \quad y = 1, 2, \ldots\]

参数说明： - \(\pi\)：额外零的概率 - \(\lambda\)：泊松分布的均值

代码实现

# 模拟零膨胀数据
set.seed(890)
n_zip <- 200

# 生成自变量
age_zip <- round(rnorm(n_zip, mean = 45, sd = 10))
smoking <- rbinom(n_zip, 1, 0.3)  # 吸烟（0=否，1=是）

# 零膨胀部分：某些人从不就诊
pi_zero <- 1 / (1 + exp(-(-1 + 0.02 * age_zip - 0.5 * smoking)))
always_zero <- rbinom(n_zip, 1, pi_zero)

# 计数部分：就诊次数
lambda_zip <- exp(1 + 0.02 * age_zip + 0.5 * smoking)
visits_zip <- ifelse(always_zero == 1, 0, rpois(n_zip, lambda_zip))

# 创建数据框
zip_data <- data.frame(
  age = age_zip,
  smoking = factor(smoking, levels = c(0, 1), labels = c("否", "是")),
  visits = visits_zip
)

# 检查零的比例
cat("========== 零值比例 ==========\n")
## ========== 零值比例 ==========
cat(sprintf("零值比例: %.2f%%\n", mean(zip_data$visits == 0) * 100))
## 零值比例: 40.50%
# 拟合标准泊松回归
model_pois_zip <- glm(visits ~ age + smoking, 
                       data = zip_data, 
                       family = poisson(link = "log"))

# 拟合零膨胀泊松模型
library(pscl)
model_zip <- pscl::zeroinfl(visits ~ age + smoking | age + smoking, 
                             data = zip_data, dist = "poisson")

# 拟合零膨胀负二项模型
model_zinb <- pscl::zeroinfl(visits ~ age + smoking | age + smoking, 
                              data = zip_data, dist = "negbin")

# 比较模型
cat("\n========== 模型比较 ==========\n")
## 
## ========== 模型比较 ==========
cat(sprintf("泊松回归 AIC: %.2f\n", AIC(model_pois_zip)))
## 泊松回归 AIC: 1615.55
cat(sprintf("ZIP AIC: %.2f\n", AIC(model_zip)))
## ZIP AIC: 868.63
cat(sprintf("ZINB AIC: %.2f\n", AIC(model_zinb)))
## ZINB AIC: 869.90
# ZIP模型结果
summary(model_zip)
## 
## Call:
## pscl::zeroinfl(formula = visits ~ age + smoking | age + smoking, data = zip_data, 
##     dist = "poisson")
## 
## Pearson residuals:
##     Min      1Q  Median      3Q     Max 
## -1.2869 -1.0096  0.0846  0.7865  2.6706 
## 
## Count model coefficients (poisson with log link):
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) 1.035651   0.147349   7.029 2.09e-12 ***
## age         0.017400   0.002956   5.887 3.94e-09 ***
## smoking是   0.670040   0.064255  10.428  < 2e-16 ***
## 
## Zero-inflation model coefficients (binomial with logit link):
##             Estimate Std. Error z value Pr(>|z|)  
## (Intercept) -1.14994    0.66958  -1.717   0.0859 .
## age          0.01726    0.01395   1.237   0.2160  
## smoking是   -0.13637    0.31804  -0.429   0.6681  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 
## 
## Number of iterations in BFGS optimization: 11 
## Log-likelihood: -428.3 on 6 Df
# 提取系数
cat("\n========== ZIP模型系数 ==========\n")
## 
## ========== ZIP模型系数 ==========
cat("计数部分（泊松）IRR：\n")
## 计数部分（泊松）IRR：
print(exp(coef(model_zip, model = "count")))
## (Intercept)         age   smoking是 
##    2.816940    1.017552    1.954316
cat("\n零膨胀部分（logit）OR：\n")
## 
## 零膨胀部分（logit）OR：
print(exp(coef(model_zip, model = "zero")))
## (Intercept)         age   smoking是 
##   0.3166568   1.0174080   0.8725219

第二章小结

核心知识点总结

主题 核心内容 关键函数
指数族分布 GLM的理论基础 dnorm(), dbinom(), dpois()
链接函数 连接均值与线性预测器 glm(family = ...)
逻辑回归 二分类因变量 glm(family = binomial)
多项逻辑回归 无序多分类 nnet::multinom()
序数逻辑回归 有序多分类 MASS::polr()
泊松回归 计数数据 glm(family = poisson)
负二项回归 过度离散计数 MASS::glm.nb()
准泊松模型 过度离散校正 glm(family = quasipoisson)
零膨胀模型 过多零值的计数 pscl::zeroinfl()

第三章：混合效应模型

混合效应模型（Mixed Effects Models）用于处理具有层次结构或聚类特征的数据，如患者嵌套在医院中、重复测量数据等。本章将系统讲解线性混合模型和广义线性混合模型的理论与应用。

3.1 线性混合模型的基本结构

意义与使用场景

核心意义：线性混合模型用于处理具有层次结构或聚类特征的数据，通过引入随机效应来捕捉组间异质性。

举例：多中心临床试验中研究治疗对血压的影响

为什么这种数据适合用线性混合模型？

首先，数据具有层次结构：患者嵌套在医院中，同一医院的患者可能具有相似的特征（如相似的医疗水平、护理质量）。其次，传统线性回归假设观测独立，忽略了层次结构，会导致标准误低估、假阳性增加。线性混合模型通过引入随机效应（医院效应），能够正确处理层次结构数据，同时估计组间和组内效应。

研究目的是什么？

本研究有三个层次的目的：1. 估计治疗效果：在控制医院间差异后，准确估计治疗对血压的影响；2. 量化医院异质性：通过随机效应方差估计医院间的差异程度；3. 正确推断：获得稳健的标准误和置信区间，避免假阳性结果。

可能得到什么样的结果？

假设模型结果显示：治疗组系数=-10.2（p<0.001），医院随机效应方差=64，残差方差=100。

  1. 治疗效应：治疗组比对照组血压平均降低10.2 mmHg，差异显著。
  2. 医院异质性：医院间方差=64，说明不同医院的基础血压水平存在差异（标准差=8 mmHg）。
  3. 组内相关系数：ICC=64/(64+100)=0.39，39%的变异来自医院间差异。
  4. 标准误校正：与传统回归相比，混合模型的标准误更大，推断更稳健。

需要注意什么？

线性混合模型假设随机效应服从正态分布，当组数较少（<10组）时，随机效应估计可能不稳定。此外，需要区分固定效应和随机效应的选择：关注特定组效应时用固定效应，关注总体效应时用随机效应。模型选择可通过似然比检验或AIC比较。

数学基础

线性混合模型（Linear Mixed Model, LMM）：

包含固定效应和随机效应的线性模型。

模型形式： \[Y_{ij} = \underbrace{\mathbf{X}_{ij}'\boldsymbol{\beta}}_{\text{固定效应}} + \underbrace{\mathbf{Z}_{ij}'\mathbf{b}_i}_{\text{随机效应}} + \varepsilon_{ij}\]

矩阵形式： \[\mathbf{Y} = \mathbf{X}\boldsymbol{\beta} + \mathbf{Z}\mathbf{b} + \boldsymbol{\varepsilon}\]

参数说明： - \(Y_{ij}\)：第\(i\)组第\(j\)个观测的因变量 - \(\mathbf{X}_{ij}\)：固定效应设计矩阵 - \(\boldsymbol{\beta}\)：固定效应系数 - \(\mathbf{Z}_{ij}\)：随机效应设计矩阵 - \(\mathbf{b}_i\)：第\(i\)组的随机效应，\(\mathbf{b}_i \sim N(\mathbf{0}, \mathbf{D})\) - \(\varepsilon_{ij}\)：残差，\(\varepsilon_{ij} \sim N(0, \sigma^2)\)

随机效应的假设： \[\mathbf{b} \sim N(\mathbf{0}, \mathbf{G}), \quad \boldsymbol{\varepsilon} \sim N(\mathbf{0}, \mathbf{R})\]

边际方差： \[Var(\mathbf{Y}) = \mathbf{Z}\mathbf{G}\mathbf{Z}' + \mathbf{R}\]

代码实现

# 模拟嵌套数据：患者嵌套在医院中
# 场景：研究不同医院患者的血压控制情况

set.seed(123)
n_hospitals <- 20          # 医院数量
n_per_hospital <- 15       # 每个医院的患者数
n_total <- n_hospitals * n_per_hospital

# 生成医院ID
hospital_id <- factor(rep(1:n_hospitals, each = n_per_hospital))

# 生成医院级别的随机效应（不同医院的基础血压水平不同）
hospital_effect <- rnorm(n_hospitals, mean = 0, sd = 8)
hospital_effect_expanded <- hospital_effect[as.numeric(hospital_id)]

# 生成患者级别的自变量
age_lmm <- round(rnorm(n_total, mean = 55, sd = 12))
treatment <- rbinom(n_total, 1, 0.5)  # 治疗组（0=对照，1=治疗）

# 生成因变量：收缩压
# 固定效应：年龄、治疗
# 随机效应：医院截距
bp <- 120 + 0.5 * age_lmm - 10 * treatment + hospital_effect_expanded + rnorm(n_total, 0, 10)

# 创建数据框
bp_data <- data.frame(
  patient_id = 1:n_total,
  hospital = hospital_id,
  age = age_lmm,
  treatment = factor(treatment, levels = c(0, 1), labels = c("对照", "治疗")),
  bp = bp
)

# 查看数据结构
str(bp_data)
## 'data.frame':    300 obs. of  5 variables:
##  $ patient_id: int  1 2 3 4 5 6 7 8 9 10 ...
##  $ hospital  : Factor w/ 20 levels "1","2","3","4",..: 1 1 1 1 1 1 1 1 1 1 ...
##  $ age       : num  42 52 43 46 47 35 65 57 41 70 ...
##  $ treatment : Factor w/ 2 levels "对照","治疗": 2 2 2 1 1 2 2 1 1 2 ...
##  $ bp        : num  146 129 114 136 137 ...
head(bp_data)
##   patient_id hospital age treatment       bp
## 1          1        1  42      治疗 146.2704
## 2          2        1  52      治疗 128.7014
## 3          3        1  43      治疗 113.7867
## 4          4        1  46      对照 136.1227
## 5          5        1  47      对照 136.8758
## 6          6        1  35      治疗 124.5330
# 描述性统计：按医院汇总
hospital_summary <- bp_data %>%
  dplyr::group_by(hospital) %>%
  dplyr::summarise(
    n = dplyr::n(),
    mean_bp = mean(bp),
    sd_bp = sd(bp)
  )
print(hospital_summary)
## # A tibble: 20 × 4
##    hospital     n mean_bp sd_bp
##    <fct>    <int>   <dbl> <dbl>
##  1 1           15    138. 11.6 
##  2 2           15    142.  7.68
##  3 3           15    152. 12.2 
##  4 4           15    145. 10.3 
##  5 5           15    147. 11.6 
##  6 6           15    156. 12.6 
##  7 7           15    144.  9.55
##  8 8           15    131. 13.9 
##  9 9           15    134. 13.4 
## 10 10          15    138. 11.8 
## 11 11          15    153. 12.8 
## 12 12          15    145. 12.9 
## 13 13          15    148. 16.5 
## 14 14          15    139.  8.69
## 15 15          15    134. 15.3 
## 16 16          15    155. 14.3 
## 17 17          15    148. 14.1 
## 18 18          15    129.  9.13
## 19 19          15    155. 17.9 
## 20 20          15    140. 13.2

3.2 随机截距与随机斜率

意义与使用场景

核心意义：随机截距允许不同组有不同的基线水平，随机斜率允许不同组有不同的效应大小。

举例：研究不同医院治疗效果的异质性

为什么这种数据适合用随机斜率模型？

首先，不同医院的基础血压水平可能不同（随机截距）：三甲医院患者可能病情更重，社区医院患者可能病情较轻。其次，不同医院的治疗效果可能存在差异（随机斜率）：三甲医院设备先进、医生经验丰富，治疗效果可能更好；社区医院资源有限，治疗效果可能较弱。随机斜率模型能够捕捉这种”治疗效果因医院而异”的异质性。

研究目的是什么？

本研究有三个层次的目的：1. 估计平均治疗效果：在考虑医院异质性后，估计总体治疗效果；2. 识别效果异质性：判断治疗效果是否在不同医院间存在显著差异；3. 模型选择：通过似然比检验比较随机截距模型与随机斜率模型。

可能得到什么样的结果？

假设随机斜率模型显示：平均治疗效果=-10 mmHg，治疗效果随机斜率方差=25（标准差=5 mmHg）。

  1. 平均效应：总体而言，治疗组比对照组血压降低10 mmHg。
  2. 效果异质性：治疗效果的标准差为5 mmHg，说明不同医院的治疗效果存在差异。
  3. 医院间比较：治疗效果最好的医院可能降低15 mmHg，最差的医院可能仅降低5 mmHg。
  4. 模型比较：随机斜率模型AIC比随机截距模型小20，支持使用随机斜率模型。

需要注意什么？

随机斜率模型增加了参数数量，需要足够多的组（通常>20组）和每组足够的样本量。当随机斜率方差很小时，可能退化为随机截距模型。此外，随机截距和随机斜率可能存在相关性：基础水平高的医院，治疗效果可能更好或更差。模型选择应结合似然比检验和AIC。

数学基础

随机截距模型：

每个组有不同的截距，但斜率相同。

\[Y_{ij} = (\beta_0 + b_{0i}) + \beta_1 X_{ij} + \varepsilon_{ij}\]

参数说明： - \(b_{0i}\)：第\(i\)组的随机截距，\(b_{0i} \sim N(0, \tau_{00}^2)\) - \(\tau_{00}^2\)：组间方差

随机斜率模型：

每个组有不同的截距和斜率。

\[Y_{ij} = (\beta_0 + b_{0i}) + (\beta_1 + b_{1i}) X_{ij} + \varepsilon_{ij}\]

参数说明： - \(b_{0i}\)：随机截距 - \(b_{1i}\)：随机斜率，\(b_{1i} \sim N(0, \tau_{11}^2)\) - \(Cov(b_{0i}, b_{1i}) = \tau_{01}\)

组内相关系数（ICC）：

\[ICC = \frac{\tau_{00}^2}{\tau_{00}^2 + \sigma^2}\]

衡量组间方差占总方差的比例。

代码实现

# 1. 随机截距模型
model_ri <- lme4::lmer(bp ~ age + treatment + (1 | hospital), data = bp_data)
summary(model_ri)
## Linear mixed model fit by REML ['lmerMod']
## Formula: bp ~ age + treatment + (1 | hospital)
##    Data: bp_data
## 
## REML criterion at convergence: 2270.5
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -2.8610 -0.5937 -0.0102  0.6330  2.6993 
## 
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  hospital (Intercept) 55.96    7.481   
##  Residual             98.86    9.943   
## Number of obs: 300, groups:  hospital, 20
## 
## Fixed effects:
##                Estimate Std. Error t value
## (Intercept)   119.72097    3.39868  35.226
## age             0.52535    0.05085  10.332
## treatment治疗  -9.82240    1.18110  -8.316
## 
## Correlation of Fixed Effects:
##               (Intr) age   
## age           -0.834       
## treatment治疗 -0.216  0.040
# 提取方差成分
vc_ri <- lme4::VarCorr(model_ri)
cat("\n========== 随机截距模型方差成分 ==========\n")
## 
## ========== 随机截距模型方差成分 ==========
print(vc_ri)
##  Groups   Name        Std.Dev.
##  hospital (Intercept) 7.4805  
##  Residual             9.9431
# 计算ICC
tau2 <- as.numeric(vc_ri$hospital)
sigma2 <- attr(vc_ri, "sc")^2
icc <- tau2 / (tau2 + sigma2)
cat(sprintf("\n组内相关系数(ICC) = %.3f\n", icc))
## 
## 组内相关系数(ICC) = 0.361
# 2. 随机斜率模型（允许治疗效果在不同医院间变化）
model_rs <- lme4::lmer(bp ~ age + treatment + (1 + treatment | hospital), data = bp_data)
summary(model_rs)
## Linear mixed model fit by REML ['lmerMod']
## Formula: bp ~ age + treatment + (1 + treatment | hospital)
##    Data: bp_data
## 
## REML criterion at convergence: 2270.2
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -2.8782 -0.6045 -0.0095  0.6442  2.6468 
## 
## Random effects:
##  Groups   Name          Variance Std.Dev. Corr  
##  hospital (Intercept)   61.7953  7.8610         
##           treatment治疗  0.5871  0.7662   -0.91 
##  Residual               98.6958  9.9346         
## Number of obs: 300, groups:  hospital, 20
## 
## Fixed effects:
##               Estimate Std. Error t value
## (Intercept)   119.8866     3.4391  34.860
## age             0.5222     0.0508  10.280
## treatment治疗  -9.8202     1.1922  -8.237
## 
## Correlation of Fixed Effects:
##               (Intr) age   
## age           -0.824       
## treatment治疗 -0.277  0.039
# 提取方差成分
vc_rs <- lme4::VarCorr(model_rs)
cat("\n========== 随机斜率模型方差成分 ==========\n")
## 
## ========== 随机斜率模型方差成分 ==========
print(vc_rs)
##  Groups   Name          Std.Dev. Corr   
##  hospital (Intercept)   7.86100         
##           treatment治疗 0.76621  -0.905 
##  Residual               9.93458
# 比较模型
cat("\n========== 模型比较 ==========\n")
## 
## ========== 模型比较 ==========
cat(sprintf("随机截距模型 AIC: %.2f\n", AIC(model_ri)))
## 随机截距模型 AIC: 2280.47
cat(sprintf("随机斜率模型 AIC: %.2f\n", AIC(model_rs)))
## 随机斜率模型 AIC: 2284.18
# 似然比检验
anova(model_ri, model_rs)
## Data: bp_data
## Models:
## model_ri: bp ~ age + treatment + (1 | hospital)
## model_rs: bp ~ age + treatment + (1 + treatment | hospital)
##          npar    AIC    BIC  logLik -2*log(L)  Chisq Df Pr(>Chisq)
## model_ri    5 2281.5 2300.0 -1135.7    2271.5                     
## model_rs    7 2285.2 2311.1 -1135.6    2271.2 0.2861  2     0.8667
# 可视化随机效应
# 提取随机效应
ranef_ri <- lme4::ranef(model_ri)$hospital
ranef_rs <- lme4::ranef(model_rs)$hospital

# 绘制随机截距分布
par(mfrow = c(1, 2))
hist(ranef_ri[, 1], main = "随机截距分布", xlab = "随机截距", col = "steelblue", breaks = 10)
hist(ranef_rs[, 2], main = "随机斜率分布", xlab = "随机斜率", col = "steelblue", breaks = 10)

par(mfrow = c(1, 1))

3.3 嵌套与交叉设计

意义与使用场景

核心意义：嵌套设计处理层次结构数据，交叉设计处理多因素交叉影响的数据结构。

举例：研究医院质量改进项目对患者满意度的影响

为什么这种数据适合用嵌套/交叉模型？

首先，医疗数据常具有复杂结构：患者嵌套在病区，病区嵌套在医院（嵌套结构）；同时，患者可能接受不同医生、护士的治疗（交叉结构）。其次，忽略这种复杂结构会导致标准误估计错误。嵌套模型能够正确处理”患者→病区→医院”的层次关系；交叉模型能够处理”患者×医生”的交叉关系。

研究目的是什么？

本研究有三个层次的目的：1. 分解变异来源：量化医院、病区、患者各层次的变异大小；2. 正确建模：根据数据结构选择嵌套或交叉模型；3. 指导干预：根据变异来源确定质量改进的重点层次。

可能得到什么样的结果？

假设嵌套模型显示：医院间方差=25，病区间方差=16，患者间方差=9，残差方差=100。

  1. 变异分解：总变异中，医院层次占17%，病区层次占11%，患者层次占6%，个体差异占66%。
  2. 干预方向：医院和病区层次的变异占28%，说明质量改进应重点关注医院和病区层面。
  3. ICC计算：医院层次ICC=25/(25+16+9+100)=0.17，同一医院患者满意度相关性为17%。
  4. 交叉效应：若患者接受多个医生治疗，医生效应方差=12，说明医生间差异也是重要因素。

需要注意什么？

嵌套和交叉结构需要正确识别：嵌套关系中低层单位只属于一个高层单位（病区只属于一个医院）；交叉关系中单位可属于多个因素（患者可接受多个医生治疗）。模型设定错误会导致估计偏差。此外，交叉设计的模型更复杂，需要更多数据支持。

数学基础

嵌套设计：

低层次单位完全嵌套在高层次单位中。例如：学生嵌套在班级中，班级嵌套在学校中。

\[Y_{ijk} = \beta_0 + b_{0k}^{(school)} + b_{0jk}^{(class)} + \varepsilon_{ijk}\]

交叉设计：

一个因素与多个其他因素交叉。例如：学生接受不同老师的课程。

\[Y_{ijk} = \beta_0 + b_{0i}^{(student)} + b_{0j}^{(teacher)} + \varepsilon_{ijk}\]

代码实现

# 嵌套设计示例：患者嵌套在病区，病区嵌套在医院
set.seed(456)
n_hospitals_nested <- 10
n_wards_per_hospital <- 3
n_patients_per_ward <- 8

# 生成嵌套ID
hospital_nested <- factor(rep(1:n_hospitals_nested, each = n_wards_per_hospital * n_patients_per_ward))
ward_nested <- factor(rep(1:(n_hospitals_nested * n_wards_per_hospital), each = n_patients_per_ward))

n_nested <- n_hospitals_nested * n_wards_per_hospital * n_patients_per_ward

# 生成随机效应
hospital_effect_nested <- rnorm(n_hospitals_nested, 0, 5)[as.numeric(hospital_nested)]
ward_effect_nested <- rnorm(n_hospitals_nested * n_wards_per_hospital, 0, 3)[as.numeric(ward_nested)]

# 生成数据
age_nested <- rnorm(n_nested, 50, 10)
outcome_nested <- 100 + 0.5 * age_nested + hospital_effect_nested + ward_effect_nested + rnorm(n_nested, 0, 5)

nested_data <- data.frame(
  hospital = hospital_nested,
  ward = ward_nested,
  age = age_nested,
  outcome = outcome_nested
)

# 拟合嵌套模型
model_nested <- lme4::lmer(outcome ~ age + (1 | hospital/ward), data = nested_data)
summary(model_nested)
## Linear mixed model fit by REML ['lmerMod']
## Formula: outcome ~ age + (1 | hospital/ward)
##    Data: nested_data
## 
## REML criterion at convergence: 1504.9
## 
## Scaled residuals: 
##      Min       1Q   Median       3Q      Max 
## -2.58442 -0.65975 -0.02934  0.63128  2.47259 
## 
## Random effects:
##  Groups        Name        Variance Std.Dev.
##  ward:hospital (Intercept) 11.86    3.444   
##  hospital      (Intercept) 25.45    5.045   
##  Residual                  23.44    4.842   
## Number of obs: 240, groups:  ward:hospital, 30; hospital, 10
## 
## Fixed effects:
##              Estimate Std. Error t value
## (Intercept) 100.15253    2.43530   41.12
## age           0.52205    0.03394   15.38
## 
## Correlation of Fixed Effects:
##     (Intr)
## age -0.698
# 查看方差成分
cat("\n========== 嵌套模型方差成分 ==========\n")
## 
## ========== 嵌套模型方差成分 ==========
print(lme4::VarCorr(model_nested))
##  Groups        Name        Std.Dev.
##  ward:hospital (Intercept) 3.4440  
##  hospital      (Intercept) 5.0446  
##  Residual                  4.8415
# 交叉设计示例：患者接受不同医生的治疗
set.seed(789)
n_patients_cross <- 100
n_doctors <- 15

# 每个患者看多个医生，每个医生看多个患者（交叉）
patient_cross <- factor(rep(1:n_patients_cross, each = 3))
doctor_cross <- factor(sample(1:n_doctors, n_patients_cross * 3, replace = TRUE))

n_cross <- n_patients_cross * 3

# 生成随机效应
patient_effect <- rnorm(n_patients_cross, 0, 4)[as.numeric(patient_cross)]
doctor_effect <- rnorm(n_doctors, 0, 3)[as.numeric(doctor_cross)]

# 生成数据
time_cross <- rnorm(n_cross, 50, 10)
outcome_cross <- 100 + 0.3 * time_cross + patient_effect + doctor_effect + rnorm(n_cross, 0, 3)

cross_data <- data.frame(
  patient = patient_cross,
  doctor = doctor_cross,
  time = time_cross,
  outcome = outcome_cross
)

# 拟合交叉模型
model_cross <- lme4::lmer(outcome ~ time + (1 | patient) + (1 | doctor), data = cross_data)
summary(model_cross)
## Linear mixed model fit by REML ['lmerMod']
## Formula: outcome ~ time + (1 | patient) + (1 | doctor)
##    Data: cross_data
## 
## REML criterion at convergence: 1749.8
## 
## Scaled residuals: 
##      Min       1Q   Median       3Q      Max 
## -2.19933 -0.65035  0.09778  0.52889  2.39861 
## 
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  patient  (Intercept) 15.904   3.988   
##  doctor   (Intercept)  8.222   2.867   
##  Residual              9.688   3.113   
## Number of obs: 300, groups:  patient, 100; doctor, 15
## 
## Fixed effects:
##              Estimate Std. Error t value
## (Intercept) 100.04146    1.44771   69.10
## time          0.28721    0.02301   12.48
## 
## Correlation of Fixed Effects:
##      (Intr)
## time -0.804
cat("\n========== 交叉模型方差成分 ==========\n")
## 
## ========== 交叉模型方差成分 ==========
print(lme4::VarCorr(model_cross))
##  Groups   Name        Std.Dev.
##  patient  (Intercept) 3.9880  
##  doctor   (Intercept) 2.8674  
##  Residual             3.1126

3.4 方差成分估计

意义与使用场景

核心意义：方差成分估计用于量化不同层次（组间、组内）的变异大小，是混合效应模型的核心。

举例：评估多中心临床试验中医院间变异的大小

为什么这种数据适合用方差成分估计？

首先，混合效应模型的核心是区分组间变异（随机效应方差）和组内变异（残差方差）。其次，方差成分估计能够回答关键问题：不同医院之间的差异有多大？同一医院内患者之间的差异有多大？这些信息对于理解数据结构、设计研究、解释结果都至关重要。

研究目的是什么？

本研究有三个层次的目的：1. 量化组间变异：估计医院间方差，判断医院异质性的程度；2. 计算ICC：组内相关系数反映同一医院患者相似程度；3. 指导研究设计：根据ICC确定样本量分配策略（更多医院还是更多患者）。

可能得到什么样的结果？

假设方差成分估计显示：医院间方差τ²=64，残差方差σ²=100，ICC=0.39。

  1. 组间变异：医院间标准差=8 mmHg，说明不同医院的基础血压水平存在明显差异。
  2. 组内相关：ICC=0.39，同一医院患者血压的相关性为39%，层次结构效应显著。
  3. 设计效应：DEFF=1+(m-1)×ICC=1+14×0.39=6.46，有效样本量仅为名义样本量的1/6.46。
  4. 样本量启示：增加医院数量比增加每医院患者数更有效。

需要注意什么？

方差成分估计方法有REML和ML两种：REML对方差的估计更准确，推荐用于最终模型；ML考虑固定效应损失自由度，适用于模型比较。当方差成分估计为0或接近0时，可能不需要随机效应。此外，小样本情况下方差估计可能不稳定，需要谨慎解释。

数学基础

方差成分估计方法：

方法 特点 适用场景
ANOVA方法 基于期望均方 平衡设计
ML（极大似然） 考虑固定效应损失 模型比较
REML（限制极大似然） 校正固定效应损失 方差估计（推荐）

REML vs ML：

REML通过投影消除固定效应的影响，得到无偏的方差估计。

\[\ell_{REML}(\boldsymbol{\theta}) = \ell_{ML}(\boldsymbol{\theta}) - \frac{1}{2}\log|\mathbf{X}'\mathbf{V}^{-1}\mathbf{X}|\]

代码实现

# 比较ML和REML估计
model_ml <- lme4::lmer(bp ~ age + treatment + (1 | hospital), 
                        data = bp_data, REML = FALSE)
model_reml <- lme4::lmer(bp ~ age + treatment + (1 | hospital), 
                          data = bp_data, REML = TRUE)

cat("========== ML估计 ==========\n")
## ========== ML估计 ==========
print(lme4::VarCorr(model_ml))
##  Groups   Name        Std.Dev.
##  hospital (Intercept) 7.2696  
##  Residual             9.9077
cat("\n========== REML估计 ==========\n")
## 
## ========== REML估计 ==========
print(lme4::VarCorr(model_reml))
##  Groups   Name        Std.Dev.
##  hospital (Intercept) 7.4805  
##  Residual             9.9431
# 使用nlme包进行更灵活的建模
library(nlme)
model_nlme <- nlme::lme(bp ~ age + treatment, 
                         random = ~ 1 | hospital, 
                         data = bp_data,
                         method = "REML")
summary(model_nlme)
## Linear mixed-effects model fit by REML
##   Data: bp_data 
##        AIC      BIC    logLik
##   2280.466 2298.935 -1135.233
## 
## Random effects:
##  Formula: ~1 | hospital
##         (Intercept) Residual
## StdDev:    7.480538 9.943065
## 
## Fixed effects:  bp ~ age + treatment 
##                   Value Std.Error  DF  t-value p-value
## (Intercept)   119.72097  3.398680 278 35.22573       0
## age             0.52535  0.050848 278 10.33183       0
## treatment治疗  -9.82240  1.181105 278 -8.31628       0
##  Correlation:
##               (Intr) age   
## age           -0.834       
## treatment治疗 -0.216  0.040
## 
## Standardized Within-Group Residuals:
##         Min          Q1         Med          Q3         Max 
## -2.86099697 -0.59373342 -0.01019796  0.63300736  2.69928772 
## 
## Number of Observations: 300
## Number of Groups: 20
# 提取方差成分
var_comp <- nlme::VarCorr(model_nlme)
print(var_comp)
## hospital = pdLogChol(1) 
##             Variance StdDev  
## (Intercept) 55.95845 7.480538
## Residual    98.86454 9.943065

3.5 广义线性混合模型

意义与使用场景

核心意义：广义线性混合模型（GLMM）结合了GLM和混合效应模型的优点，可处理非正态分布的层次结构数据。

举例：纵向研究中研究治疗对症状缓解的影响（二分类重复测量）

为什么这种数据适合用广义线性混合模型？

首先，因变量”症状是否缓解”是二分类变量，需要使用逻辑回归框架。其次，同一患者的多次测量不独立，存在层次结构（测量嵌套在患者中）。传统逻辑回归忽略层次结构会导致标准误低估。GLMM结合了逻辑回归（处理二分类因变量）和混合效应模型（处理层次结构），能够正确分析这类数据。

研究目的是什么？

本研究有三个层次的目的：1. 估计治疗效果：在控制患者间异质性后，估计治疗对症状缓解的影响；2. 分析时间趋势：判断症状缓解率是否随时间变化；3. 正确推断：获得稳健的标准误和置信区间。

可能得到什么样的结果？

假设GLMM结果显示：治疗组OR=2.5（p<0.001），时间效应OR=1.3（p=0.02），患者随机效应方差=2.25。

  1. 治疗效应：治疗组症状缓解的优势是对照组的2.5倍，差异显著。
  2. 时间效应：每增加一次随访，症状缓解的优势增加30%。
  3. 患者异质性：患者随机效应方差=2.25（标准差=1.5），说明不同患者的基线缓解概率存在较大差异。
  4. ICC计算：在logit尺度上，患者间ICC=2.25/(2.25+π²/3)=0.41。

需要注意什么？

GLMM的参数估计比LMM更复杂，常用方法包括Laplace近似和自适应高斯求积。Laplace近似速度快但可能不够精确；自适应高斯求积更精确但计算量大。此外，GLMM的边际效应和条件效应不同，解释时需明确是哪种效应。模型收敛问题在GLMM中更常见，可能需要简化模型或调整优化参数。

数学基础

广义线性混合模型（GLMM）：

将GLM扩展到包含随机效应的情况。

模型形式： \[g(E[Y_{ij} | \mathbf{b}_i]) = \mathbf{X}_{ij}'\boldsymbol{\beta} + \mathbf{Z}_{ij}'\mathbf{b}_i\]

常见类型：

模型 分布 链接函数 应用场景
逻辑混合模型 二项 logit 二分类重复测量
泊松混合模型 泊松 log 计数重复测量

代码实现

# 模拟二分类重复测量数据
set.seed(111)
n_subjects <- 100
n_visits <- 4

subject_id <- factor(rep(1:n_subjects, each = n_visits))
visit <- rep(1:n_visits, n_subjects)

# 随机效应
subject_effect <- rnorm(n_subjects, 0, 1.5)[as.numeric(subject_id)]

# 生成自变量
time_visit <- visit - 1  # 0, 1, 2, 3
treatment_visit <- rep(rbinom(n_subjects, 1, 0.5), each = n_visits)

# 生成二分类结果
linear_pred <- -1 + 0.3 * time_visit - 0.5 * treatment_visit + subject_effect
prob_response <- exp(linear_pred) / (1 + exp(linear_pred))
response <- rbinom(n_subjects * n_visits, 1, prob_response)

glmm_data <- data.frame(
  subject = subject_id,
  visit = visit,
  time = time_visit,
  treatment = factor(treatment_visit, levels = c(0, 1), labels = c("对照", "治疗")),
  response = factor(response, levels = c(0, 1), labels = c("无", "有"))
)

# 拟合逻辑混合模型
model_glmm <- lme4::glmer(response ~ time + treatment + (1 | subject), 
                           data = glmm_data, 
                           family = binomial(link = "logit"))
summary(model_glmm)
## Generalized linear mixed model fit by maximum likelihood (Laplace
##   Approximation) [glmerMod]
##  Family: binomial  ( logit )
## Formula: response ~ time + treatment + (1 | subject)
##    Data: glmm_data
## 
##       AIC       BIC    logLik -2*log(L)  df.resid 
##     483.4     499.4    -237.7     475.4       396 
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -1.7101 -0.5617 -0.3685  0.7519  2.3005 
## 
## Random effects:
##  Groups  Name        Variance Std.Dev.
##  subject (Intercept) 1.875    1.369   
## Number of obs: 400, groups:  subject, 100
## 
## Fixed effects:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept)    -1.2826     0.3475  -3.691 0.000224 ***
## time            0.5075     0.1185   4.283 1.84e-05 ***
## treatment治疗  -0.5034     0.3788  -1.329 0.183825    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##               (Intr) time  
## time          -0.568       
## treatment治疗 -0.582 -0.039
# 提取优势比
cat("\n========== GLMM优势比 ==========\n")
## 
## ========== GLMM优势比 ==========
coef_glmm <- summary(model_glmm)$coefficients
or_glmm <- exp(coef_glmm[, "Estimate"])
ci_glmm <- confint(model_glmm, method = "Wald")
or_ci <- exp(ci_glmm[rownames(coef_glmm), ])
glmm_results <- data.frame(
  OR = or_glmm,
  CI_lower = or_ci[, 1],
  CI_upper = or_ci[, 2]
)
print(glmm_results)
##                      OR  CI_lower  CI_upper
## (Intercept)   0.2773131 0.1403308 0.5480092
## time          1.6610928 1.3168828 2.0952731
## treatment治疗 0.6044649 0.2877143 1.2699324

3.6 模型拟合与推断

意义与使用场景

核心意义：模型拟合与推断用于评估固定效应和随机效应的显著性，是混合效应模型结果解释的关键。

举例：检验多中心临床试验中治疗效果是否显著

为什么这种数据适合用模型推断方法？

首先，混合效应模型的参数估计和推断比传统回归复杂：固定效应的显著性检验需要考虑随机效应的存在，随机效应的检验涉及边界问题。其次，正确推断需要选择合适的检验方法：Wald检验适用于固定效应，似然比检验适用于模型比较。模型拟合与推断方法能够帮助研究者正确评估治疗效果和医院异质性的显著性。

研究目的是什么？

本研究有三个层次的目的：1. 检验固定效应：判断治疗效果是否显著；2. 检验随机效应：判断医院间差异是否需要纳入模型；3. 模型比较：通过AIC或似然比检验选择最优模型。

可能得到什么样的结果？

假设推断结果显示：治疗组系数=-10.2（SE=2.1，p<0.001），随机效应似然比检验p<0.001。

  1. 固定效应检验：治疗组系数显著（p<0.001），治疗有效降低血压。
  2. 随机效应检验：似然比检验p<0.001，医院间差异显著，需要保留随机效应。
  3. 置信区间：治疗效果95%CI=(-14.3, -6.1)，不包含0，确认治疗效果显著。
  4. 模型比较：混合模型AIC比固定效应模型小50，支持使用混合模型。

需要注意什么？

混合模型的自由度计算复杂，常用Satterthwaite近似或Kenward-Roger近似。对于随机效应的似然比检验，由于方差不能为负（边界问题），p值需要除以2。此外，使用REML估计时，比较的模型必须具有相同的固定效应结构；比较不同固定效应结构时需使用ML估计。

数学基础

假设检验：

对于固定效应： - Wald检验：\(z = \frac{\hat{\beta}}{SE(\hat{\beta})}\) - 似然比检验：比较嵌套模型

对于随机效应： - 似然比检验：比较有无随机效应的模型 - 注意：边界问题（方差不能为负），p值需要校正

自由度问题：

混合模型的自由度计算复杂，常用方法： - Satterthwaite近似 - Kenward-Roger近似

代码实现

# 使用lmerTest包获取p值
library(lmerTest)
model_with_p <- lmerTest::lmer(bp ~ age + treatment + (1 | hospital), data = bp_data)
summary(model_with_p)
## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: bp ~ age + treatment + (1 | hospital)
##    Data: bp_data
## 
## REML criterion at convergence: 2270.5
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -2.8610 -0.5937 -0.0102  0.6330  2.6993 
## 
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  hospital (Intercept) 55.96    7.481   
##  Residual             98.86    9.943   
## Number of obs: 300, groups:  hospital, 20
## 
## Fixed effects:
##                Estimate Std. Error        df t value Pr(>|t|)    
## (Intercept)   119.72097    3.39868 171.21190  35.226  < 2e-16 ***
## age             0.52535    0.05085 279.96916  10.332  < 2e-16 ***
## treatment治疗  -9.82240    1.18110 281.42143  -8.316 3.93e-15 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##               (Intr) age   
## age           -0.834       
## treatment治疗 -0.216  0.040
# 固定效应的F检验
anova(model_with_p)
## Type III Analysis of Variance Table with Satterthwaite's method
##            Sum Sq Mean Sq NumDF  DenDF F value    Pr(>F)    
## age       10553.5 10553.5     1 279.97 106.747 < 2.2e-16 ***
## treatment  6837.5  6837.5     1 281.42  69.161 3.935e-15 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
# 似然比检验：比较有无随机效应
model_fixed <- lm(bp ~ age + treatment, data = bp_data)
model_mixed <- lme4::lmer(bp ~ age + treatment + (1 | hospital), 
                           data = bp_data, REML = FALSE)

cat("\n========== 似然比检验（随机效应） ==========\n")
## 
## ========== 似然比检验（随机效应） ==========
cat(sprintf("固定效应模型 logLik: %.2f\n", logLik(model_fixed)))
## 固定效应模型 logLik: -1178.26
cat(sprintf("混合效应模型 logLik: %.2f\n", logLik(model_mixed)))
## 混合效应模型 logLik: -1135.73
cat(sprintf("卡方统计量: %.2f, p < 0.001\n", 2 * (logLik(model_mixed) - logLik(model_fixed))))
## 卡方统计量: 85.06, p < 0.001
# 置信区间
confint_mixed <- confint(model_with_p, method = "Wald")
cat("\n========== 固定效应置信区间 ==========\n")
## 
## ========== 固定效应置信区间 ==========
print(confint_mixed)
##                     2.5 %      97.5 %
## .sig01                 NA          NA
## .sigma                 NA          NA
## (Intercept)   113.0596801 126.3822594
## age             0.4256923   0.6250126
## treatment治疗 -12.1373254  -7.5074802

3.7 预测随机效应（BLUP）

意义与使用场景

核心意义：BLUP（最佳线性无偏预测）用于预测每个组的随机效应值，实现组水平的个性化预测。

举例：估计各医院的治疗效果差异，识别表现优异或落后的医院

为什么这种数据适合用BLUP？

首先，混合效应模型假设医院效应是随机变量，我们不仅关心总体平均效应，还想了解每个医院的具体表现。其次，直接使用各医院的原始数据估计效应可能导致过拟合（样本量小的医院估计不稳定）。BLUP通过”收缩估计”技术，将样本量小的医院效应向均值收缩，避免过拟合，提供更稳定的估计。

研究目的是什么？

本研究有三个层次的目的：1. 估计医院效应：预测每个医院相对于总体平均的偏离程度；2. 识别异常医院：发现表现显著优于或劣于平均的医院；3. 个性化预测：根据医院效应调整预测值，提高预测精度。

可能得到什么样的结果？

假设BLUP估计显示：医院A的随机效应=+5.2 mmHg，医院B的随机效应=-3.8 mmHg，医院C的随机效应=+0.3 mmHg。

  1. 医院A：随机效应+5.2，说明该医院患者血压比总体平均高5.2 mmHg，可能需要重点关注。
  2. 医院B：随机效应-3.8，说明该医院患者血压控制较好，可作为标杆学习。
  3. 医院C：随机效应+0.3，接近总体平均，表现正常。
  4. 收缩效应：样本量小的医院，BLUP值更接近0（向均值收缩），避免极端估计。

需要注意什么？

BLUP是预测值而非估计值，具有收缩特性：样本量越小的组，收缩程度越大。这意味着BLUP不能直接用于排名或比较，特别是当各组样本量差异较大时。此外，BLUP假设随机效应服从正态分布，当这一假设不满足时，预测可能不准确。BLUP的置信区间可用于判断哪些医院的效应显著偏离均值。

数学基础

最佳线性无偏预测（BLUP）：

预测随机效应的值，使得预测误差均方最小。

\[\hat{\mathbf{b}}_i = \mathbf{D}\mathbf{Z}_i'\mathbf{V}_i^{-1}(\mathbf{Y}_i - \mathbf{X}_i\hat{\boldsymbol{\beta}})\]

参数说明： - \(\mathbf{D}\)：随机效应的协方差矩阵 - \(\mathbf{V}_i\)：边际方差矩阵

收缩（Shrinkage）：

BLUP向均值收缩，组内观测越少，收缩越大。

代码实现

# 提取BLUP
blup_values <- lme4::ranef(model_ri)$hospital
colnames(blup_values) <- "random_intercept"

# 合并医院信息
hospital_blup <- data.frame(
  hospital = rownames(blup_values),
  random_intercept = blup_values$random_intercept
)

# 计算每个医院的观测数和均值
hospital_stats <- bp_data %>%
  dplyr::group_by(hospital) %>%
  dplyr::summarise(
    n = dplyr::n(),
    mean_bp = mean(bp),
    .groups = "drop"
  )

# 合并
hospital_blup$hospital <- factor(hospital_blup$hospital)
hospital_stats$hospital <- factor(hospital_stats$hospital)
hospital_combined <- dplyr::left_join(hospital_stats, hospital_blup, by = "hospital")

# 可视化收缩效应
ggplot2::ggplot(hospital_combined, ggplot2::aes(x = mean_bp, y = random_intercept, size = n)) +
  ggplot2::geom_point(alpha = 0.7) +
  ggplot2::geom_hline(yintercept = 0, linetype = "dashed", color = "red") +
  ggplot2::labs(title = "BLUP与医院均值的关系（点大小=样本量）",
                x = "医院平均血压", y = "随机截距(BLUP)", size = "样本量") +
  ggplot2::theme_minimal()

# 条件预测 vs 边际预测
bp_data$pred_marginal <- predict(model_ri, re.form = NA)  # 边际预测（不含随机效应）
bp_data$pred_conditional <- predict(model_ri)              # 条件预测（含随机效应）

# 比较两种预测
cat("\n========== 预测比较 ==========\n")
## 
## ========== 预测比较 ==========
cat(sprintf("边际预测RMSE: %.2f\n", sqrt(mean((bp_data$bp - bp_data$pred_marginal)^2))))
## 边际预测RMSE: 12.29
cat(sprintf("条件预测RMSE: %.2f\n", sqrt(mean((bp_data$bp - bp_data$pred_conditional)^2))))
## 条件预测RMSE: 9.61

3.8 重复测量数据分析

意义与使用场景

核心意义：重复测量数据分析用于处理同一受试者在多个时间点的测量数据，正确处理测量值间的相关性。

举例：临床试验中研究治疗对血压的长期影响

为什么这种数据适合用重复测量分析方法？

首先，同一患者的多次血压测量不独立：相邻时间点的测量值相关性较高，间隔较远的测量值相关性较低。其次，传统方法（如每个时间点单独分析）忽略了测量值间的相关性，会导致标准误估计错误、假阳性增加。重复测量分析方法能够正确建模时间相关性，同时分析所有时间点的数据，提高统计效率。

研究目的是什么？

本研究有三个层次的目的：1. 估计治疗效果：判断治疗组与对照组血压变化轨迹的差异；2. 分析时间趋势：判断血压是否随时间变化，变化趋势如何；3. 检验交互效应：判断治疗效果是否随时间变化（时间×治疗交互）。

可能得到什么样的结果？

假设重复测量分析显示：治疗组系数=5（p<0.001），时间×治疗交互=2（p=0.01），AR(1)相关系数ρ=0.6。

  1. 治疗效应：治疗组比对照组血压平均低5 mmHg。
  2. 时间趋势：对照组血压随时间无显著变化；治疗组血压随时间下降更快。
  3. 交互效应：时间×治疗交互显著，说明治疗效果随时间增强：第1周降低5 mmHg，第4周降低11 mmHg。
  4. 相关结构：AR(1)相关系数ρ=0.6，相邻时间点测量值相关性为0.6，间隔1个时间点相关性为0.36。

需要注意什么？

重复测量数据需要选择合适的相关结构：复合对称（CS）假设任意两时点相关相同，适用于随机效应模型；AR(1)假设相关性随时间衰减，适用于时间序列数据；无结构（UN）最灵活但参数最多。模型选择可通过AIC比较。此外，缺失数据在重复测量中常见，需考虑缺失机制（完全随机缺失、随机缺失、非随机缺失）选择合适的处理方法。

数学基础

重复测量数据的特点：

同一受试者在不同时间点的多次测量，测量值之间存在相关性。

常用相关结构：

结构 特点 参数数量
复合对称（CS） 任意两时点相关相同 2
一阶自回归（AR(1)） 相关性随时间衰减 2
无结构（UN） 任意相关矩阵 \(t(t+1)/2\)

代码实现

# 模拟重复测量数据
set.seed(222)
n_subjects_rm <- 50
n_timepoints <- 4

subject_rm <- factor(rep(1:n_subjects_rm, each = n_timepoints))
time_rm <- rep(1:n_timepoints, n_subjects_rm)
treatment_rm <- factor(rep(rbinom(n_subjects_rm, 1, 0.5), each = n_timepoints),
                       levels = c(0, 1), labels = c("对照", "治疗"))

# 生成相关误差（AR(1)结构）
rho <- 0.6
sigma <- 5
# 创建AR(1)协方差矩阵
ar1_cov <- sigma^2 * rho^abs(outer(1:n_timepoints, 1:n_timepoints, "-"))
# 生成误差
library(MASS)
errors <- MASS::mvrnorm(n_subjects_rm, mu = rep(0, n_timepoints), Sigma = ar1_cov)
errors_vec <- as.vector(t(errors))

# 生成结果
outcome_rm <- 100 + 2 * time_rm + 5 * (treatment_rm == "治疗") * (time_rm - 1) + errors_vec

rm_data <- data.frame(
  subject = subject_rm,
  time = time_rm,
  treatment = treatment_rm,
  outcome = outcome_rm
)

# 使用nlme包拟合不同相关结构
# 复合对称
model_cs <- nlme::lme(outcome ~ time + treatment + time:treatment,
                       random = ~ 1 | subject,
                       correlation = nlme::corCompSymm(form = ~ time | subject),
                       data = rm_data,
                       method = "REML")

# AR(1)结构
model_ar1 <- nlme::lme(outcome ~ time + treatment + time:treatment,
                        random = ~ 1 | subject,
                        correlation = nlme::corAR1(form = ~ time | subject),
                        data = rm_data,
                        method = "REML")

# 无结构
model_un <- nlme::lme(outcome ~ time + treatment + time:treatment,
                       random = ~ 1 | subject,
                       correlation = nlme::corSymm(form = ~ time | subject),
                       data = rm_data,
                       method = "REML")

# 比较模型
cat("========== 相关结构比较 ==========\n")
## ========== 相关结构比较 ==========
cat(sprintf("复合对称 AIC: %.2f\n", AIC(model_cs)))
## 复合对称 AIC: 1164.38
cat(sprintf("AR(1) AIC: %.2f\n", AIC(model_ar1)))
## AR(1) AIC: 1150.56
cat(sprintf("无结构 AIC: %.2f\n", AIC(model_un)))
## 无结构 AIC: 1159.23
# 查看最优模型结果
summary(model_ar1)
## Linear mixed-effects model fit by REML
##   Data: rm_data 
##        AIC      BIC    logLik
##   1150.563 1173.509 -568.2813
## 
## Random effects:
##  Formula: ~1 | subject
##         (Intercept) Residual
## StdDev:     1.80747 4.592091
## 
## Correlation Structure: AR(1)
##  Formula: ~time | subject 
##  Parameter estimate(s):
##       Phi 
## 0.5204014 
## Fixed effects:  outcome ~ time + treatment + time:treatment 
##                       Value Std.Error  DF  t-value p-value
## (Intercept)        99.25632 1.2774438 148 77.69917  0.0000
## time                2.31208 0.4087652 148  5.65626  0.0000
## treatment治疗      -3.52548 1.7714958  48 -1.99011  0.0523
## time:treatment治疗  4.21846 0.5668553 148  7.44186  0.0000
##  Correlation:
##                    (Intr) time   trtm治疗
## time               -0.800                
## treatment治疗      -0.721  0.577         
## time:treatment治疗  0.577 -0.721 -0.800  
## 
## Standardized Within-Group Residuals:
##         Min          Q1         Med          Q3         Max 
## -2.30476044 -0.61333806 -0.05456872  0.61758569  2.40003383 
## 
## Number of Observations: 200
## Number of Groups: 50
# 可视化轨迹
ggplot2::ggplot(rm_data, ggplot2::aes(x = time, y = outcome, group = subject, color = treatment)) +
  ggplot2::geom_line(alpha = 0.3) +
  ggplot2::stat_summary(fun = mean, geom = "line", linewidth = 2) +
  ggplot2::labs(title = "重复测量数据轨迹", x = "时间", y = "结果", color = "治疗组") +
  ggplot2::theme_minimal()

第三章小结

核心知识点总结

主题 核心内容 关键函数
随机截距 组间截距差异 lmer(... + (1|group))
随机斜率 组间斜率差异 lmer(... + (1+x|group))
嵌套设计 多层次嵌套 lmer(... + (1|A/B))
交叉设计 因素交叉 lmer(... + (1|A) + (1|B))
GLMM 非正态混合模型 glmer(family = ...)
BLUP 随机效应预测 ranef()
重复测量 相关结构建模 nlme::lme(correlation = ...)

第四章：时间序列分析

时间序列分析用于研究随时间变化的数据，广泛应用于医学监测、疾病流行趋势分析等领域。本章将系统讲解时间序列的基本概念、平稳性检验、ARIMA模型等内容。

4.1 时间序列分解

意义与使用场景

核心意义：时间序列分解将数据分解为趋势、季节和随机成分，帮助理解数据的基本结构和变化规律。

举例：分析医院月度门诊量的长期趋势和季节波动

为什么这种数据适合用时间序列分解？

首先，门诊量数据随时间变化，包含多种成分：长期趋势（医院发展、人口增长）、季节波动（冬季呼吸道疾病高发）、随机扰动（突发事件）。其次，直接观察原始数据难以识别各成分的贡献。时间序列分解能够将数据拆解为趋势、季节、随机三部分，帮助理解数据结构，为预测建模提供基础。

研究目的是什么？

本研究有三个层次的目的：1. 识别长期趋势：判断门诊量是否呈上升或下降趋势，趋势是线性还是非线性；2. 分析季节模式：识别门诊量的季节波动规律，哪些月份高峰、哪些月份低谷；3. 评估随机波动：判断随机成分的大小，评估预测的不确定性。

可能得到什么样的结果？

假设分解结果显示：趋势成分从1000增长到1600（年均增长5%），季节成分在1月最高（+80）、8月最低（-60）。

  1. 长期趋势：门诊量呈上升趋势，10年间增长60%，年均增长5%。
  2. 季节模式：冬季（12-2月）为高峰期，夏季（7-8月）为低谷期，符合呼吸道疾病流行规律。
  3. 随机波动：残差标准差为30，占均值的2%，波动较小。
  4. 预测启示：预测时需考虑趋势增长和季节波动，可使用乘法模型或加法模型。

需要注意什么？

分解方法的选择：加法模型适用于季节波动幅度不随趋势变化的情况；乘法模型适用于季节波动幅度随趋势增大的情况。STL分解比经典分解更稳健，能够处理季节效应随时间变化的情况。此外，分解结果依赖于季节周期的设定，需确保周期设置正确。

数学基础

时间序列的组成：

\[Y_t = T_t + S_t + R_t \quad \text{（加法模型）}\] \[Y_t = T_t \times S_t \times R_t \quad \text{（乘法模型）}\]

参数说明： - \(T_t\)：趋势成分（Trend） - \(S_t\)：季节成分（Seasonal） - \(R_t\)：随机/残差成分（Random/Residual）

分解方法：

方法 特点
经典分解 简单直观，假设季节效应恒定
STL分解 季节效应可变，稳健性强
X-11/X-13 官方统计常用

代码实现

# 模拟月度门诊量数据（含趋势和季节性）
set.seed(333)
n_months <- 120  # 10年的月度数据

# 趋势成分
trend <- 1000 + 5 * (1:n_months) + 0.1 * (1:n_months)^2 / 10

# 季节成分（12个月周期）
seasonal <- 50 * sin(2 * pi * (1:n_months) / 12) + 
            20 * cos(4 * pi * (1:n_months) / 12)

# 随机成分
random <- rnorm(n_months, 0, 30)

# 合成时间序列
ts_data <- ts(trend + seasonal + random, frequency = 12, start = c(2014, 1))

# 绘制时间序列图
plot(ts_data, main = "月度门诊量时间序列", ylab = "门诊量", xlab = "时间", col = "steelblue")

# 经典分解
decomp_classic <- decompose(ts_data, type = "additive")
plot(decomp_classic)

# STL分解（更稳健）
decomp_stl <- stl(ts_data, s.window = "periodic")
plot(decomp_stl)

# 提取各成分
trend_comp <- decomp_stl$time.series[, "trend"]
seasonal_comp <- decomp_stl$time.series[, "seasonal"]
random_comp <- decomp_stl$time.series[, "remainder"]

# 查看季节效应
cat("========== 季节效应摘要 ==========\n")
## ========== 季节效应摘要 ==========
seasonal_summary <- tapply(as.numeric(seasonal_comp), 
                           cycle(ts_data), mean)
print(round(seasonal_summary, 2))
##      1      2      3      4      5      6      7      8      9     10     11 
##  31.59  42.60  23.05  37.02  32.08   8.41  -3.36 -40.52 -70.17 -45.41 -27.21 
##     12 
##  11.92

4.2 平稳性概念与检验

意义与使用场景

核心意义：平稳性是时间序列建模的基本假设，非平稳数据可能导致虚假回归。

举例：检验疾病发病率序列是否平稳，为ARIMA建模做准备

为什么这种数据适合用平稳性检验？

首先，许多时间序列模型（如ARIMA）假设数据平稳，即均值、方差不随时间变化，自相关结构稳定。其次，医疗数据中的发病率、门诊量等往往存在趋势（非平稳），直接建模可能导致虚假回归。平稳性检验能够判断数据是否满足建模假设，指导差分等预处理步骤。

研究目的是什么？

本研究有三个层次的目的：1. 检验平稳性：判断发病率序列是否存在趋势或单位根；2. 确定差分阶数：若非平稳，确定需要几阶差分使其平稳；3. 避免虚假回归：确保建模结果的可靠性。

可能得到什么样的结果？

假设平稳性检验显示：原始序列ADF检验p值=0.45（非平稳），一阶差分后ADF检验p值=0.01（平稳）。

  1. 原始序列：ADF检验p值>0.05，不能拒绝非平稳假设，序列存在趋势。
  2. 一阶差分：ADF检验p值<0.05，拒绝非平稳假设，差分后序列平稳。
  3. 差分阶数：需要一阶差分（d=1）使序列平稳，ARIMA模型中d=1。
  4. KPSS验证：KPSS检验p值<0.05（原始序列），与ADF结果一致。

需要注意什么？

ADF检验和KPSS检验的原假设相反：ADF原假设为非平稳，KPSS原假设为平稳。建议同时使用两种检验，结果一致时结论更可靠。若检验结果矛盾，需结合图形观察判断。此外，ADF检验对滞后阶数敏感，需选择合适的滞后阶数（通常使用AIC或BIC准则）。

数学基础

严平稳（Strictly Stationary）：

时间序列的联合分布不随时间平移而改变。

弱平稳（Weakly Stationary）：

满足以下条件： 1. \(E(Y_t) = \mu\)（常数均值） 2. \(Var(Y_t) = \sigma^2\)（常数方差） 3. \(Cov(Y_t, Y_{t+k}) = \gamma_k\)（自协方差仅依赖于滞后阶数\(k\)）

单位根检验：

ADF检验（Augmented Dickey-Fuller）： \[H_0: \text{存在单位根（非平稳）}\] \[H_1: \text{不存在单位根（平稳）}\]

KPSS检验： \[H_0: \text{平稳}\] \[H_1: \text{非平稳}\]

代码实现

# 检验平稳性
library(tseries)
library(forecast)

# ADF检验
adf_test <- tseries::adf.test(ts_data)
cat("========== ADF检验 ==========\n")
## ========== ADF检验 ==========
print(adf_test)
## 
##  Augmented Dickey-Fuller Test
## 
## data:  ts_data
## Dickey-Fuller = -6.6307, Lag order = 4, p-value = 0.01
## alternative hypothesis: stationary
# KPSS检验
kpss_test <- tseries::kpss.test(ts_data)
cat("\n========== KPSS检验 ==========\n")
## 
## ========== KPSS检验 ==========
print(kpss_test)
## 
##  KPSS Test for Level Stationarity
## 
## data:  ts_data
## KPSS Level = 2.4427, Truncation lag parameter = 4, p-value = 0.01
# PP检验（Phillips-Perron）
pp_test <- tseries::pp.test(ts_data)
cat("\n========== PP检验 ==========\n")
## 
## ========== PP检验 ==========
print(pp_test)
## 
##  Phillips-Perron Unit Root Test
## 
## data:  ts_data
## Dickey-Fuller Z(alpha) = -51.614, Truncation lag parameter = 4, p-value
## = 0.01
## alternative hypothesis: stationary
# 差分使其平稳
ts_diff <- diff(ts_data)
ts_diff2 <- diff(ts_diff)

# 绘制差分后的序列
par(mfrow = c(2, 1))
plot(ts_diff, main = "一阶差分", ylab = "差分值", col = "steelblue")
plot(ts_diff2, main = "二阶差分", ylab = "差分值", col = "steelblue")

par(mfrow = c(1, 1))

# 检验差分后的平稳性
adf_diff <- tseries::adf.test(ts_diff2)
cat("\n========== 差分后ADF检验 ==========\n")
## 
## ========== 差分后ADF检验 ==========
print(adf_diff)
## 
##  Augmented Dickey-Fuller Test
## 
## data:  ts_diff2
## Dickey-Fuller = -7.4167, Lag order = 4, p-value = 0.01
## alternative hypothesis: stationary

4.3 自相关与偏自相关

意义与使用场景

核心意义：ACF和PACF是识别时间序列模型阶数的关键工具，帮助确定ARIMA模型的参数。

举例：分析传染病发病数据的自相关结构，确定ARIMA模型阶数

为什么这种数据适合用自相关分析？

首先，时间序列数据的特点是相邻观测之间存在相关性：本周发病人数可能与上周、上上周有关。其次，不同类型的时间序列模型（AR、MA、ARMA）具有不同的自相关结构特征。ACF和PACF图形能够揭示数据的自相关模式，帮助识别模型类型和阶数。

研究目的是什么？

本研究有三个层次的目的：1. 识别自相关结构：判断数据是否存在显著的自相关，自相关模式如何；2. 确定模型类型：根据ACF和PACF的形态判断使用AR、MA还是ARMA模型；3. 确定模型阶数：根据ACF和PACF的截尾位置确定模型的阶数p和q。

可能得到什么样的结果？

假设ACF和PACF分析显示：ACF在滞后1-2阶显著后快速衰减，PACF在滞后1阶后截尾。

  1. ACF形态：ACF在滞后1、2阶显著（超过置信区间），之后快速衰减至不显著。
  2. PACF形态：PACF在滞后1阶显著，滞后2阶及之后不显著（截尾）。
  3. 模型识别：PACF截尾→AR模型，截尾位置在滞后1阶→AR(1)模型。
  4. 白噪声检验：Ljung-Box检验p值<0.001，序列非白噪声，存在可建模的自相关结构。

需要注意什么？

ACF和PACF的识别规则是经验性的，实际数据可能不典型。建议结合auto.arima()函数自动选择参数，并比较多种模型的AIC值。此外，季节性数据的ACF和PACF会在季节滞后处（如滞后12、24）出现峰值，需要识别季节性成分。

数学基础

自相关函数（ACF）：

\[\rho_k = \frac{\gamma_k}{\gamma_0} = \frac{Cov(Y_t, Y_{t-k})}{Var(Y_t)}\]

偏自相关函数（PACF）：

控制中间所有滞后项后，\(Y_t\)与\(Y_{t-k}\)的相关系数。

\[\phi_{kk} = Corr(Y_t, Y_{t-k} | Y_{t-1}, Y_{t-2}, \ldots, Y_{t-k+1})\]

模型识别规则：

模型 ACF PACF
AR(p) 拖尾衰减 p阶后截尾
MA(q) q阶后截尾 拖尾衰减
ARMA(p,q) 拖尾衰减 拖尾衰减

代码实现

# 绘制ACF和PACF
par(mfrow = c(2, 2))
acf(ts_data, main = "原始序列ACF", lag.max = 36)
pacf(ts_data, main = "原始序列PACF", lag.max = 36)
acf(ts_diff2, main = "差分序列ACF", lag.max = 36)
pacf(ts_diff2, main = "差分序列PACF", lag.max = 36)

par(mfrow = c(1, 1))

# 白噪声检验
# Ljung-Box检验
lb_test <- Box.test(ts_data, lag = 12, type = "Ljung-Box")
cat("========== Ljung-Box检验 ==========\n")
## ========== Ljung-Box检验 ==========
print(lb_test)
## 
##  Box-Ljung test
## 
## data:  ts_data
## X-squared = 1004.5, df = 12, p-value < 2.2e-16
# 对残差进行白噪声检验
residuals_stl <- decomp_stl$time.series[, "remainder"]
lb_residuals <- Box.test(residuals_stl, lag = 12, type = "Ljung-Box")
cat("\n========== 残差白噪声检验 ==========\n")
## 
## ========== 残差白噪声检验 ==========
print(lb_residuals)
## 
##  Box-Ljung test
## 
## data:  residuals_stl
## X-squared = 19.598, df = 12, p-value = 0.07508

4.4 ARIMA模型

意义与使用场景

核心意义：ARIMA模型是时间序列预测的经典方法，通过自回归、差分和移动平均的组合来建模和预测。

举例：预测医院未来12个月的门诊量

为什么这种数据适合用ARIMA模型？

首先，门诊量数据是典型的时间序列，具有趋势和季节性，经差分后可达到平稳。其次，门诊量存在自相关：本月门诊量可能与上月、去年同期有关。ARIMA模型能够捕捉这种自相关结构，同时处理趋势（通过差分）和季节性（通过季节性ARIMA），是预测门诊量的经典方法。

研究目的是什么？

本研究有三个层次的目的：1. 建立预测模型：根据历史门诊量数据建立ARIMA模型；2. 评估模型拟合：通过残差检验判断模型是否充分捕捉了数据特征；3. 进行预测：预测未来12个月的门诊量，为医院资源配置提供依据。

可能得到什么样的结果？

假设ARIMA(1,1,1)(1,1,0)12模型显示：AR(1)系数=0.6，MA(1)系数=0.3，季节AR(1)系数=0.5，AIC=1250。

  1. 模型结构：ARIMA(1,1,1)(1,1,0)12，包含一阶差分、季节差分和季节自回归。
  2. 参数解释：AR(1)=0.6，说明当月门诊量与上月正相关；季节AR(1)=0.5，说明与去年同期正相关。
  3. 模型诊断：残差Ljung-Box检验p值=0.35，残差为白噪声，模型拟合充分。
  4. 预测结果：预测未来12个月门诊量呈上升趋势，95%置信区间宽度约为±150。

需要注意什么？

ARIMA模型的参数选择可通过ACF/PACF图形或auto.arima()函数确定。auto.arima()基于AIC准则自动选择最优参数，但结果可能与图形分析不同，建议比较多种模型。模型诊断需检验残差是否为白噪声，若残差存在自相关，说明模型未充分拟合。预测的置信区间会随预测期延长而变宽，长期预测不确定性较大。

数学基础

ARIMA(p, d, q)模型：

  • AR(p)自回归：\(Y_t = \phi_1 Y_{t-1} + \cdots + \phi_p Y_{t-p} + \varepsilon_t\)
  • I(d)差分：差分次数使序列平稳
  • MA(q)移动平均：\(Y_t = \varepsilon_t + \theta_1 \varepsilon_{t-1} + \cdots + \theta_q \varepsilon_{t-q}\)

完整形式： \[\phi(B)(1-B)^d Y_t = \theta(B)\varepsilon_t\]

其中： - \(\phi(B) = 1 - \phi_1 B - \cdots - \phi_p B^p\) - \(\theta(B) = 1 + \theta_1 B + \cdots + \theta_q B^q\) - \(B\)：后移算子，\(BY_t = Y_{t-1}\)

代码实现

# 自动选择ARIMA参数
library(forecast)
auto_model <- forecast::auto.arima(ts_data, seasonal = TRUE)
summary(auto_model)
## Series: ts_data 
## ARIMA(1,0,1)(2,1,0)[12] with drift 
## 
## Coefficients:
##          ar1      ma1     sar1     sar2   drift
##       0.9775  -0.8915  -0.7732  -0.4405  6.3351
## s.e.  0.0345   0.0674   0.0899   0.0918  0.4750
## 
## sigma^2 = 1132:  log likelihood = -534.93
## AIC=1081.85   AICc=1082.69   BIC=1097.95
## 
## Training set error measures:
##                    ME     RMSE      MAE          MPE     MAPE      MASE
## Training set 1.263417 31.17644 22.84473 0.0002043013 1.700539 0.2957541
##                    ACF1
## Training set 0.08195347
# 手动拟合ARIMA模型
# 基于ACF/PACF判断：p=1, d=1, q=1
model_arima <- forecast::Arima(ts_data, order = c(1, 1, 1), seasonal = c(1, 1, 0))
summary(model_arima)
## Series: ts_data 
## ARIMA(1,1,1)(1,1,0)[12] 
## 
## Coefficients:
##          ar1      ma1     sar1
##       0.1136  -0.9481  -0.5391
## s.e.  0.1004   0.0325   0.0818
## 
## sigma^2 = 1381:  log likelihood = -540.5
## AIC=1089   AICc=1089.39   BIC=1099.69
## 
## Training set error measures:
##                    ME     RMSE      MAE      MPE     MAPE      MASE
## Training set 4.007443 34.60021 25.47387 0.230051 1.876509 0.3297915
##                      ACF1
## Training set 0.0006771485
# 模型诊断
# 残差检验
checkresiduals(model_arima)

## 
##  Ljung-Box test
## 
## data:  Residuals from ARIMA(1,1,1)(1,1,0)[12]
## Q* = 32.143, df = 21, p-value = 0.05663
## 
## Model df: 3.   Total lags used: 24
# 残差ACF
acf(residuals(model_arima), main = "ARIMA残差ACF")

# Ljung-Box检验
lb_arima <- Box.test(residuals(model_arima), lag = 12, type = "Ljung-Box", fitdf = 2)
cat("\n========== ARIMA残差检验 ==========\n")
## 
## ========== ARIMA残差检验 ==========
print(lb_arima)
## 
##  Box-Ljung test
## 
## data:  residuals(model_arima)
## X-squared = 15.172, df = 10, p-value = 0.1259
# 模型比较
cat("\n========== 模型比较 ==========\n")
## 
## ========== 模型比较 ==========
cat(sprintf("自动选择ARIMA AIC: %.2f\n", AIC(auto_model)))
## 自动选择ARIMA AIC: 1081.85
cat(sprintf("手动ARIMA AIC: %.2f\n", AIC(model_arima)))
## 手动ARIMA AIC: 1089.00

4.5 季节性ARIMA

意义与使用场景

核心意义：季节性ARIMA（SARIMA）扩展了ARIMA模型，专门处理具有季节性周期的时间序列数据。

举例：预测流感季节性爆发的发病人数

为什么这种数据适合用季节性ARIMA模型？

首先，流感发病具有明显的季节性：冬季高发，夏季低发，周期为12个月。其次，流感发病数据同时存在非季节性自相关（本周与上周相关）和季节性自相关（本周与去年同期相关）。SARIMA模型能够同时建模这两种自相关结构，是预测季节性传染病的理想方法。

研究目的是什么？

本研究有三个层次的目的：1. 捕捉季节模式：建模流感发病的年度周期性；2. 区分季节与非季节效应：分别估计非季节性自相关和季节性自相关的参数；3. 提高预测精度：通过季节性建模提高预测准确性。

可能得到什么样的结果？

假设SARIMA(1,0,1)(1,1,0)12模型显示：非季节AR(1)=0.5，非季节MA(1)=0.3，季节AR(1)=0.7。

  1. 非季节效应：AR(1)=0.5，说明本周发病人数与上周正相关，存在短期持续性。
  2. 季节效应：季节AR(1)=0.7，说明本周发病人数与去年同期高度相关，季节性明显。
  3. 季节差分：D=1，说明需要进行季节差分（当年减去去年同期）使序列平稳。
  4. 预测应用：预测显示今年冬季（12-2月）流感发病人数将比去年同期增加15%。

需要注意什么？

SARIMA模型的参数较多（非季节p,d,q和季节P,D,Q），需要足够长的历史数据（至少几个完整周期）来估计。季节周期s的选择应与数据的季节性一致：月度数据s=12，季度数据s=4，周数据s=52。模型选择可使用auto.arima()函数，设置seasonal=TRUE。

数学基础

**SARIMA(p, d, q)(P, D, Q)_s模型**：

\[\phi(B)\Phi(B^s)(1-B)^d(1-B^s)^D Y_t = \theta(B)\Theta(B^s)\varepsilon_t\]

参数说明： - \((p, d, q)\)：非季节部分 - \((P, D, Q)\)：季节部分 - \(s\)：季节周期（如月度数据\(s=12\)）

代码实现

# 拟合季节性ARIMA
model_sarima <- forecast::Arima(ts_data, 
                                 order = c(1, 1, 1), 
                                 seasonal = c(1, 1, 1))
summary(model_sarima)
## Series: ts_data 
## ARIMA(1,1,1)(1,1,1)[12] 
## 
## Coefficients:
##          ar1      ma1     sar1     sma1
##       0.1091  -0.8836  -0.1368  -0.9271
## s.e.  0.1085   0.0545   0.1301   0.4063
## 
## sigma^2 = 950.9:  log likelihood = -529.31
## AIC=1068.62   AICc=1069.21   BIC=1081.98
## 
## Training set error measures:
##                    ME     RMSE      MAE       MPE     MAPE      MASE
## Training set 4.027794 28.56942 20.17855 0.2309524 1.497407 0.2612369
##                     ACF1
## Training set -0.01534729
# 预测
forecast_sarima <- forecast::forecast(model_sarima, h = 24)

# 绘制预测
plot(forecast_sarima, main = "SARIMA预测（24个月）")

# 预测区间
cat("\n========== 预测值及置信区间 ==========\n")
## 
## ========== 预测值及置信区间 ==========
print(forecast_sarima)
##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## Jan 2024       1790.368 1749.954 1830.782 1728.560 1852.176
## Feb 2024       1802.715 1761.288 1844.143 1739.357 1866.074
## Mar 2024       1791.031 1749.214 1832.848 1727.078 1854.985
## Apr 2024       1811.537 1769.384 1853.691 1747.069 1876.005
## May 2024       1811.204 1768.721 1853.686 1746.233 1876.175
## Jun 2024       1791.946 1749.138 1834.755 1726.477 1857.416
## Jul 2024       1776.688 1733.556 1819.819 1710.724 1842.652
## Aug 2024       1753.056 1709.604 1796.508 1686.602 1819.511
## Sep 2024       1726.941 1683.170 1770.711 1659.999 1793.882
## Oct 2024       1758.930 1714.843 1803.017 1691.505 1826.355
## Nov 2024       1779.444 1735.042 1823.845 1711.537 1847.350
## Dec 2024       1827.453 1782.734 1872.171 1759.061 1895.844
## Jan 2025       1859.944 1815.035 1904.854 1791.261 1928.628
## Feb 2025       1876.385 1831.198 1921.573 1807.277 1945.494
## Mar 2025       1866.311 1820.837 1911.786 1796.764 1935.858
## Apr 2025       1884.525 1838.765 1930.286 1814.541 1954.510
## May 2025       1886.073 1840.028 1932.118 1815.654 1956.492
## Jun 2025       1867.303 1820.976 1913.631 1796.452 1938.155
## Jul 2025       1860.492 1813.884 1907.101 1789.211 1931.774
## Aug 2025       1829.234 1782.346 1876.122 1757.525 1900.942
## Sep 2025       1804.096 1756.931 1851.261 1731.963 1876.229
## Oct 2025       1835.412 1787.971 1882.853 1762.857 1907.967
## Nov 2025       1860.927 1813.210 1908.643 1787.950 1933.903
## Dec 2025       1907.490 1859.493 1955.486 1834.086 1980.893
# 模型准确度评估
accuracy_sarima <- forecast::accuracy(forecast_sarima)
cat("\n========== 模型准确度 ==========\n")
## 
## ========== 模型准确度 ==========
print(accuracy_sarima)
##                    ME     RMSE      MAE       MPE     MAPE      MASE
## Training set 4.027794 28.56942 20.17855 0.2309524 1.497407 0.2612369
##                     ACF1
## Training set -0.01534729

4.6 GARCH模型

意义与使用场景

核心意义：GARCH模型用于建模时间序列的波动率聚集现象，即大波动后往往跟随大波动，小波动后跟随小波动。

举例：分析医院急诊就诊量的异常波动

为什么这种数据适合用GARCH模型？

首先，急诊就诊量存在波动聚集现象：某些时期就诊量波动剧烈（如流感爆发期），某些时期波动平稳。其次，传统时间序列模型假设方差恒定，无法捕捉波动率的时变性。GARCH模型能够建模波动率的动态变化，识别高风险时期，为医院应急管理提供依据。

研究目的是什么？

本研究有三个层次的目的：1. 建模波动率：估计急诊就诊量波动率的动态变化规律；2. 识别高风险时期：判断哪些时期波动率异常升高，需要加强应急准备；3. 预测波动率：预测未来时期的波动率，评估风险水平。

可能得到什么样的结果？

假设GARCH(1,1)模型显示：α=0.3（ARCH系数），β=0.6（GARCH系数），α+β=0.9。

  1. 波动持续性：α+β=0.9，接近1，说明波动率具有高度持续性，大波动后会持续一段时间。
  2. 冲击影响：α=0.3，说明突发事件（如流感爆发）对波动率的影响较大。
  3. 波动率预测：当前波动率为50人次/天，预测下周波动率为45人次/天。
  4. 高风险识别：12月-2月波动率显著高于其他月份，与流感季节一致。

需要注意什么？

GARCH模型假设收益率（或波动）均值为零或已建模，适用于建模条件方差。在医疗数据中，需先对原始数据建模均值（如用ARIMA），再对残差建模波动率。GARCH模型的参数需满足约束条件：α+β<1保证平稳性，α>0，β>0。模型选择可通过AIC比较不同阶数的GARCH模型。

数学基础

ARCH模型：

自回归条件异方差模型，用于建模波动率聚集。

\[\sigma_t^2 = \alpha_0 + \alpha_1 \varepsilon_{t-1}^2 + \cdots + \alpha_q \varepsilon_{t-q}^2\]

GARCH(p, q)模型：

\[\sigma_t^2 = \alpha_0 + \sum_{i=1}^{q} \alpha_i \varepsilon_{t-i}^2 + \sum_{j=1}^{p} \beta_j \sigma_{t-j}^2\]

参数说明： - \(\alpha_i\)：ARCH系数（冲击的影响） - \(\beta_j\)：GARCH系数（波动的持续性）

代码实现

# 模拟金融收益率数据（含波动聚集）
set.seed(444)
n_garch <- 500

# GARCH(1,1)参数
omega <- 0.1
alpha <- 0.3
beta <- 0.6

# 生成GARCH过程
returns <- numeric(n_garch)
sigma2 <- numeric(n_garch)
sigma2[1] <- omega / (1 - alpha - beta)

for (t in 2:n_garch) {
  returns[t] <- rnorm(1, 0, sqrt(sigma2[t-1]))
  sigma2[t] <- omega + alpha * returns[t-1]^2 + beta * sigma2[t-1]
}

# 创建时间序列
ts_garch <- ts(returns)

# 绘制收益率和波动率
par(mfrow = c(2, 1))
plot(ts_garch, main = "模拟收益率序列", ylab = "收益率", col = "steelblue")
plot(sqrt(sigma2), type = "l", main = "条件波动率", ylab = "波动率", col = "red")

par(mfrow = c(1, 1))

# 拟合GARCH模型
library(tseries)
library(fGarch)

model_garch <- fGarch::garchFit(~ garch(1, 1), data = ts_garch, trace = FALSE)
summary(model_garch)
## 
## Title:
##  GARCH Modelling 
## 
## Call:
##  fGarch::garchFit(formula = ~garch(1, 1), data = ts_garch, trace = FALSE) 
## 
## Mean and Variance Equation:
##  data ~ garch(1, 1)
## <environment: 0x00000143597bb690>
##  [data = ts_garch]
## 
## Conditional Distribution:
##  norm 
## 
## Coefficient(s):
##       mu     omega    alpha1     beta1  
## 0.036302  0.079514  0.285839  0.626649  
## 
## Std. Errors:
##  based on Hessian 
## 
## Error Analysis:
##         Estimate  Std. Error  t value Pr(>|t|)    
## mu       0.03630     0.03068    1.183  0.23675    
## omega    0.07951     0.02490    3.193  0.00141 ** 
## alpha1   0.28584     0.06191    4.617 3.89e-06 ***
## beta1    0.62665     0.06185   10.131  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Log Likelihood:
##  -599.4667    normalized:  -1.198933 
## 
## Description:
##  Sun Mar 29 19:35:05 2026 by user: XTS-green 
## 
## 
## 
## Standardised Residuals Tests:
##                                  Statistic   p-Value
##  Jarque-Bera Test   R    Chi^2   2.9667297 0.2268730
##  Shapiro-Wilk Test  R    W       0.9953873 0.1454590
##  Ljung-Box Test     R    Q(10)  11.3868843 0.3281808
##  Ljung-Box Test     R    Q(15)  13.3614908 0.5743983
##  Ljung-Box Test     R    Q(20)  22.1278027 0.3336162
##  Ljung-Box Test     R^2  Q(10)  12.8928778 0.2297230
##  Ljung-Box Test     R^2  Q(15)  19.0386900 0.2119860
##  Ljung-Box Test     R^2  Q(20)  23.8860054 0.2474072
##  LM Arch Test       R    TR^2   13.0391041 0.3662049
## 
## Information Criterion Statistics:
##      AIC      BIC      SIC     HQIC 
## 2.413867 2.447584 2.413740 2.427097
# 提取参数
cat("\n========== GARCH参数估计 ==========\n")
## 
## ========== GARCH参数估计 ==========
cat(sprintf("omega = %.4f\n", model_garch@fit$par["omega"]))
## omega = 0.0795
cat(sprintf("alpha1 = %.4f\n", model_garch@fit$par["alpha1"]))
## alpha1 = 0.2858
cat(sprintf("beta1 = %.4f\n", model_garch@fit$par["beta1"]))
## beta1 = 0.6266
# 波动率预测
pred_garch <- predict(model_garch, n.ahead = 20)
plot(pred_garch, main = "GARCH波动率预测")

第四章小结

核心知识点总结

主题 核心内容 关键函数
时间序列分解 趋势、季节、随机 decompose(), stl()
平稳性检验 ADF、KPSS检验 adf.test(), kpss.test()
ACF/PACF 模型识别工具 acf(), pacf()
ARIMA 自回归移动平均 Arima(), auto.arima()
SARIMA 季节性ARIMA Arima(seasonal = ...)
GARCH 条件异方差 garchFit()

第五章：生存分析

生存分析是研究事件发生时间的统计分析方法，广泛应用于医学研究中的生存时间、疾病复发时间等分析。本章将系统讲解生存函数、Cox比例风险模型等核心内容。

5.1 生存函数与风险函数

意义与使用场景

核心意义：生存函数描述生存时间超过某时刻的概率，风险函数描述瞬时事件发生风险，两者是生存分析的基础概念。

举例：研究癌症患者的生存时间及影响因素

为什么这种数据适合用生存分析？

首先，研究终点是”死亡时间”，是典型的时间到事件数据。其次，研究结束时部分患者仍存活（删失数据），传统方法无法正确处理。生存分析能够利用删失数据的信息，正确估计生存概率和风险函数，是分析这类数据的理想方法。

研究目的是什么？

本研究有三个层次的目的：1. 描述生存模式：估计生存函数，判断生存概率随时间的变化规律；2. 评估风险水平：计算风险函数，判断不同时期的死亡风险；3. 识别影响因素：分析哪些因素影响生存时间。

可能得到什么样的结果？

假设生存分析显示：1年生存率=85%，3年生存率=60%，5年生存率=45%，中位生存时间=4.2年。

  1. 生存函数：生存概率随时间递减，前2年下降较慢，2年后下降加快。
  2. 风险函数：风险随时间增加，第1年风险较低，第3-5年风险较高。
  3. 删失比例：研究结束时35%的患者仍存活（删失），生存分析能够利用这部分信息。
  4. 临床意义：早期生存率较高，提示早期干预的重要性。

需要注意什么？

生存分析的核心是正确处理删失数据。删失分为右删失（只知道生存时间大于某值）、左删失（只知道生存时间小于某值）、区间删失（只知道生存时间在某区间内）。最常见的右删失需满足非信息性删失假设：删失原因与生存时间无关。

数学基础

生存函数（Survival Function）：

\[S(t) = P(T > t) = 1 - F(t)\]

表示生存时间超过\(t\)的概率。

风险函数（Hazard Function）：

\[h(t) = \lim_{\Delta t \to 0} \frac{P(t \leq T < t + \Delta t | T \geq t)}{\Delta t} = \frac{f(t)}{S(t)}\]

表示在时刻\(t\)瞬时发生事件的风险。

累积风险函数：

\[H(t) = \int_0^t h(u) du = -\log S(t)\]

关键关系： \[S(t) = \exp\left(-\int_0^t h(u) du\right) = \exp(-H(t))\]

代码实现

# 模拟生存数据
set.seed(555)
n_surv <- 200

# 生成协变量
age_surv <- round(rnorm(n_surv, 60, 10))
treatment_surv <- rbinom(n_surv, 1, 0.5)
stage_surv <- sample(1:3, n_surv, replace = TRUE)  # 疾病分期

# 生成生存时间（Weibull分布）
# 基线风险随年龄和分期增加
lambda <- 0.01 * exp(0.02 * age_surv + 0.5 * stage_surv - 0.5 * treatment_surv)
shape <- 1.5
surv_time <- rweibull(n_surv, shape = shape, scale = lambda^(-1/shape))

# 生成删失时间
censor_time <- runif(n_surv, min = 0, max = 10)
observed_time <- pmin(surv_time, censor_time)
status <- as.numeric(surv_time <= censor_time)  # 1=事件发生，0=删失

# 创建数据框
surv_data <- data.frame(
  patient_id = 1:n_surv,
  age = age_surv,
  treatment = factor(treatment_surv, levels = c(0, 1), labels = c("对照", "治疗")),
  stage = factor(stage_surv, levels = 1:3, labels = c("I期", "II期", "III期")),
  time = observed_time,
  status = status
)

# 查看数据
str(surv_data)
## 'data.frame':    200 obs. of  6 variables:
##  $ patient_id: int  1 2 3 4 5 6 7 8 9 10 ...
##  $ age       : num  57 65 64 79 42 69 58 74 60 66 ...
##  $ treatment : Factor w/ 2 levels "对照","治疗": 2 2 1 2 1 1 1 1 1 2 ...
##  $ stage     : Factor w/ 3 levels "I期","II期","III期": 3 3 1 1 2 2 1 1 2 3 ...
##  $ time      : num  0.994 1.695 2.111 3.537 0.721 ...
##  $ status    : num  0 1 0 0 0 1 1 1 1 0 ...
cat("\n========== 删失情况 ==========\n")
## 
## ========== 删失情况 ==========
cat(sprintf("事件发生: %d (%.1f%%)\n", sum(status), mean(status) * 100))
## 事件发生: 102 (51.0%)
cat(sprintf("删失: %d (%.1f%%)\n", sum(1-status), mean(1-status) * 100))
## 删失: 98 (49.0%)

5.2 Kaplan-Meier估计

意义与使用场景

核心意义：Kaplan-Meier估计是非参数方法，用于估计生存函数，能够处理删失数据。

举例：比较不同治疗组的生存曲线

为什么这种数据适合用Kaplan-Meier估计？

首先，我们需要估计各组的生存概率随时间的变化，但数据中存在删失（研究结束时部分患者仍存活）。其次，我们不想假设生存时间服从特定分布（如指数分布、Weibull分布）。Kaplan-Meier估计是非参数方法，无需分布假设，能够正确处理删失数据，直观展示生存曲线。

研究目的是什么？

本研究有三个层次的目的：1. 估计生存曲线：绘制各组的生存概率随时间变化的曲线；2. 计算中位生存时间：估计各组生存时间的中位数；3. 比较组间差异：初步判断不同治疗组的生存情况是否存在差异。

可能得到什么样的结果？

假设Kaplan-Meier估计显示：治疗组中位生存时间=5.2年，对照组中位生存时间=3.8年。

  1. 生存曲线：治疗组的生存曲线始终位于对照组上方，提示治疗组生存情况更好。
  2. 中位生存时间：治疗组中位生存时间比对照组延长1.4年（37%）。
  3. 生存率比较：治疗组1年生存率=90%，对照组1年生存率=75%；治疗组5年生存率=55%，对照组5年生存率=35%。
  4. 风险表：随时间推移，风险集中人数逐渐减少，需要关注曲线尾部的可靠性。

需要注意什么？

Kaplan-Meier估计的可靠性依赖于风险集中的样本量。当风险集中人数较少时（如曲线尾部），估计的标准误较大，置信区间较宽。此外，Kaplan-Meier曲线只能描述生存情况，不能直接判断组间差异是否显著，需要配合对数秩检验使用。

数学基础

Kaplan-Meier估计量：

\[\hat{S}(t) = \prod_{t_i \leq t} \left(1 - \frac{d_i}{n_i}\right)\]

参数说明： - \(t_i\)：事件发生时间点 - \(d_i\)：在\(t_i\)时刻发生事件的个体数 - \(n_i\)：在\(t_i\)时刻前仍在风险集中的个体数

标准误（Greenwood公式）： \[SE(\hat{S}(t)) = \hat{S}(t) \sqrt{\sum_{t_i \leq t} \frac{d_i}{n_i(n_i - d_i)}}\]

代码实现

library(survival)
library(survminer)

# 创建生存对象
surv_obj <- survival::Surv(surv_data$time, surv_data$status)

# Kaplan-Meier估计
km_fit <- survival::survfit(surv_obj ~ 1, data = surv_data)

# 查看生存曲线摘要
summary(km_fit)
## Call: survfit(formula = surv_obj ~ 1, data = surv_data)
## 
##   time n.risk n.event survival std.err lower 95% CI upper 95% CI
##  0.138    198       1    0.995 0.00504        0.985        1.000
##  0.228    196       1    0.990 0.00712        0.976        1.000
##  0.527    191       1    0.985 0.00877        0.968        1.000
##  0.573    186       1    0.979 0.01020        0.960        1.000
##  0.613    184       1    0.974 0.01145        0.952        0.997
##  0.630    183       1    0.969 0.01256        0.944        0.994
##  0.676    180       1    0.963 0.01360        0.937        0.990
##  0.709    178       1    0.958 0.01456        0.930        0.987
##  0.737    175       1    0.952 0.01547        0.923        0.983
##  0.804    171       1    0.947 0.01635        0.915        0.980
##  0.804    170       1    0.941 0.01718        0.908        0.976
##  0.842    168       1    0.936 0.01797        0.901        0.972
##  0.877    166       1    0.930 0.01872        0.894        0.968
##  0.923    165       1    0.924 0.01944        0.887        0.963
##  0.950    164       1    0.919 0.02012        0.880        0.959
##  0.961    163       1    0.913 0.02077        0.873        0.955
##  1.018    157       1    0.907 0.02144        0.866        0.950
##  1.040    156       1    0.902 0.02208        0.859        0.946
##  1.117    154       1    0.896 0.02269        0.852        0.941
##  1.129    152       1    0.890 0.02330        0.845        0.937
##  1.166    149       1    0.884 0.02389        0.838        0.932
##  1.177    148       1    0.878 0.02447        0.831        0.927
##  1.217    147       1    0.872 0.02502        0.824        0.922
##  1.229    145       1    0.866 0.02556        0.817        0.917
##  1.305    142       1    0.860 0.02610        0.810        0.912
##  1.344    141       1    0.854 0.02661        0.803        0.907
##  1.365    140       1    0.848 0.02711        0.796        0.902
##  1.409    137       1    0.841 0.02761        0.789        0.897
##  1.468    135       1    0.835 0.02810        0.782        0.892
##  1.477    134       1    0.829 0.02858        0.775        0.887
##  1.513    132       1    0.823 0.02904        0.768        0.882
##  1.695    129       1    0.816 0.02951        0.760        0.876
##  1.707    128       1    0.810 0.02996        0.753        0.871
##  1.720    127       1    0.804 0.03039        0.746        0.865
##  1.746    126       1    0.797 0.03081        0.739        0.860
##  1.847    123       1    0.791 0.03124        0.732        0.854
##  1.869    122       1    0.784 0.03165        0.725        0.849
##  1.872    121       1    0.778 0.03204        0.717        0.843
##  1.891    120       1    0.771 0.03242        0.710        0.837
##  1.915    118       1    0.765 0.03280        0.703        0.832
##  2.130    113       1    0.758 0.03320        0.696        0.826
##  2.234    112       1    0.751 0.03359        0.688        0.820
##  2.303    111       1    0.744 0.03396        0.681        0.814
##  2.341    109       1    0.738 0.03433        0.673        0.808
##  2.367    108       1    0.731 0.03468        0.666        0.802
##  2.427    107       1    0.724 0.03503        0.658        0.796
##  2.436    106       1    0.717 0.03535        0.651        0.790
##  2.473    105       1    0.710 0.03567        0.644        0.784
##  2.499    104       1    0.703 0.03598        0.636        0.778
##  2.501    103       1    0.697 0.03627        0.629        0.771
##  2.607    101       1    0.690 0.03656        0.622        0.765
##  2.654    100       1    0.683 0.03684        0.614        0.759
##  2.655     99       1    0.676 0.03711        0.607        0.753
##  2.730     98       1    0.669 0.03736        0.600        0.746
##  2.739     97       1    0.662 0.03761        0.592        0.740
##  2.824     95       1    0.655 0.03785        0.585        0.734
##  2.839     94       1    0.648 0.03809        0.578        0.727
##  2.861     93       1    0.641 0.03831        0.570        0.721
##  2.865     92       1    0.634 0.03852        0.563        0.714
##  2.876     91       1    0.627 0.03872        0.556        0.708
##  2.956     90       1    0.620 0.03892        0.549        0.701
##  2.973     89       1    0.613 0.03910        0.541        0.695
##  3.010     87       1    0.606 0.03928        0.534        0.688
##  3.120     85       1    0.599 0.03946        0.527        0.682
##  3.121     84       1    0.592 0.03963        0.519        0.675
##  3.130     83       1    0.585 0.03979        0.512        0.668
##  3.131     82       1    0.578 0.03994        0.505        0.662
##  3.140     81       1    0.571 0.04008        0.497        0.655
##  3.144     80       1    0.563 0.04020        0.490        0.648
##  3.213     79       1    0.556 0.04032        0.483        0.641
##  3.435     76       1    0.549 0.04045        0.475        0.634
##  3.497     75       1    0.542 0.04057        0.468        0.627
##  3.561     73       1    0.534 0.04069        0.460        0.620
##  3.609     71       1    0.527 0.04080        0.453        0.613
##  3.629     70       1    0.519 0.04091        0.445        0.606
##  3.712     68       1    0.512 0.04101        0.437        0.599
##  3.773     67       1    0.504 0.04111        0.429        0.591
##  3.893     65       1    0.496 0.04120        0.422        0.584
##  3.900     64       1    0.488 0.04128        0.414        0.576
##  3.954     61       1    0.480 0.04137        0.406        0.569
##  4.372     56       1    0.472 0.04151        0.397        0.561
##  4.473     52       1    0.463 0.04169        0.388        0.552
##  4.484     51       1    0.454 0.04185        0.379        0.544
##  4.528     47       1    0.444 0.04206        0.369        0.535
##  4.640     44       1    0.434 0.04230        0.359        0.525
##  4.685     43       1    0.424 0.04250        0.348        0.516
##  4.702     41       1    0.414 0.04270        0.338        0.506
##  4.733     40       1    0.403 0.04287        0.327        0.497
##  4.817     39       1    0.393 0.04300        0.317        0.487
##  4.830     38       1    0.383 0.04309        0.307        0.477
##  4.891     37       1    0.372 0.04315        0.297        0.467
##  4.983     34       1    0.361 0.04325        0.286        0.457
##  5.075     32       1    0.350 0.04334        0.275        0.446
##  5.280     30       1    0.338 0.04344        0.263        0.435
##  5.452     26       1    0.325 0.04367        0.250        0.423
##  5.474     25       1    0.312 0.04382        0.237        0.411
##  5.724     23       1    0.299 0.04397        0.224        0.399
##  5.875     22       1    0.285 0.04402        0.211        0.386
##  6.416     19       1    0.270 0.04418        0.196        0.372
##  7.465     15       1    0.252 0.04476        0.178        0.357
##  7.488     13       1    0.233 0.04532        0.159        0.341
##  7.523     12       1    0.213 0.04550        0.140        0.324
# 绘制生存曲线
survminer::ggsurvplot(km_fit, 
                       data = surv_data,
                       conf.int = TRUE,
                       pval = TRUE,
                       risk.table = TRUE,
                       title = "Kaplan-Meier生存曲线",
                       xlab = "时间（年）",
                       ylab = "生存概率")

# 按治疗组分组
km_treatment <- survival::survfit(surv_obj ~ treatment, data = surv_data)

# 绘制分组生存曲线
survminer::ggsurvplot(km_treatment, 
                       data = surv_data,
                       conf.int = TRUE,
                       pval = TRUE,
                       risk.table = TRUE,
                       legend.title = "治疗组",
                       title = "按治疗组分层的生存曲线",
                       xlab = "时间（年）",
                       ylab = "生存概率")

# 中位生存时间
cat("\n========== 中位生存时间 ==========\n")
## 
## ========== 中位生存时间 ==========
print(km_fit)
## Call: survfit(formula = surv_obj ~ 1, data = surv_data)
## 
##        n events median 0.95LCL 0.95UCL
## [1,] 200    102   3.89    3.14    4.73

5.3 对数秩检验

意义与使用场景

核心意义：对数秩检验用于比较两组或多组生存曲线是否存在显著差异，是生存分析中最常用的假设检验方法。

举例：检验治疗组与对照组的生存曲线是否存在显著差异

为什么这种数据适合用对数秩检验？

首先，Kaplan-Meier曲线只能直观展示组间差异，无法判断差异是否具有统计学意义。其次，我们需要一种能够比较整个生存曲线（而非特定时间点）的方法。对数秩检验通过比较各组在每个事件时间点的观察死亡数与期望死亡数，检验生存曲线是否存在显著差异。

研究目的是什么？

本研究有三个层次的目的：1. 检验组间差异：判断治疗组与对照组的生存曲线是否存在显著差异；2. 计算检验统计量：获得卡方值和p值，做出统计推断；3. 报告结果：为临床决策提供统计学依据。

可能得到什么样的结果？

假设对数秩检验显示：卡方=8.5，自由度=1，p值=0.003。

  1. 检验结果：p值=0.003<0.05，拒绝原假设，治疗组与对照组的生存曲线存在显著差异。
  2. 效应方向：结合Kaplan-Meier曲线，治疗组的生存曲线位于对照组上方，说明治疗组生存情况更好。
  3. 临床意义：治疗组中位生存时间比对照组延长1.4年，差异具有统计学意义和临床意义。
  4. 亚组分析：可进一步按疾病分期分层进行对数秩检验，探索治疗效果在不同分期是否存在差异。

需要注意什么？

对数秩检验是比较整个生存曲线的方法，而非比较特定时间点的生存率。检验假设各组的风险函数成比例（比例风险假设），当假设不满足时，检验效能可能降低。对于多组比较，对数秩检验只能判断是否存在差异，无法识别哪些组之间存在差异，需要事后两两比较。

数学基础

对数秩检验（Log-rank Test）：

比较两组或多组生存曲线是否有差异。

检验统计量： \[\chi^2 = \frac{\left(\sum_{i}(O_{1i} - E_{1i})\right)^2}{\sum_{i}V_i}\]

参数说明： - \(O_{1i}\)：第1组在\(t_i\)时刻的观察事件数 - \(E_{1i}\)：第1组在\(t_i\)时刻的期望事件数 - \(V_i\)：方差

代码实现

# 对数秩检验：治疗组 vs 对照组
logrank <- survival::survdiff(surv_obj ~ treatment, data = surv_data)
cat("========== 对数秩检验（治疗组） ==========\n")
## ========== 对数秩检验（治疗组） ==========
print(logrank)
## Call:
## survival::survdiff(formula = surv_obj ~ treatment, data = surv_data)
## 
##                  N Observed Expected (O-E)^2/E (O-E)^2/V
## treatment=对照 103       67     48.4      7.16      13.7
## treatment=治疗  97       35     53.6      6.46      13.7
## 
##  Chisq= 13.7  on 1 degrees of freedom, p= 2e-04
# 对数秩检验：疾病分期
logrank_stage <- survival::survdiff(surv_obj ~ stage, data = surv_data)
cat("\n========== 对数秩检验（分期） ==========\n")
## 
## ========== 对数秩检验（分期） ==========
print(logrank_stage)
## Call:
## survival::survdiff(formula = surv_obj ~ stage, data = surv_data)
## 
##              N Observed Expected (O-E)^2/E (O-E)^2/V
## stage=I期   72       32     42.0      2.36      4.05
## stage=II期  67       33     40.5      1.37      2.29
## stage=III期 61       37     19.6     15.47     19.69
## 
##  Chisq= 19.8  on 2 degrees of freedom, p= 5e-05
# 趋势检验
logrank_trend <- survival::survdiff(surv_obj ~ stage, data = surv_data, rho = 1)
cat("\n========== 趋势检验 ==========\n")
## 
## ========== 趋势检验 ==========
print(logrank_trend)
## Call:
## survival::survdiff(formula = surv_obj ~ stage, data = surv_data, 
##     rho = 1)
## 
##              N Observed Expected (O-E)^2/E (O-E)^2/V
## stage=I期   72     18.5     27.5      2.92      6.63
## stage=II期  67     21.7     26.9      1.02      2.26
## stage=III期 61     28.8     14.6     13.76     22.79
## 
##  Chisq= 23.1  on 2 degrees of freedom, p= 9e-06

5.4 Cox比例风险模型

意义与使用场景

核心意义：Cox比例风险模型是生存分析中最重要的半参数模型，可同时分析多个协变量对生存时间的影响。

举例：研究年龄、治疗方式、疾病分期对癌症患者生存的影响

为什么这种数据适合用Cox模型？

首先，我们需要同时分析多个因素（年龄、治疗、分期）对生存的影响，控制混杂因素。其次，我们不知道生存时间的具体分布形式，不想做出强假设。Cox模型是半参数方法，不需要指定基线风险函数的形式，同时能够分析多个协变量的影响，是生存分析中最常用的多因素分析方法。

研究目的是什么？

本研究有三个层次的目的：1. 识别危险因素：判断哪些因素与生存时间显著相关；2. 量化风险程度：计算风险比（HR），回答”治疗组死亡风险是对照组的多少倍”；3. 控制混杂：在控制其他因素后，估计每个因素的独立效应。

可能得到什么样的结果？

假设Cox模型显示：年龄HR=1.05（p<0.001），治疗组HR=0.65（p=0.02），III期vs I期HR=2.5（p<0.001）。

  1. 年龄效应：年龄每增加1岁，死亡风险增加5%；增加10岁风险增加63%。
  2. 治疗效应：治疗组死亡风险是对照组的0.65倍（降低35%），治疗有效。
  3. 分期效应：III期患者死亡风险是I期的2.5倍，分期是重要的预后因素。
  4. 多因素分析：在控制年龄和分期后，治疗效果仍然显著，说明治疗有效。

需要注意什么？

Cox模型的核心假设是比例风险假设：风险比不随时间变化。若假设违反（如治疗效果随时间减弱），需使用分层Cox模型或引入时间协变量。风险比的解释需注意方向：HR>1表示风险增加，HR<1表示风险降低。此外，Cox模型不能直接预测生存概率，只能估计风险比。

数学基础

Cox比例风险模型：

\[h(t|\mathbf{X}) = h_0(t) \exp(\beta_1 X_1 + \beta_2 X_2 + \cdots + \beta_p X_p)\]

参数说明： - \(h_0(t)\)：基线风险函数（不指定形式） - \(\exp(\beta_j)\)：风险比（Hazard Ratio, HR）

比例风险假设：

任意两个体的风险比不随时间变化： \[\frac{h(t|\mathbf{X}_1)}{h(t|\mathbf{X}_2)} = \exp(\boldsymbol{\beta}'(\mathbf{X}_1 - \mathbf{X}_2))\]

偏似然函数： \[L(\boldsymbol{\beta}) = \prod_{i=1}^{n} \frac{\exp(\boldsymbol{\beta}'\mathbf{X}_i)}{\sum_{j \in R_i} \exp(\boldsymbol{\beta}'\mathbf{X}_j)}\]

代码实现

# 拟合Cox模型
cox_model <- survival::coxph(surv_obj ~ age + treatment + stage, data = surv_data)
summary(cox_model)
## Call:
## survival::coxph(formula = surv_obj ~ age + treatment + stage, 
##     data = surv_data)
## 
##   n= 200, number of events= 102 
## 
##                    coef exp(coef)  se(coef)      z Pr(>|z|)    
## age            0.006428  1.006449  0.009952  0.646    0.518    
## treatment治疗 -1.116084  0.327560  0.224974 -4.961 7.01e-07 ***
## stageII期      0.269636  1.309488  0.255023  1.057    0.290    
## stageIII期     1.413932  4.112093  0.269329  5.250 1.52e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
##               exp(coef) exp(-coef) lower .95 upper .95
## age              1.0064     0.9936    0.9870    1.0263
## treatment治疗    0.3276     3.0529    0.2108    0.5091
## stageII期        1.3095     0.7637    0.7944    2.1586
## stageIII期       4.1121     0.2432    2.4255    6.9713
## 
## Concordance= 0.67  (se = 0.029 )
## Likelihood ratio test= 43.39  on 4 df,   p=9e-09
## Wald test            = 42.07  on 4 df,   p=2e-08
## Score (logrank) test = 44.3  on 4 df,   p=6e-09
# 提取风险比
hr_table <- broom::tidy(cox_model, exponentiate = TRUE, conf.int = TRUE)
cat("\n========== 风险比（HR）及95%%置信区间 ==========\n")
## 
## ========== 风险比（HR）及95%%置信区间 ==========
print(hr_table)
## # A tibble: 4 × 7
##   term          estimate std.error statistic     p.value conf.low conf.high
##   <chr>            <dbl>     <dbl>     <dbl>       <dbl>    <dbl>     <dbl>
## 1 age              1.01    0.00995     0.646 0.518          0.987     1.03 
## 2 treatment治疗    0.328   0.225      -4.96  0.000000701    0.211     0.509
## 3 stageII期        1.31    0.255       1.06  0.290          0.794     2.16 
## 4 stageIII期       4.11    0.269       5.25  0.000000152    2.43      6.97
# 解释风险比
cat("\n========== 风险比解释 ==========\n")
## 
## ========== 风险比解释 ==========
cat(sprintf("年龄: HR = %.3f，年龄每增加1岁，死亡风险增加%.1f%%\n", 
            hr_table$estimate[1], (hr_table$estimate[1] - 1) * 100))
## 年龄: HR = 1.006，年龄每增加1岁，死亡风险增加0.6%
cat(sprintf("治疗: HR = %.3f，治疗组死亡风险是对照组的%.2f倍\n", 
            hr_table$estimate[2], hr_table$estimate[2]))
## 治疗: HR = 0.328，治疗组死亡风险是对照组的0.33倍
# 绘制森林图
survminer::ggforest(cox_model, data = surv_data, main = "Cox模型森林图")

5.5 比例风险假设检验

意义与使用场景

核心意义：比例风险假设检验用于验证Cox模型的核心假设——风险比是否随时间保持恒定。

举例：检验治疗效果是否随时间变化

为什么这种数据适合用比例风险假设检验？

首先，Cox模型假设风险比不随时间变化，即治疗组与对照组的风险比在任何时间点都相同。其次，某些治疗可能存在时间依赖效应：治疗初期效果好，后期效果减弱（或增强）。比例风险假设检验能够识别这种违反假设的情况，确保模型结果的可靠性。

研究目的是什么？

本研究有三个层次的目的：1. 检验比例风险假设：判断Cox模型的核心假设是否满足；2. 识别违反假设的变量：判断哪些变量的风险比随时间变化；3. 指导模型修正：若假设违反，选择合适的处理方法（分层或时变协变量）。

可能得到什么样的结果？

假设Schoenfeld残差检验显示：年龄p=0.45，治疗p=0.02，分期p=0.68。

  1. 年龄：p=0.45>0.05，比例风险假设满足，年龄的HR不随时间变化。
  2. 治疗：p=0.02<0.05，比例风险假设违反，治疗效果随时间变化。
  3. 分期：p=0.68>0.05，比例风险假设满足。
  4. 残差图：治疗的Schoenfeld残差与时间呈负相关，提示治疗效果随时间减弱。

需要注意什么？

比例风险假设检验的p值<0.05表示假设违反，需要修正模型。修正方法包括：分层（按违反假设的变量分层）、时变协变量（引入时间交互项）、使用其他模型（如加速失效时间模型）。检验的敏感性受样本量影响：大样本可能检测到轻微违反，小样本可能漏检重要违反。

数学基础

Schoenfeld残差检验：

检验比例风险假设是否成立。

\[H_0: \text{比例风险假设成立}\]

如果残差与时间存在系统性关系，则违反比例风险假设。

代码实现

# Schoenfeld残差检验
ph_test <- survival::cox.zph(cox_model)
cat("========== 比例风险假设检验 ==========\n")
## ========== 比例风险假设检验 ==========
print(ph_test)
##           chisq df    p
## age       0.838  1 0.36
## treatment 1.331  1 0.25
## stage     1.746  2 0.42
## GLOBAL    2.926  4 0.57
# 绘制Schoenfeld残差图
plot(ph_test)

# 如果违反比例风险假设，可以使用分层或时变协变量
# 分层Cox模型
cox_stratified <- survival::coxph(surv_obj ~ age + treatment + strata(stage), 
                                   data = surv_data)
summary(cox_stratified)
## Call:
## survival::coxph(formula = surv_obj ~ age + treatment + strata(stage), 
##     data = surv_data)
## 
##   n= 200, number of events= 102 
## 
##                    coef exp(coef)  se(coef)      z Pr(>|z|)    
## age            0.005124  1.005137  0.010103  0.507    0.612    
## treatment治疗 -1.017969  0.361328  0.225858 -4.507 6.57e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
##               exp(coef) exp(-coef) lower .95 upper .95
## age              1.0051     0.9949    0.9854    1.0252
## treatment治疗    0.3613     2.7676    0.2321    0.5625
## 
## Concordance= 0.596  (se = 0.035 )
## Likelihood ratio test= 21.91  on 2 df,   p=2e-05
## Wald test            = 20.34  on 2 df,   p=4e-05
## Score (logrank) test = 21.64  on 2 df,   p=2e-05

5.6 参数生存模型

意义与使用场景

核心意义：参数生存模型假设生存时间服从特定分布，可提供更精确的估计和预测，但需要正确指定分布形式。

举例：预测癌症患者的生存概率

为什么这种数据适合用参数生存模型？

首先，我们需要预测特定时间点的生存概率（如1年、3年、5年生存率），Cox模型需要额外估计基线风险。其次，根据既往研究，该疾病的生存时间大致服从Weibull分布。参数生存模型能够直接估计生存概率，提供更精确的预测，同时可以比较不同分布的拟合优度。

研究目的是什么？

本研究有三个层次的目的：1. 选择合适分布：比较指数、Weibull、对数正态等分布的拟合优度；2. 估计生存概率：预测特定时间点的生存概率和置信区间；3. 比较模型：通过AIC比较参数模型与Cox模型的拟合效果。

可能得到什么样的结果？

假设Weibull模型显示：形状参数γ=1.5，尺度参数λ=0.1，AIC=850（Cox模型AIC=865）。

  1. 分布选择：Weibull分布AIC最小，拟合效果最好。
  2. 风险函数：γ=1.5>1，风险随时间增加，早期风险较低，后期风险较高。
  3. 生存预测：根据模型预测，1年生存率=88%，3年生存率=62%，5年生存率=45%。
  4. 模型比较：Weibull模型AIC比Cox模型低15，说明参数模型拟合更好。

需要注意什么？

参数生存模型的结果依赖于分布假设的正确性。若分布假设错误，估计可能有偏。建议比较多种分布的拟合效果，选择AIC最小的分布。指数分布假设恒定风险，适用性有限；Weibull分布可建模单调风险，适用性较广；对数正态分布可建模非单调风险（先增后减）。

数学基础

常见参数分布：

分布 生存函数 风险函数
指数 \(e^{-\lambda t}\) \(\lambda\)（常数）
Weibull \(e^{-(\lambda t)^\gamma}\) \(\gamma\lambda(\lambda t)^{\gamma-1}\)
对数正态 \(1-\Phi(\frac{\log t - \mu}{\sigma})\) 非单调
对数逻辑 \(\frac{1}{1+(\lambda t)^\gamma}\) 先增后减

代码实现

# 指数分布模型
exp_model <- survival::survreg(surv_obj ~ age + treatment + stage, 
                                data = surv_data, dist = "exponential")
summary(exp_model)
## 
## Call:
## survival::survreg(formula = surv_obj ~ age + treatment + stage, 
##     data = surv_data, dist = "exponential")
##                  Value Std. Error     z       p
## (Intercept)    2.18842    0.63988  3.42 0.00063
## age           -0.00706    0.00980 -0.72 0.47117
## treatment治疗  0.92201    0.21431  4.30 1.7e-05
## stageII期     -0.20314    0.25247 -0.80 0.42106
## stageIII期    -1.05120    0.24795 -4.24 2.2e-05
## 
## Scale fixed at 1 
## 
## Exponential distribution
## Loglik(model)= -267.7   Loglik(intercept only)= -283.9
##  Chisq= 32.34 on 4 degrees of freedom, p= 1.6e-06 
## Number of Newton-Raphson Iterations: 5 
## n= 200
# Weibull分布模型
weibull_model <- survival::survreg(surv_obj ~ age + treatment + stage, 
                                    data = surv_data, dist = "weibull")
summary(weibull_model)
## 
## Call:
## survival::survreg(formula = surv_obj ~ age + treatment + stage, 
##     data = surv_data, dist = "weibull")
##                  Value Std. Error     z       p
## (Intercept)    1.93960    0.40996  4.73 2.2e-06
## age           -0.00453    0.00626 -0.72    0.47
## treatment治疗  0.71439    0.13920  5.13 2.9e-07
## stageII期     -0.16690    0.15792 -1.06    0.29
## stageIII期    -0.93342    0.15905 -5.87 4.4e-09
## Log(scale)    -0.47168    0.07689 -6.13 8.5e-10
## 
## Scale= 0.624 
## 
## Weibull distribution
## Loglik(model)= -252.7   Loglik(intercept only)= -276.4
##  Chisq= 47.29 on 4 degrees of freedom, p= 1.3e-09 
## Number of Newton-Raphson Iterations: 7 
## n= 200
# 对数正态分布模型
lognormal_model <- survival::survreg(surv_obj ~ age + treatment + stage, 
                                      data = surv_data, dist = "lognormal")
summary(lognormal_model)
## 
## Call:
## survival::survreg(formula = surv_obj ~ age + treatment + stage, 
##     data = surv_data, dist = "lognormal")
##                   Value Std. Error     z       p
## (Intercept)    1.384748   0.460945  3.00  0.0027
## age           -0.000299   0.007279 -0.04  0.9672
## treatment治疗  0.637299   0.151300  4.21 2.5e-05
## stageII期     -0.156202   0.179554 -0.87  0.3843
## stageIII期    -0.848148   0.182196 -4.66 3.2e-06
## Log(scale)    -0.136441   0.071191 -1.92  0.0553
## 
## Scale= 0.872 
## 
## Log Normal distribution
## Loglik(model)= -256   Loglik(intercept only)= -274
##  Chisq= 35.99 on 4 degrees of freedom, p= 2.9e-07 
## Number of Newton-Raphson Iterations: 4 
## n= 200
# 模型比较
cat("\n========== 参数模型比较 ==========\n")
## 
## ========== 参数模型比较 ==========
cat(sprintf("指数模型 AIC: %.2f\n", AIC(exp_model)))
## 指数模型 AIC: 545.47
cat(sprintf("Weibull模型 AIC: %.2f\n", AIC(weibull_model)))
## Weibull模型 AIC: 517.41
cat(sprintf("对数正态模型 AIC: %.2f\n", AIC(lognormal_model)))
## 对数正态模型 AIC: 524.07

5.7 竞争风险模型

意义与使用场景

核心意义：竞争风险模型处理存在多种终点事件的情况，一种事件的发生会阻止其他事件的发生。

举例：研究癌症患者的复发和死亡风险

为什么这种数据适合用竞争风险模型？

首先，癌症患者可能发生两种终点事件：复发和死亡，且两者互为竞争风险：患者死亡后无法再观察到复发。其次，传统生存分析将其他事件视为删失，可能导致累积发生率估计偏高。竞争风险模型能够正确估计每种事件的累积发生率，是分析多终点事件的标准方法。

研究目的是什么？

本研究有三个层次的目的：1. 估计累积发生率：分别估计复发和死亡的累积发生率；2. 识别危险因素：分析哪些因素影响复发风险，哪些因素影响死亡风险；3. 比较组间差异：比较治疗组与对照组的累积发生率曲线。

可能得到什么样的结果？

假设竞争风险模型显示：治疗组复发风险SHR=0.65（p=0.03），死亡风险SHR=0.80（p=0.15）。

  1. 复发风险：治疗组复发风险是对照组的0.65倍（降低35%），差异显著。
  2. 死亡风险：治疗组死亡风险是对照组的0.80倍（降低20%），差异不显著。
  3. 累积发生率：3年复发累积发生率治疗组=15%，对照组=25%；3年死亡累积发生率治疗组=10%，对照组=12%。
  4. 临床意义：治疗主要降低复发风险，对死亡风险的影响较小。

需要注意什么？

竞争风险模型的结果解释需注意：累积发生率函数（CIF）与传统生存分析中的生存函数不同，CIF之和可能小于1（因为存在删失）。Fine-Gray模型估计的是亚分布风险比（SHR），与Cox模型的风险比（HR）解释不同。当竞争事件发生率较高时，竞争风险模型与传统生存分析的结果差异较大。

数学基础

竞争风险：

当存在多种可能的事件类型，且一种事件的发生会阻止其他事件发生时。

原因别风险函数： \[h_k(t) = \lim_{\Delta t \to 0} \frac{P(t \leq T < t + \Delta t, K = k | T \geq t)}{\Delta t}\]

累积发生率函数（CIF）： \[F_k(t) = P(T \leq t, K = k) = \int_0^t h_k(u)S(u)du\]

代码实现

# 模拟竞争风险数据
set.seed(666)
n_cr <- 200

age_cr <- rnorm(n_cr, 60, 10)
treatment_cr <- rbinom(n_cr, 1, 0.5)

# 生成两种竞争事件：复发和死亡
# 基线风险
lambda_relapse <- 0.1 * exp(0.02 * age_cr - 0.3 * treatment_cr)
lambda_death <- 0.05 * exp(0.03 * age_cr)

# 生成事件时间
time_relapse <- rexp(n_cr, lambda_relapse)
time_death <- rexp(n_cr, lambda_death)

# 观察到的事件
obs_time <- pmin(time_relapse, time_death)
event_type <- ifelse(time_relapse < time_death, 1, 2)  # 1=复发, 2=死亡

# 创建数据框
cr_data <- data.frame(
  age = age_cr,
  treatment = factor(treatment_cr, levels = c(0, 1), labels = c("对照", "治疗")),
  time = obs_time,
  status = event_type
)

# 使用cmprsk包进行分析
library(cmprsk)

# Fine-Gray模型
fg_model <- cmprsk::crr(cr_data$time, cr_data$status, 
                         cov1 = model.matrix(~ age + treatment, cr_data)[, -1])
summary(fg_model)
## Competing Risks Regression
## 
## Call:
## cmprsk::crr(ftime = cr_data$time, fstatus = cr_data$status, cov1 = model.matrix(~age + 
##     treatment, cr_data)[, -1])
## 
##                   coef exp(coef) se(coef)      z p-value
## age           -0.00179     0.998  0.00929 -0.193  0.8500
## treatment治疗 -0.68100     0.506  0.21645 -3.146  0.0017
## 
##               exp(coef) exp(-coef)  2.5% 97.5%
## age               0.998       1.00 0.980 1.017
## treatment治疗     0.506       1.98 0.331 0.774
## 
## Num. cases = 200
## Pseudo Log-likelihood = -480 
## Pseudo likelihood ratio test = 10.5  on 2 df,
# 累积发生率曲线
cif_fit <- cmprsk::cuminc(cr_data$time, cr_data$status, cr_data$treatment)
plot(cif_fit, xlab = "时间", ylab = "累积发生率", main = "竞争风险累积发生率曲线")

第五章小结

核心知识点总结

主题 核心内容 关键函数
生存函数 生存概率随时间变化 Surv()
Kaplan-Meier 非参数生存估计 survfit()
对数秩检验 比较生存曲线 survdiff()
Cox模型 半参数回归 coxph()
比例风险检验 Schoenfeld残差 cox.zph()
参数模型 指数、Weibull等 survreg()
竞争风险 多种事件类型 crr(), cuminc()

第六章：多元统计分析

多元统计分析用于研究多个变量之间的关系，包括降维、分类、聚类等方法。本章将系统讲解主成分分析、因子分析、聚类分析、判别分析等核心方法。

6.1 主成分分析

意义与使用场景

核心意义：主成分分析（PCA）是一种降维技术，将多个相关变量转换为少数几个不相关的主成分，简化数据结构。

举例：从多个健康指标中提取综合健康指数

为什么这种数据适合用主成分分析？

首先，我们有多个健康指标（血压、BMI、血糖、胆固醇等），这些指标之间存在相关性，信息有重叠。其次，我们需要一个综合指标来评估整体健康状况，便于后续分析和可视化。主成分分析能够将多个相关变量转换为少数几个不相关的主成分，提取主要信息，简化数据结构。

研究目的是什么？

本研究有三个层次的目的：1. 数据降维：将多个健康指标转换为少数几个主成分；2. 提取综合指标：用第一主成分作为综合健康指数；3. 简化后续分析：用主成分代替原始变量进行回归或聚类分析。

可能得到什么样的结果？

假设主成分分析显示：第一主成分解释方差40%，第二主成分解释方差25%，累计解释方差65%。

  1. 第一主成分：载荷显示血压、血糖、胆固醇载荷较高，命名为”代谢综合征指数”。
  2. 第二主成分：载荷显示BMI、血压载荷较高，命名为”肥胖相关指数”。
  3. 累计解释方差：前两个主成分解释了65%的总变异，信息损失可接受。
  4. 综合健康指数：第一主成分得分可作为综合健康指数，得分越高表示代谢风险越高。

需要注意什么？

主成分分析对变量的量纲敏感，不同量纲的变量会导致结果偏向方差大的变量。建议在分析前对变量进行标准化（Z-score标准化）。主成分的解释需要结合载荷矩阵，载荷绝对值越大，该变量对主成分的贡献越大。主成分数量可通过累计解释方差（如>70%）或特征值>1准则确定。

数学基础

主成分分析（PCA）：

将多个相关变量转换为少数几个不相关的主成分。

数学定义：

寻找线性组合： \[PC_1 = a_{11}X_1 + a_{12}X_2 + \cdots + a_{1p}X_p\]

使得\(Var(PC_1)\)最大，且满足\(a_{11}^2 + a_{12}^2 + \cdots + a_{1p}^2 = 1\)。

协方差矩阵分解：

\[\mathbf{S} = \mathbf{A}\mathbf{\Lambda}\mathbf{A}'\]

参数说明： - \(\mathbf{S}\)：协方差矩阵 - \(\mathbf{A}\)：特征向量矩阵（载荷） - \(\mathbf{\Lambda}\)：特征值对角矩阵

方差解释率： \[\text{解释率}_k = \frac{\lambda_k}{\sum_{j=1}^{p}\lambda_j}\]

代码实现

# 模拟健康指标数据
set.seed(777)
n_pca <- 200

# 生成相关的健康指标
sbp <- rnorm(n_pca, 120, 15)          # 收缩压
dbp <- 0.6 * sbp + rnorm(n_pca, 30, 8) # 舒张压（与收缩压相关）
bmi <- rnorm(n_pca, 25, 4)             # BMI
glucose <- 0.3 * bmi + rnorm(n_pca, 90, 15)  # 血糖（与BMI相关）
cholesterol <- rnorm(n_pca, 200, 40)   # 胆固醇
triglyceride <- 0.4 * cholesterol + rnorm(n_pca, 50, 30)  # 甘油三酯
crp <- rnorm(n_pca, 3, 2)              # C反应蛋白

health_data <- data.frame(
  sbp = sbp, dbp = dbp, bmi = bmi, 
  glucose = glucose, cholesterol = cholesterol,
  triglyceride = triglyceride, crp = crp
)

# 查看相关矩阵
cor_matrix <- cor(health_data)
cat("========== 相关矩阵 ==========\n")
## ========== 相关矩阵 ==========
print(round(cor_matrix, 3))
##                 sbp    dbp    bmi glucose cholesterol triglyceride    crp
## sbp           1.000  0.704 -0.099   0.069       0.014       -0.018  0.032
## dbp           0.704  1.000 -0.106   0.085       0.015        0.041  0.058
## bmi          -0.099 -0.106  1.000   0.149      -0.049       -0.081 -0.022
## glucose       0.069  0.085  0.149   1.000      -0.109       -0.103 -0.021
## cholesterol   0.014  0.015 -0.049  -0.109       1.000        0.454  0.019
## triglyceride -0.018  0.041 -0.081  -0.103       0.454        1.000 -0.004
## crp           0.032  0.058 -0.022  -0.021       0.019       -0.004  1.000
# 主成分分析
pca_result <- prcomp(health_data, scale. = TRUE, center = TRUE)

# 查看结果
summary(pca_result)
## Importance of components:
##                          PC1    PC2    PC3    PC4    PC5     PC6     PC7
## Standard deviation     1.323 1.2372 1.0387 0.9953 0.9009 0.74000 0.53938
## Proportion of Variance 0.250 0.2187 0.1541 0.1415 0.1160 0.07823 0.04156
## Cumulative Proportion  0.250 0.4686 0.6227 0.7642 0.8802 0.95844 1.00000
# 特征值和方差解释
eigenvalues <- pca_result$sdev^2
var_explained <- eigenvalues / sum(eigenvalues)
cum_var <- cumsum(var_explained)

pca_summary <- data.frame(
  PC = 1:length(eigenvalues),
  Eigenvalue = eigenvalues,
  Variance = var_explained,
  Cumulative = cum_var
)
cat("\n========== 方差解释 ==========\n")
## 
## ========== 方差解释 ==========
print(round(pca_summary, 4))
##   PC Eigenvalue Variance Cumulative
## 1  1     1.7497   0.2500     0.2500
## 2  2     1.5306   0.2187     0.4686
## 3  3     1.0789   0.1541     0.6227
## 4  4     0.9906   0.1415     0.7643
## 5  5     0.8117   0.1160     0.8802
## 6  6     0.5476   0.0782     0.9584
## 7  7     0.2909   0.0416     1.0000
# 碎石图
plot(eigenvalues, type = "b", main = "碎石图", 
     xlab = "主成分", ylab = "特征值")
abline(h = 1, col = "red", lty = 2)

# 载荷矩阵
loadings <- pca_result$rotation
cat("\n========== 载荷矩阵 ==========\n")
## 
## ========== 载荷矩阵 ==========
print(round(loadings[, 1:3], 3))
##                 PC1    PC2    PC3
## sbp           0.682 -0.096  0.028
## dbp           0.689 -0.067  0.047
## bmi          -0.187 -0.223  0.645
## glucose       0.081 -0.343  0.601
## cholesterol   0.075  0.637  0.294
## triglyceride  0.075  0.643  0.273
## crp           0.087  0.027 -0.243
# 主成分得分
scores <- pca_result$x

# 绘制双标图
biplot(pca_result, scale = 0, main = "PCA双标图")

6.2 因子分析

意义与使用场景

核心意义：因子分析用于探索观测变量背后的潜在因子结构，揭示变量间的潜在关系。

举例：心理量表开发中提取潜在心理维度

为什么这种数据适合用因子分析？

首先，心理量表包含多个条目（如”我感到焦虑”、“我难以入睡”等），这些条目可能反映几个潜在的心理维度（如焦虑、抑郁）。其次，我们需要探索量表的结构效度，验证条目是否按预期归入不同因子。因子分析能够揭示观测变量背后的潜在因子结构，是量表开发和验证的标准方法。

研究目的是什么？

本研究有三个层次的目的：1. 探索因子结构：确定量表包含几个潜在因子；2. 验证条目归属：判断每个条目归属于哪个因子；3. 评估量表质量：计算因子载荷和共同度，评估条目质量。

可能得到什么样的结果？

假设因子分析显示：提取2个因子，累计解释方差55%，因子间相关r=0.4。

  1. 因子结构：条目1-5在因子1上载荷较高（>0.6），命名为”焦虑因子”；条目6-10在因子2上载荷较高，命名为”抑郁因子”。
  2. 因子载荷：大部分条目的因子载荷>0.5，说明条目与因子的关联较强。
  3. 共同度：大部分条目的共同度>0.4，说明条目的变异能被因子较好地解释。
  4. 因子相关：两因子相关r=0.4，说明焦虑和抑郁存在中等程度相关。

需要注意什么？

因子分析需要足够的样本量，一般建议样本量至少为变量数的5-10倍。因子数量可通过平行分析、特征值>1准则或理论预期确定。正交旋转（Varimax）假设因子不相关，斜交旋转（Promax）允许因子相关，实际应用中斜交旋转更符合心理现象。

数学基础

因子分析模型：

\[\mathbf{X} = \mathbf{\Lambda}\mathbf{F} + \mathbf{\varepsilon}\]

参数说明： - \(\mathbf{X}\)：观测变量 - \(\mathbf{\Lambda}\)：因子载荷矩阵 - \(\mathbf{F}\)：公共因子 - \(\mathbf{\varepsilon}\)：特殊因子（误差）

因子旋转：

方法 特点
方差最大旋转（Varimax） 正交旋转，简化载荷
斜交旋转（Promax/Oblimin） 允许因子相关

因子得分：

估计个体在公共因子上的值。

代码实现

# 探索性因子分析
library(psych)

# 确定因子数量
fa_parallel <- psych::fa.parallel(health_data, fa = "fa", main = "平行分析")

## Parallel analysis suggests that the number of factors =  2  and the number of components =  NA
# 提取2个因子
fa_result <- psych::fa(health_data, nfactors = 2, rotate = "varimax", fm = "ml")

# 查看结果
print(fa_result)
## Factor Analysis using method =  ml
## Call: psych::fa(r = health_data, nfactors = 2, rotate = "varimax", 
##     fm = "ml")
## Standardized loadings (pattern matrix) based upon correlation matrix
##                ML1   ML2     h2    u2 com
## sbp           0.73 -0.09 0.5383 0.462 1.0
## dbp           0.96 -0.06 0.9242 0.076 1.0
## bmi          -0.12 -0.10 0.0240 0.976 1.9
## glucose       0.08 -0.17 0.0348 0.965 1.4
## cholesterol   0.06  0.61 0.3719 0.628 1.0
## triglyceride  0.09  0.74 0.5496 0.450 1.0
## crp           0.06  0.00 0.0035 0.997 1.0
## 
##                        ML1  ML2
## SS loadings           1.49 0.96
## Proportion Var        0.21 0.14
## Cumulative Var        0.21 0.35
## Proportion Explained  0.61 0.39
## Cumulative Proportion 0.61 1.00
## 
## Mean item complexity =  1.2
## Test of the hypothesis that 2 factors are sufficient.
## 
## df null model =  21  with the objective function =  0.99 with Chi Square =  194.64
## df of  the model are 8  and the objective function was  0.03 
## 
## The root mean square of the residuals (RMSR) is  0.03 
## The df corrected root mean square of the residuals is  0.05 
## 
## The harmonic n.obs is  200 with the empirical chi square  4.68  with prob <  0.79 
## The total n.obs was  200  with Likelihood Chi Square =  5.77  with prob <  0.67 
## 
## Tucker Lewis Index of factoring reliability =  1.034
## RMSEA index =  0  and the 90 % confidence intervals are  0 0.066
## BIC =  -36.62
## Fit based upon off diagonal values = 0.97
## Measures of factor score adequacy             
##                                                    ML1  ML2
## Correlation of (regression) scores with factors   0.96 0.81
## Multiple R square of scores with factors          0.93 0.65
## Minimum correlation of possible factor scores     0.86 0.30
# 因子载荷
cat("\n========== 因子载荷 ==========\n")
## 
## ========== 因子载荷 ==========
print(round(fa_result$loadings, 3))
## 
## Loadings:
##              ML1    ML2   
## sbp           0.729       
## dbp           0.960       
## bmi          -0.119 -0.100
## glucose             -0.170
## cholesterol          0.607
## triglyceride         0.736
## crp                       
## 
##                  ML1   ML2
## SS loadings    1.487 0.960
## Proportion Var 0.212 0.137
## Cumulative Var 0.212 0.350
# 方差解释
cat("\n========== 方差解释 ==========\n")
## 
## ========== 方差解释 ==========
print(fa_result$Vaccounted)
##                             ML1       ML2
## SS loadings           1.4854592 0.9607829
## Proportion Var        0.2122085 0.1372547
## Cumulative Var        0.2122085 0.3494632
## Proportion Explained  0.6072413 0.3927587
## Cumulative Proportion 0.6072413 1.0000000
# 绘制因子载荷图
psych::fa.diagram(fa_result)

# 斜交旋转
fa_oblique <- psych::fa(health_data, nfactors = 2, rotate = "promax", fm = "ml")
cat("\n========== 斜交旋转因子载荷 ==========\n")
## 
## ========== 斜交旋转因子载荷 ==========
print(round(fa_oblique$loadings, 3))
## 
## Loadings:
##              ML1    ML2   
## sbp           0.733 -0.115
## dbp           0.964       
## bmi          -0.115       
## glucose             -0.173
## cholesterol          0.606
## triglyceride         0.735
## crp                       
## 
##                  ML1   ML2
## SS loadings    1.495 0.969
## Proportion Var 0.214 0.138
## Cumulative Var 0.214 0.352
# 因子间相关
cat("\n========== 因子间相关 ==========\n")
## 
## ========== 因子间相关 ==========
print(round(fa_oblique$Phi, 3))
##       ML1   ML2
## ML1 1.000 0.073
## ML2 0.073 1.000
# 计算因子得分
factor_scores <- factor.scores(health_data, fa_result)
head(factor_scores$scores)
##             ML1         ML2
## [1,]  0.2371443 -1.21209869
## [2,]  0.5687909 -0.49879278
## [3,]  0.3364426  0.82119205
## [4,] -0.5301159  0.01436721
## [5,]  0.7783406 -0.57864714
## [6,] -0.2129023 -0.09287515

6.3 聚类分析

意义与使用场景

核心意义：聚类分析将相似的观测对象分组，发现数据中的自然分组结构，是无监督学习的核心方法。

举例：糖尿病患者亚型识别

为什么这种数据适合用聚类分析？

首先，糖尿病是一种异质性疾病，可能存在不同的亚型，但亚型数量和特征未知。其次，我们有多个临床指标（年龄、BMI、血糖、胰岛素水平等），需要根据这些指标将患者分组。聚类分析是无监督学习方法，能够在没有预先定义类别的情况下，发现数据中的自然分组结构。

研究目的是什么？

本研究有三个层次的目的：1. 发现亚型：识别糖尿病患者中是否存在不同的亚型；2. 描述亚型特征：分析各亚型在临床指标上的差异；3. 临床应用：为精准医疗提供依据，不同亚型可能需要不同的治疗方案。

可能得到什么样的结果？

假设聚类分析显示：最优聚类数为3，轮廓系数=0.65。

  1. 亚型1（经典型）：年龄较大、BMI正常、胰岛素分泌减少，占40%。
  2. 亚型2（肥胖相关型）：年龄较轻、BMI较高、胰岛素抵抗明显，占35%。
  3. 亚型3（轻度肥胖型）：年龄中等、BMI轻度升高、代谢指标相对较好，占25%。
  4. 临床意义：亚型2可能需要更积极的减重干预，亚型1可能需要更早启动胰岛素治疗。

需要注意什么？

聚类分析的结果依赖于距离度量（如欧氏距离、马氏距离）和聚类方法（如层次聚类、K-means）。不同方法可能得到不同的结果，建议尝试多种方法并比较。聚类数量可通过轮廓系数、肘部法则或Gap统计量确定。聚类结果需要结合专业知识解释，确保分型具有临床意义。

数学基础

层次聚类：

自底向上（凝聚）或自顶向下（分裂）构建聚类树。

距离度量： \[d_{ij} = \sqrt{\sum_{k=1}^{p}(x_{ik} - x_{jk})^2} \quad \text{（欧氏距离）}\]

链接方法：

方法 定义
单链接 类间最小距离
全链接 类间最大距离
平均链接 类间平均距离
Ward方法 最小化类内方差

K-means聚类：

最小化类内平方和： \[W(C) = \sum_{k=1}^{K}\sum_{i \in C_k} ||\mathbf{x}_i - \boldsymbol{\mu}_k||^2\]

代码实现

# 标准化数据
health_scaled <- scale(health_data)

# 层次聚类
dist_matrix <- dist(health_scaled, method = "euclidean")
hc_complete <- hclust(dist_matrix, method = "complete")

# 绘制树状图
plot(hc_complete, main = "层次聚类树状图", xlab = "样本", cex = 0.6)

# 切割树状图
clusters_hc <- cutree(hc_complete, k = 3)
table(clusters_hc)
## clusters_hc
##   1   2   3 
## 108  21  71
# K-means聚类
set.seed(888)
km_result <- kmeans(health_scaled, centers = 3, nstart = 25)

# 查看结果
cat("========== K-means聚类结果 ==========\n")
## ========== K-means聚类结果 ==========
print(km_result$centers)
##          sbp        dbp         bmi    glucose cholesterol triglyceride
## 1  0.2950832  0.3057690  0.38234893  0.7806327  -0.8965902   -0.9658988
## 2  0.8076646  0.7328541 -0.30581313 -0.1847194   0.4423954    0.4182768
## 3 -0.8828170 -0.8235747  0.04148128 -0.3006827   0.1435340    0.2057467
##            crp
## 1  0.142779377
## 2 -0.105916114
## 3  0.008230049
cat("\n各类别样本数：\n")
## 
## 各类别样本数：
print(table(km_result$cluster))
## 
##  1  2  3 
## 48 71 81
# 确定最优聚类数
library(factoextra)
fviz_nbclust(health_scaled, kmeans, method = "wss") +
  ggplot2::labs(title = "肘部法则")

fviz_nbclust(health_scaled, kmeans, method = "silhouette") +
  ggplot2::labs(title = "轮廓系数")

# 可视化聚类结果
fviz_cluster(km_result, data = health_scaled,
             palette = "jco", ellipse.type = "convex",
             main = "K-means聚类结果")

# 比较两种聚类方法
cat("\n========== 聚类方法比较 ==========\n")
## 
## ========== 聚类方法比较 ==========
cat("调整兰德指数（ARI）：\n")
## 调整兰德指数（ARI）：
library(mclust)
ari <- mclust::adjustedRandIndex(clusters_hc, km_result$cluster)
cat(sprintf("ARI = %.3f\n", ari))
## ARI = 0.266

6.4 判别分析

意义与使用场景

核心意义：判别分析用于根据多个变量对观测对象进行分类，是有监督的分类方法。

举例：良性与恶性肿瘤的鉴别诊断

为什么这种数据适合用判别分析？

首先，我们有已知的肿瘤类型标签（良性/恶性），需要建立分类规则。其次，我们有多个诊断指标（肿瘤大小、形状、边界、密度等），需要综合这些指标进行判断。判别分析能够根据已知类别的样本，建立最优的分类规则，对新样本进行分类，是医学诊断的常用方法。

研究目的是什么？

本研究有三个层次的目的：1. 建立分类规则：根据多个指标建立肿瘤良恶性的判别函数；2. 评估分类准确性：计算训练集和测试集的分类准确率；3. 识别关键指标：判断哪些指标对分类贡献最大。

可能得到什么样的结果？

假设LDA模型显示：整体准确率=92%，敏感性=88%，特异性=95%。

  1. 判别函数：LD1 = 0.5×肿瘤大小 + 0.8×边界不规则度 - 0.3×密度，LD1是主要的判别维度。
  2. 分类准确性：整体准确率92%，良性肿瘤识别率95%，恶性肿瘤识别率88%。
  3. 关键指标：边界不规则度对判别贡献最大，其次是肿瘤大小。
  4. 临床应用：判别函数可用于辅助诊断，但需结合临床经验。

需要注意什么？

LDA假设各组协方差矩阵相等，若假设违反需使用QDA。判别分析的结果需要用独立测试集验证，避免过拟合。对于不平衡数据，准确率可能误导，应关注敏感性和特异性。判别分析假设自变量服从多元正态分布，严重偏离时可能影响结果。

数学基础

线性判别分析（LDA）：

寻找线性组合最大化组间方差与组内方差之比。

\[\max_{\mathbf{a}} \frac{\mathbf{a}'\mathbf{B}\mathbf{a}}{\mathbf{a}'\mathbf{W}\mathbf{a}}\]

参数说明： - \(\mathbf{B}\)：组间协方差矩阵 - \(\mathbf{W}\)：组内协方差矩阵

判别函数： \[\delta_k(\mathbf{x}) = \mathbf{x}'\mathbf{W}^{-1}\boldsymbol{\mu}_k - \frac{1}{2}\boldsymbol{\mu}_k'\mathbf{W}^{-1}\boldsymbol{\mu}_k + \log\pi_k\]

二次判别分析（QDA）：

假设各组协方差矩阵不同。

代码实现

# 模拟疾病分类数据
set.seed(999)
n_da <- 150

# 生成三组疾病类型
group <- factor(rep(1:3, each = 50))

# 生成与组相关的指标
marker1 <- c(rnorm(50, 10, 2), rnorm(50, 15, 2), rnorm(50, 20, 2))
marker2 <- c(rnorm(50, 5, 1.5), rnorm(50, 8, 1.5), rnorm(50, 6, 1.5))
marker3 <- c(rnorm(50, 100, 15), rnorm(50, 120, 15), rnorm(50, 90, 15))

disease_data <- data.frame(
  group = group,
  marker1 = marker1,
  marker2 = marker2,
  marker3 = marker3
)

# 线性判别分析
library(MASS)
lda_model <- MASS::lda(group ~ marker1 + marker2 + marker3, data = disease_data)
print(lda_model)
## Call:
## lda(group ~ marker1 + marker2 + marker3, data = disease_data)
## 
## Prior probabilities of groups:
##         1         2         3 
## 0.3333333 0.3333333 0.3333333 
## 
## Group means:
##     marker1  marker2   marker3
## 1  9.484663 5.044950  99.77728
## 2 15.086562 7.937900 120.43636
## 3 19.667422 5.686237  90.23225
## 
## Coefficients of linear discriminants:
##                 LD1         LD2
## marker1 0.524139686  0.02361893
## marker2 0.086580905 -0.46340341
## marker3 0.006980749 -0.04797410
## 
## Proportion of trace:
##    LD1    LD2 
## 0.7869 0.2131
# 预测
lda_pred <- predict(lda_model, disease_data)

# 混淆矩阵
cat("\n========== LDA混淆矩阵 ==========\n")
## 
## ========== LDA混淆矩阵 ==========
print(table(真实 = disease_data$group, 预测 = lda_pred$class))
##     预测
## 真实  1  2  3
##    1 48  1  1
##    2  1 44  5
##    3  1  1 48
# 准确率
lda_acc <- mean(disease_data$group == lda_pred$class)
cat(sprintf("\nLDA准确率: %.2f%%\n", lda_acc * 100))
## 
## LDA准确率: 93.33%
# 二次判别分析
qda_model <- MASS::qda(group ~ marker1 + marker2 + marker3, data = disease_data)
qda_pred <- predict(qda_model, disease_data)

cat("\n========== QDA混淆矩阵 ==========\n")
## 
## ========== QDA混淆矩阵 ==========
print(table(真实 = disease_data$group, 预测 = qda_pred$class))
##     预测
## 真实  1  2  3
##    1 48  1  1
##    2  1 46  3
##    3  0  2 48
qda_acc <- mean(disease_data$group == qda_pred$class)
cat(sprintf("\nQDA准确率: %.2f%%\n", qda_acc * 100))
## 
## QDA准确率: 94.67%
# 可视化判别结果
lda_df <- data.frame(
  LD1 = predict(lda_model)$x[, 1],
  LD2 = predict(lda_model)$x[, 2],
  group = disease_data$group
)
ggplot2::ggplot(lda_df, ggplot2::aes(x = LD1, y = LD2, color = group, fill = group)) +
  ggplot2::geom_point(size = 3, alpha = 0.7) +
  ggplot2::stat_ellipse(geom = "polygon", alpha = 0.2, level = 0.95) +
  ggplot2::labs(title = "LDA判别图", x = "LD1", y = "LD2") +
  ggplot2::theme_minimal()

6.5 多维尺度分析

意义与使用场景

核心意义：多维尺度分析（MDS）将高维数据的距离关系映射到低维空间，便于可视化展示数据结构。

举例：疾病症状的相似性可视化

为什么这种数据适合用多维尺度分析？

首先，我们有多种疾病，每种疾病有多种症状表现，形成高维数据。其次，我们需要直观展示疾病之间的相似性关系，发现疾病的聚类结构。多维尺度分析能够将高维的距离关系映射到二维空间，便于可视化和解释，是探索数据结构的有效方法。

研究目的是什么？

本研究有三个层次的目的：1. 可视化相似性：将疾病之间的相似性关系在二维空间中展示；2. 发现聚类结构：识别相似的疾病群组；3. 解释维度含义：分析二维空间的维度代表什么含义。

可能得到什么样的结果？

假设MDS分析显示：应力值=0.12，二维解释效果良好。

  1. 空间分布：相似疾病在图中距离较近，如流感和普通感冒聚集在一起。
  2. 维度解释：第一维度可能代表”严重程度”，第二维度可能代表”传染性”。
  3. 聚类结构：图中可识别出3-4个疾病群组，如呼吸道疾病、消化道疾病、皮肤疾病等。
  4. 异常点：某疾病位置孤立，可能具有独特的症状特征。

需要注意什么？

MDS的结果依赖于距离度量的选择，常用欧氏距离、马氏距离或自定义距离。应力值（Stress）评估拟合优度，一般要求<0.2。MDS只能展示相对位置，不能直接解释为绝对距离。对于大数据集，建议先进行降维或采样，再进行MDS分析。

核心目标：在低维空间中尽可能保持原始数据的距离关系

数学基础

多维尺度分析（MDS）：

将高维距离矩阵映射到低维空间，保持距离关系。

经典MDS：

最小化应力函数： \[Stress = \sqrt{\frac{\sum_{i<j}(d_{ij} - \hat{d}_{ij})^2}{\sum_{i<j}d_{ij}^2}}\]

参数说明： - \(d_{ij}\)：原始距离 - \(\hat{d}_{ij}\)：低维空间中的距离

代码实现

# 经典MDS
mds_result <- cmdscale(dist_matrix, k = 2, eig = TRUE)

# 查看结果
cat("========== MDS结果 ==========\n")
## ========== MDS结果 ==========
cat(sprintf("应力值: %.4f\n", mds_result$GOF[1]))
## 应力值: 0.4686
# 可视化
mds_df <- data.frame(
  MDS1 = mds_result$points[, 1],
  MDS2 = mds_result$points[, 2],
  Cluster = factor(km_result$cluster)
)

ggplot2::ggplot(mds_df, ggplot2::aes(x = MDS1, y = MDS2, color = Cluster)) +
  ggplot2::geom_point(size = 3, alpha = 0.7) +
  ggplot2::labs(title = "多维尺度分析结果", x = "MDS1", y = "MDS2") +
  ggplot2::theme_minimal()

# 非度量MDS
library(MASS)
nmds_result <- MASS::isoMDS(dist_matrix, k = 2)
## initial  value 29.755913 
## iter   5 value 25.315123
## final  value 24.770606 
## converged
nmds_df <- data.frame(
  NMDS1 = nmds_result$points[, 1],
  NMDS2 = nmds_result$points[, 2],
  Cluster = factor(km_result$cluster)
)

ggplot2::ggplot(nmds_df, ggplot2::aes(x = NMDS1, y = NMDS2, color = Cluster)) +
  ggplot2::geom_point(size = 3, alpha = 0.7) +
  ggplot2::labs(title = "非度量MDS结果", x = "NMDS1", y = "NMDS2") +
  ggplot2::theme_minimal()

第六章小结

核心知识点总结

主题 核心内容 关键函数
主成分分析 降维、特征提取 prcomp()
因子分析 潜变量提取 psych::fa()
层次聚类 树状结构聚类 hclust()
K-means 快速聚类 kmeans()
判别分析 分类预测 MASS::lda()
MDS 距离可视化 cmdscale()

第七章：面板数据模型

面板数据（Panel Data）是同时在时间和个体维度上观测的数据，广泛应用于经济学、医学研究等领域。本章将系统讲解固定效应、随机效应、动态面板等模型。

7.1 面板数据结构

意义与使用场景

核心意义：面板数据同时包含截面维度（个体）和时间维度，能够控制不可观测的个体异质性，提高估计效率。

举例：多中心临床试验的长期随访数据

为什么这种数据适合用面板数据模型？

首先，数据同时在多个中心（个体维度）和多个时间点（时间维度）上观测，形成面板数据结构。其次，不同中心可能存在不可观测的异质性（如医疗水平、患者人群差异），传统截面方法无法控制。面板数据模型能够控制个体固定效应，消除异质性偏差，提高估计效率。

研究目的是什么？

本研究有三个层次的目的：1. 控制个体异质性：消除各中心不可观测差异带来的偏差；2. 利用面板优势：增加样本量，提高估计精度；3. 识别动态效应：分析治疗效果随时间的变化。

可能得到什么样的结果？

假设面板数据分析显示：固定效应模型R²=0.75，治疗效应β=0.35（p<0.001）。

  1. 数据结构：50个中心，每个中心10年随访，共500个观测，平衡面板。
  2. 个体异质性：各中心的截距差异显著（F检验p<0.001），说明存在个体固定效应。
  3. 治疗效应：控制中心固定效应后，治疗效果β=0.35，比混合回归估计（β=0.45）更准确。
  4. 时间效应：治疗效果随时间增强，第5年后效果趋于稳定。

需要注意什么？

面板数据需区分平衡面板和非平衡面板，非平衡面板可能存在选择偏差。固定效应模型只能估计时变变量的效应，无法估计时不变变量（如性别、种族）。面板数据的样本量计算需考虑个体数和时间期的双重影响。

数学基础

面板数据特点：

  • 截面维度：\(N\)个个体
  • 时间维度：\(T\)个时期
  • 平衡面板：每个个体都有完整的\(T\)期观测
  • 非平衡面板：部分个体有缺失观测

数据结构：

\[Y_{it} = \alpha_i + \beta X_{it} + \varepsilon_{it}\]

参数说明： - \(i\)：个体下标 - \(t\)：时间下标 - \(\alpha_i\)：个体固定效应

代码实现

# 模拟面板数据
set.seed(111)
n_individuals <- 50
n_periods <- 10

# 生成面板数据
panel_data <- data.frame(
  id = rep(1:n_individuals, each = n_periods),
  time = rep(1:n_periods, n_individuals)
)

# 生成个体固定效应
individual_effect <- rnorm(n_individuals, 0, 3)
panel_data$alpha_i <- individual_effect[panel_data$id]

# 生成自变量
panel_data$x1 <- rnorm(nrow(panel_data), 50, 10) + panel_data$alpha_i * 0.5
panel_data$x2 <- rnorm(nrow(panel_data), 100, 20)

# 生成因变量
panel_data$y <- 10 + 0.5 * panel_data$x1 + 0.3 * panel_data$x2 + 
                panel_data$alpha_i + rnorm(nrow(panel_data), 0, 2)

# 查看数据结构
str(panel_data)
## 'data.frame':    500 obs. of  6 variables:
##  $ id     : int  1 1 1 1 1 1 1 1 1 1 ...
##  $ time   : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ alpha_i: num  0.706 0.706 0.706 0.706 0.706 ...
##  $ x1     : num  52.3 65.9 59.5 53.9 52.1 ...
##  $ x2     : num  81.1 91.6 66.7 119.2 97.6 ...
##  $ y      : num  62.3 66.9 60.4 74.5 68.4 ...
head(panel_data, 15)
##    id time    alpha_i       x1        x2        y
## 1   1    1  0.7056621 52.26946  81.13040 62.27035
## 2   1    2  0.7056621 65.87827  91.60649 66.86542
## 3   1    3  0.7056621 59.49525  66.65784 60.40834
## 4   1    4  0.7056621 53.93908 119.24568 74.45950
## 5   1    5  0.7056621 52.10379  97.59034 68.35469
## 6   1    6  0.7056621 41.88015 115.12986 67.65765
## 7   1    7  0.7056621 60.13515  86.04346 67.99838
## 8   1    8  0.7056621 68.41151 106.80401 78.32145
## 9   1    9  0.7056621 51.58198 128.89678 74.39321
## 10  1   10  0.7056621 49.05511 117.86020 71.52604
## 11  2    1 -0.9922076 47.33961 107.89379 60.33753
## 12  2    2 -0.9922076 63.96868 109.15645 73.01814
## 13  2    3 -0.9922076 53.60099  96.04250 65.47151
## 14  2    4 -0.9922076 58.61306 133.01039 79.98570
## 15  2    5 -0.9922076 63.80748  99.26790 77.46338
# 使用plm包
library(plm)

# 声明面板数据
pdata <- plm::pdata.frame(panel_data, index = c("id", "time"))

7.2 固定效应模型

意义与使用场景

核心意义：固定效应模型通过控制个体固定效应，消除不可观测的个体异质性偏差，得到一致的估计。

举例：控制医院固定效应比较治疗效果

为什么这种数据适合用固定效应模型？

首先，不同医院可能存在不可观测的异质性（如医疗水平、设备条件），这些因素可能与治疗效果相关。其次，我们关注的是治疗变量（时变变量）的效应，而非医院的特征。固定效应模型通过控制医院固定效应，消除异质性偏差，得到治疗效应的一致估计。

研究目的是什么？

本研究有三个层次的目的：1. 控制医院异质性：消除各医院不可观测差异带来的偏差；2. 估计治疗效应：得到治疗变量的无偏估计；3. 检验固定效应：判断固定效应是否显著，选择合适的模型。

可能得到什么样的结果？

假设固定效应模型显示：治疗效应β=0.35（p<0.001），固定效应检验F=15.2（p<0.001）。

  1. 固定效应检验：F检验p<0.001，拒绝”个体效应为零”的原假设，固定效应模型优于混合回归。
  2. 治疗效应：控制医院固定效应后，治疗效应β=0.35，比混合回归（β=0.50）更准确。
  3. 组内R²：组内R²=0.72，说明模型解释了72%的组内变异。
  4. 时不变变量：医院等级、地理位置等时不变变量无法在固定效应模型中估计。

需要注意什么？

固定效应模型只能估计时变变量的效应，无法估计时不变变量（如性别、种族、医院等级）。若需要估计时不变变量，可考虑随机效应模型或混合效应模型。固定效应模型的估计方法包括组内估计和LSDV，两者结果等价但计算效率不同。

数学基础

固定效应模型（FE）：

\[Y_{it} = \alpha_i + \beta X_{it} + \varepsilon_{it}\]

估计方法：

  1. 组内估计（Within Estimator）： \[\tilde{Y}_{it} = \beta \tilde{X}_{it} + \tilde{\varepsilon}_{it}\] 其中\(\tilde{Y}_{it} = Y_{it} - \bar{Y}_i\)为组内离差。

  2. LSDV（最小二乘虚拟变量法）： 直接加入个体虚拟变量。

固定效应检验：

\[H_0: \alpha_1 = \alpha_2 = \cdots = \alpha_N = 0\]

代码实现

# 混合OLS模型
pooled_model <- plm::plm(y ~ x1 + x2, data = pdata, model = "pooling")
summary(pooled_model)
## Pooling Model
## 
## Call:
## plm::plm(formula = y ~ x1 + x2, data = pdata, model = "pooling")
## 
## Balanced Panel: n = 50, T = 10, N = 500
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -13.48722  -2.65565   0.38046   2.46962  11.32791 
## 
## Coefficients:
##              Estimate Std. Error t-value  Pr(>|t|)    
## (Intercept) 6.2548665  1.2747030  4.9069 1.256e-06 ***
## x1          0.5713839  0.0183153 31.1970 < 2.2e-16 ***
## x2          0.2946080  0.0090006 32.7319 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    42178
## Residual Sum of Squares: 8028
## R-Squared:      0.80966
## Adj. R-Squared: 0.8089
## F-statistic: 1057.08 on 2 and 497 DF, p-value: < 2.22e-16
# 固定效应模型（组内估计）
fe_model <- plm::plm(y ~ x1 + x2, data = pdata, model = "within")
summary(fe_model)
## Oneway (individual) effect Within Model
## 
## Call:
## plm::plm(formula = y ~ x1 + x2, data = pdata, model = "within")
## 
## Balanced Panel: n = 50, T = 10, N = 500
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -4.867472 -1.177090  0.062713  1.196818  6.575264 
## 
## Coefficients:
##     Estimate Std. Error t-value  Pr(>|t|)    
## x1 0.5173956  0.0095857  53.976 < 2.2e-16 ***
## x2 0.3029740  0.0045988  65.881 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    30524
## Residual Sum of Squares: 1686.1
## R-Squared:      0.94476
## Adj. R-Squared: 0.93847
## F-statistic: 3831.23 on 2 and 448 DF, p-value: < 2.22e-16
# 提取固定效应
fe_effects <- plm::fixef(fe_model)
cat("========== 个体固定效应（前10个） ==========\n")
## ========== 个体固定效应（前10个） ==========
print(head(fe_effects, 10))
##        1        2        3        4        5        6        7        8 
## 9.893385 7.798814 9.105530 1.818202 9.228620 9.239097 4.810655 5.280331 
##        9       10 
## 5.148118 7.568561
# 固定效应检验
fe_test <- plm::pFtest(fe_model, pooled_model)
cat("\n========== 固定效应检验 ==========\n")
## 
## ========== 固定效应检验 ==========
print(fe_test)
## 
##  F test for individual effects
## 
## data:  y ~ x1 + x2
## F = 34.39, df1 = 49, df2 = 448, p-value < 2.2e-16
## alternative hypothesis: significant effects
# LSDV方法
fe_lsdv <- lm(y ~ x1 + x2 + factor(id), data = panel_data)
summary(fe_lsdv)
## 
## Call:
## lm(formula = y ~ x1 + x2 + factor(id), data = panel_data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -4.8675 -1.1771  0.0627  1.1968  6.5753 
## 
## Coefficients:
##                Estimate Std. Error t value Pr(>|t|)    
## (Intercept)    9.893385   0.921104  10.741  < 2e-16 ***
## x1             0.517396   0.009586  53.976  < 2e-16 ***
## x2             0.302974   0.004599  65.881  < 2e-16 ***
## factor(id)2   -2.094571   0.868138  -2.413  0.01623 *  
## factor(id)3   -0.787855   0.868332  -0.907  0.36473    
## factor(id)4   -8.075183   0.875238  -9.226  < 2e-16 ***
## factor(id)5   -0.664765   0.869842  -0.764  0.44513    
## factor(id)6   -0.654288   0.869416  -0.753  0.45211    
## factor(id)7   -5.082730   0.871491  -5.832 1.05e-08 ***
## factor(id)8   -4.613054   0.867782  -5.316 1.68e-07 ***
## factor(id)9   -4.745267   0.872760  -5.437 8.92e-08 ***
## factor(id)10  -2.324824   0.867915  -2.679  0.00766 ** 
## factor(id)11  -2.043770   0.874604  -2.337  0.01989 *  
## factor(id)12  -2.055696   0.867668  -2.369  0.01825 *  
## factor(id)13   4.166750   0.867790   4.802 2.15e-06 ***
## factor(id)14   0.161556   0.873451   0.185  0.85334    
## factor(id)15   1.118020   0.869756   1.285  0.19930    
## factor(id)16  -5.497292   0.874587  -6.286 7.76e-10 ***
## factor(id)17  -1.442928   0.867835  -1.663  0.09708 .  
## factor(id)18  -1.572085   0.873780  -1.799  0.07266 .  
## factor(id)19  -5.539345   0.867911  -6.382 4.36e-10 ***
## factor(id)20  -1.037640   0.867942  -1.196  0.23252    
## factor(id)21  -0.334502   0.872257  -0.383  0.70154    
## factor(id)22   0.344714   0.868963   0.397  0.69178    
## factor(id)23  -1.406438   0.868812  -1.619  0.10619    
## factor(id)24  -1.090819   0.868732  -1.256  0.20990    
## factor(id)25  -0.246406   0.870750  -0.283  0.77732    
## factor(id)26  -0.102563   0.869364  -0.118  0.90614    
## factor(id)27  -7.492941   0.871520  -8.598  < 2e-16 ***
## factor(id)28   7.994563   0.869899   9.190  < 2e-16 ***
## factor(id)29  -0.199991   0.868619  -0.230  0.81801    
## factor(id)30  -4.418275   0.875164  -5.049 6.49e-07 ***
## factor(id)31 -11.939772   0.877247 -13.611  < 2e-16 ***
## factor(id)32  -3.648508   0.871394  -4.187 3.40e-05 ***
## factor(id)33   2.301053   0.867664   2.652  0.00829 ** 
## factor(id)34  -5.719317   0.869034  -6.581 1.31e-10 ***
## factor(id)35  -7.511140   0.871171  -8.622  < 2e-16 ***
## factor(id)36   1.379354   0.869521   1.586  0.11337    
## factor(id)37  -0.861840   0.875476  -0.984  0.32544    
## factor(id)38  -0.286773   0.870538  -0.329  0.74199    
## factor(id)39  -2.517938   0.870489  -2.893  0.00401 ** 
## factor(id)40  -5.820291   0.871879  -6.676 7.30e-11 ***
## factor(id)41  -4.866279   0.872627  -5.577 4.25e-08 ***
## factor(id)42  -4.250774   0.875401  -4.856 1.66e-06 ***
## factor(id)43  -6.349854   0.871436  -7.287 1.44e-12 ***
## factor(id)44   0.044263   0.873480   0.051  0.95961    
## factor(id)45   0.630730   0.867991   0.727  0.46782    
## factor(id)46  -0.910107   0.870366  -1.046  0.29628    
## factor(id)47  -0.367757   0.869494  -0.423  0.67253    
## factor(id)48   0.672493   0.870491   0.773  0.44020    
## factor(id)49   6.004634   0.868303   6.915 1.62e-11 ***
## factor(id)50   3.869319   0.869561   4.450 1.09e-05 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.94 on 448 degrees of freedom
## Multiple R-squared:   0.96,  Adjusted R-squared:  0.9555 
## F-statistic:   211 on 51 and 448 DF,  p-value: < 2.2e-16

7.3 随机效应模型

意义与使用场景

核心意义：随机效应模型假设个体效应与解释变量不相关，比固定效应更高效，可估计时不变变量。

举例：分析性别、年龄等变量对健康结果的影响

为什么这种数据适合用随机效应模型？

首先，我们需要估计时不变变量（如性别、种族）的效应，固定效应模型无法估计。其次，我们假设个体效应与解释变量不相关，即医院的异质性是随机的，与治疗变量无关。随机效应模型能够估计时不变变量的效应，且比固定效应更高效（标准误更小）。

研究目的是什么？

本研究有三个层次的目的：1. 估计时不变变量效应：分析性别、种族等变量对健康结果的影响；2. 获得更高效的估计：利用随机效应模型的优势，获得更精确的估计；3. 检验模型假设：通过Hausman检验判断随机效应假设是否成立。

可能得到什么样的结果？

假设随机效应模型显示：性别效应β=0.25（p=0.02），治疗效应β=0.38（p<0.001）。

  1. 时不变变量：女性比男性健康结果高0.25个单位，差异显著。
  2. 治疗效应：治疗效应β=0.38，与固定效应估计（β=0.35）接近。
  3. 组内相关系数：ICC=0.35，说明35%的变异来自个体间差异。
  4. 模型效率：随机效应的标准误比固定效应小15%，估计更高效。

需要注意什么？

随机效应模型的核心假设是个体效应与解释变量不相关。若假设违反，估计将有偏。建议通过Hausman检验判断应使用固定效应还是随机效应模型。随机效应模型可估计时不变变量，但需谨慎解释，确保假设合理。

数学基础

随机效应模型（RE）：

\[Y_{it} = \alpha + \beta X_{it} + u_i + \varepsilon_{it}\]

参数说明： - \(u_i\)：随机个体效应，\(u_i \sim N(0, \sigma_u^2)\) - \(\varepsilon_{it}\)：误差项，\(\varepsilon_{it} \sim N(0, \sigma_\varepsilon^2)\)

GLS估计：

广义最小二乘，考虑复合误差结构。

方差成分： \[Var(Y_{it}) = \sigma_u^2 + \sigma_\varepsilon^2\] \[Cov(Y_{it}, Y_{is}) = \sigma_u^2\]

代码实现

# 随机效应模型
re_model <- plm::plm(y ~ x1 + x2, data = pdata, model = "random")
summary(re_model)
## Oneway (individual) effect Random Effect Model 
##    (Swamy-Arora's transformation)
## 
## Call:
## plm::plm(formula = y ~ x1 + x2, data = pdata, model = "random")
## 
## Balanced Panel: n = 50, T = 10, N = 500
## 
## Effects:
##                  var std.dev share
## idiosyncratic  3.764   1.940 0.249
## individual    11.360   3.370 0.751
## theta: 0.8209
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -5.808529 -1.264999  0.094409  1.360050  6.498766 
## 
## Coefficients:
##              Estimate Std. Error z-value  Pr(>|z|)    
## (Intercept) 8.0267447  0.8111315  9.8957 < 2.2e-16 ***
## x1          0.5194305  0.0096189 54.0010 < 2.2e-16 ***
## x2          0.3026540  0.0046188 65.5266 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    30898
## Residual Sum of Squares: 1894.1
## R-Squared:      0.9387
## Adj. R-Squared: 0.93845
## Chisq: 7610.34 on 2 DF, p-value: < 2.22e-16
# 提取方差成分
ercomp <- plm::ercomp(re_model)
cat("========== 方差成分 ==========\n")
## ========== 方差成分 ==========
print(ercomp)
##                  var std.dev share
## idiosyncratic  3.764   1.940 0.249
## individual    11.360   3.370 0.751
## theta: 0.8209
# 计算组内相关系数
icc_panel <- ercomp$sigma2["id"] / (ercomp$sigma2["id"] + ercomp$sigma2["idios"])
cat(sprintf("\n组内相关系数(ICC): %.3f\n", icc_panel))
## 
## 组内相关系数(ICC): 0.751

7.4 Hausman检验

意义与使用场景

核心意义：Hausman检验用于在固定效应和随机效应模型之间做出选择，是面板数据分析的关键步骤。

举例：决定多中心研究应使用固定效应还是随机效应模型

为什么这种数据适合用Hausman检验？

首先，固定效应和随机效应模型各有优势：固定效应无偏但效率低，随机效应高效但可能有偏。其次，我们需要一种统计方法来判断哪种模型更合适。Hausman检验通过比较两种模型的估计差异，判断随机效应假设是否成立，是模型选择的标准方法。

研究目的是什么？

本研究有三个层次的目的：1. 比较模型估计：检验固定效应和随机效应模型的估计是否存在显著差异；2. 选择合适模型：根据检验结果选择固定效应或随机效应模型；3. 验证模型假设：判断随机效应假设是否成立。

可能得到什么样的结果？

假设Hausman检验显示：卡方=12.5，自由度=2，p值=0.002。

  1. 检验结果：p值=0.002<0.05，拒绝原假设，固定效应和随机效应估计存在显著差异。
  2. 模型选择：应选择固定效应模型，因为随机效应假设不成立。
  3. 估计差异：固定效应估计β=0.35，随机效应估计β=0.45，差异较大。
  4. 原因分析：个体效应与解释变量相关，随机效应估计有偏。

需要注意什么？

Hausman检验的原假设是随机效应一致且更有效。p值<0.05表示拒绝原假设，应选择固定效应模型；p值≥0.05表示不能拒绝原假设，可选择随机效应模型。检验结果受样本量影响：大样本可能检测到微小差异，小样本可能漏检重要差异。

数学基础

Hausman检验：

用于选择固定效应还是随机效应模型。

\[H_0: \text{随机效应一致且更有效}\] \[H_1: \text{固定效应一致}\]

检验统计量： \[H = (\hat{\beta}_{FE} - \hat{\beta}_{RE})' [Var(\hat{\beta}_{FE}) - Var(\hat{\beta}_{RE})]^{-1} (\hat{\beta}_{FE} - \hat{\beta}_{RE})\]

在\(H_0\)下，\(H \sim \chi^2(k)\)。

代码实现

# Hausman检验
hausman_test <- plm::phtest(fe_model, re_model)
cat("========== Hausman检验 ==========\n")
## ========== Hausman检验 ==========
print(hausman_test)
## 
##  Hausman Test
## 
## data:  y ~ x1 + x2
## chisq = 7.2345, df = 2, p-value = 0.02686
## alternative hypothesis: one model is inconsistent
# 解释
if (hausman_test$p.value < 0.05) {
  cat("\n结论：拒绝原假设，应使用固定效应模型\n")
} else {
  cat("\n结论：不能拒绝原假设，可使用随机效应模型\n")
}
## 
## 结论：拒绝原假设，应使用固定效应模型

7.5 动态面板模型

意义与使用场景

核心意义：动态面板模型处理因变量滞后项导致的内生性问题，使用工具变量方法获得一致估计。

举例：分析健康状态的动态调整过程

为什么这种数据适合用动态面板模型？

首先，健康状态具有持续性：本期健康状态可能与上期健康状态相关（路径依赖）。其次，模型中包含因变量滞后项会导致内生性问题：滞后项与个体固定效应相关，普通固定效应估计有偏。动态面板模型（如Arellano-Bond GMM）使用工具变量方法，能够获得一致估计。

研究目的是什么？

本研究有三个层次的目的：1. 建模动态调整：分析健康状态的持续性和调整过程；2. 处理内生性：解决因变量滞后项导致的内生性问题；3. 检验工具变量有效性：通过Sargan检验和序列相关检验验证模型设定。

可能得到什么样的结果？

假设动态面板模型显示：滞后项系数γ=0.65（p<0.001），治疗效应β=0.25（p=0.01）。

  1. 动态效应：滞后项系数γ=0.65，说明健康状态具有较强的持续性。
  2. 治疗效应：控制动态效应后，治疗效应β=0.25，比静态模型（β=0.35）更准确。
  3. 工具变量检验：Sargan检验p值=0.35，工具变量有效性假设成立。
  4. 序列相关检验：AR(2)检验p值=0.42，不存在二阶序列相关，模型设定合理。

需要注意什么？

动态面板模型需要足够的时间期数（T≥3）来构建工具变量。工具变量的数量会随时间期数增加而快速增加，可能导致”工具变量过多”问题。Sargan检验用于检验工具变量有效性，AR(2)检验用于检验残差的序列相关。系统GMM比差分GMM更高效，但假设更强。

数学基础

动态面板模型：

包含因变量滞后项：

\[Y_{it} = \gamma Y_{i,t-1} + \beta X_{it} + \alpha_i + \varepsilon_{it}\]

问题：

\(Y_{i,t-1}\)与\(\alpha_i\)相关，导致OLS和固定效应估计有偏。

解决方案：

  1. Arellano-Bond估计量（差分GMM）： \[\Delta Y_{it} = \gamma \Delta Y_{i,t-1} + \beta \Delta X_{it} + \Delta \varepsilon_{it}\]

使用\(Y_{i,t-2}, Y_{i,t-3}, \ldots\)作为\(\Delta Y_{i,t-1}\)的工具变量。

  1. 系统GMM： 结合水平方程和差分方程。

代码实现

# 添加滞后项
panel_data$y_lag <- ave(panel_data$y, panel_data$id, FUN = function(x) c(NA, x[-length(x)]))

# 移除缺失值
panel_data_complete <- panel_data[complete.cases(panel_data), ]
pdata_complete <- plm::pdata.frame(panel_data_complete, index = c("id", "time"))

# 使用plm包的动态面板估计
# Arellano-Bond GMM
library(plm)
dpd_model <- plm::pgmm(y ~ lag(y, 1) + x1 + x2 | lag(y, 2:4) + lag(x1, 2:4),
                        data = pdata_complete, 
                        effect = "individual",
                        model = "onestep",
                        transformation = "d")
summary(dpd_model)
## Oneway (individual) effect One-step model Difference GMM 
## 
## Call:
## plm::pgmm(formula = y ~ lag(y, 1) + x1 + x2 | lag(y, 2:4) + lag(x1, 
##     2:4), data = pdata_complete, effect = "individual", model = "onestep", 
##     transformation = "d")
## 
## Balanced Panel: n = 50, T = 9, N = 450
## 
## Number of Observations Used: 350
## Residuals:
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
## -8.185642 -1.885523  0.058347 -0.004588  1.847267  8.232531 
## 
## Coefficients:
##             Estimate Std. Error z-value Pr(>|z|)    
## lag(y, 1) -0.0026336  0.0217758 -0.1209   0.9037    
## x1         0.5408025  0.0313598 17.2451   <2e-16 ***
## x2         0.3011926  0.0057320 52.5457   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Sargan test: chisq(34) = 40.60036 (p-value = 0.20228)
## Autocorrelation test (1): normal = -5.425032 (p-value = 5.7944e-08)
## Autocorrelation test (2): normal = 0.3289342 (p-value = 0.74221)
## Wald test for coefficients: chisq(3) = 2931.187 (p-value = < 2.22e-16)
# 使用pdynmc包进行系统GMM
# library(pdynmc)
# 系统GMM估计

7.6 面板二值选择模型

数学基础

面板Logit/Probit模型：

\[P(Y_{it} = 1 | X_{it}) = F(\alpha_i + \beta X_{it})\]

固定效应Logit：

条件Logit，消除个体效应。

随机效应Logit：

假设\(\alpha_i \sim N(0, \sigma_\alpha^2)\)。

代码实现

# 模拟面板二值数据
set.seed(222)
panel_data$y_binary <- as.integer(panel_data$y > median(panel_data$y))

# 固定效应Logit
library(bife)
fe_logit <- bife::bife(y_binary ~ x1 + x2 | id, data = panel_data, model = "logit")
summary(fe_logit)
## binomial - logit link
## 
## y_binary ~ x1 + x2 | id
## 
## Estimates:
##    Estimate Std. error z value Pr(> |z|)    
## x1  0.59488    0.08328   7.143  9.11e-13 ***
## x2  0.37091    0.05230   7.092  1.32e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## residual deviance= 119.24,
## null deviance= 664.59,
## n= 480, N= 48
## 
## ( 20 observation(s) deleted due to perfect classification )
## 
## Number of Fisher Scoring Iterations: 10 
## 
## Average individual fixed effect= -66.39
# 随机效应Logit
library(pglm)
pdata_binary <- plm::pdata.frame(panel_data, index = c("id", "time"))
re_logit <- pglm::pglm(y_binary ~ x1 + x2, 
                        data = pdata_binary, 
                        model = "random",
                        family = binomial(link = "logit"))
summary(re_logit)
## --------------------------------------------
## Maximum Likelihood estimation
## Newton-Raphson maximisation, 7 iterations
## Return code 8: successive function values within relative tolerance limit (reltol)
## Log-Likelihood: -133.3531 
## 4  free parameters
## Estimates:
##              Estimate Std. error t value  Pr(> t)    
## (Intercept) -44.64733    6.26680  -7.124 1.05e-12 ***
## x1            0.41348    0.05992   6.900 5.19e-12 ***
## x2            0.23943    0.03435   6.970 3.17e-12 ***
## sigma         3.15058    0.63381   4.971 6.67e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## --------------------------------------------

第七章小结

核心知识点总结

主题 核心内容 关键函数
面板数据结构 个体×时间维度 pdata.frame()
固定效应模型 组内估计、LSDV plm(model = "within")
随机效应模型 GLS估计 plm(model = "random")
Hausman检验 FE vs RE选择 phtest()
动态面板 GMM估计 pgmm()
面板二值模型 FE/RE Logit bife(), pglm()

第八章：结构方程模型

结构方程模型（Structural Equation Modeling, SEM）是一种综合性的统计方法，结合了因子分析和路径分析，用于研究潜变量之间的因果关系。本章将系统讲解验证性因子分析、路径分析、结构方程模型等内容。

8.1 路径分析

意义与使用场景

核心意义：路径分析用于研究观测变量之间的因果关系网络，可分解直接效应、间接效应和总效应。

举例：分析社会经济地位→健康行为→健康状况的因果路径

为什么这种数据适合用路径分析？

首先，健康结果受多种因素影响，且这些因素之间存在因果链条：教育影响收入，收入影响健康行为，健康行为影响健康状况。其次，我们需要分解直接效应和间接效应：教育对健康的影响有多少是通过收入和健康行为中介的。路径分析能够同时估计多个方程，分解直接和间接效应，是分析因果链条的有效方法。

研究目的是什么？

本研究有三个层次的目的：1. 检验因果路径：验证教育→收入→健康行为→健康状况的因果链条；2. 分解效应：计算教育对健康状况的直接效应和间接效应；3. 识别关键中介：判断收入和健康行为哪个中介效应更强。

可能得到什么样的结果？

假设路径分析显示：教育→收入β=0.45，收入→健康行为β=0.20，健康行为→健康状况β=0.35。

  1. 直接效应：收入对健康状况的直接效应β=0.20，教育对健康状况的直接效应不显著。
  2. 间接效应：教育通过收入影响健康的间接效应=0.45×0.20=0.09；教育通过健康行为影响健康的间接效应=0.30×0.35=0.105。
  3. 总效应：教育对健康状况的总效应=0.09+0.105=0.195。
  4. 中介比例：健康行为的中介效应占总效应的54%，是更重要的中介变量。

需要注意什么？

路径分析假设因果方向正确，但统计模型无法证明因果关系。中介效应的检验建议使用Bootstrap方法，比Sobel检验更稳健。模型拟合指数（如CFI、TLI、RMSEA）用于评估整体模型拟合，但拟合好不代表因果正确。

数学基础

路径分析：

研究观测变量之间的因果关系网络。

模型形式：

\[Y_1 = \beta_{11}X_1 + \beta_{12}X_2 + \varepsilon_1\] \[Y_2 = \beta_{21}X_1 + \beta_{22}Y_1 + \varepsilon_2\]

效应分解：

效应类型 定义
直接效应 变量间的直接路径系数
间接效应 通过中介变量的效应
总效应 直接效应 + 间接效应

代码实现

# 模拟路径分析数据
set.seed(333)
n_path <- 300

# 外生变量
education <- rnorm(n_path, 12, 3)      # 教育年限
income <- 2000 + 500 * education + rnorm(n_path, 0, 1000)  # 收入

# 中介变量
health_behavior <- 50 + 0.5 * education + 0.01 * income + rnorm(n_path, 0, 10)

# 内生变量
health_status <- 70 + 0.2 * income + 0.3 * health_behavior + rnorm(n_path, 0, 8)

path_data <- data.frame(
  education = education,
  income = income,
  health_behavior = health_behavior,
  health_status = health_status
)

# 使用lavaan包进行路径分析
library(lavaan)

# 定义路径模型
path_model <- '
  # 直接效应
  income ~ b1 * education
  health_behavior ~ b2 * education + b3 * income
  health_status ~ b4 * income + b5 * health_behavior
  
  # 间接效应
  indirect_edu_health := b1 * b4
  indirect_edu_behavior := b2 * b5
  indirect_income_behavior := b3 * b5
  
  # 总效应
  total_edu_status := b1 * b4 + b2 * b5
'

# 拟合模型
path_fit <- lavaan::sem(path_model, data = path_data)
summary(path_fit, standardized = TRUE, rsquare = TRUE)
## lavaan 0.6-21 ended normally after 61 iterations
## 
##   Estimator                                         ML
##   Optimization method                           NLMINB
##   Number of model parameters                         8
## 
##   Number of observations                           300
## 
## Model Test User Model:
##                                                       
##   Test statistic                                 0.000
##   Degrees of freedom                                 1
##   P-value (Chi-square)                           0.997
## 
## Parameter Estimates:
## 
##   Standard errors                             Standard
##   Information                                 Expected
##   Information saturated (h1) model          Structured
## 
## Regressions:
##                     Estimate     Std.Err  z-value  P(>|z|)   Std.lv     Std.all
##   income ~                                                                     
##     education (b1)      507.603       NA                       507.603    0.816
##   health_behavior ~                                                            
##     education (b2)        0.367       NA                         0.367    0.047
##     income    (b3)        0.011       NA                         0.011    0.854
##   health_status ~                                                              
##     income    (b4)        0.200       NA                         0.200    0.982
##     hlth_bhvr (b5)        0.314       NA                         0.314    0.020
## 
## Variances:
##                    Estimate     Std.Err  z-value  P(>|z|)   Std.lv     Std.all
##    .income         1051345.173       NA                   1051345.173    0.334
##    .health_behavir     102.830       NA                       102.830    0.203
##    .health_status       56.173       NA                        56.173    0.000
## 
## R-Square:
##                    Estimate   
##     income               0.666
##     health_behavir       0.797
##     health_status        1.000
## 
## Defined Parameters:
##                    Estimate     Std.Err  z-value  P(>|z|)   Std.lv     Std.all
##     indirct_d_hlth     101.491                                101.491    0.802
##     indirct_d_bhvr       0.115                                  0.115    0.001
##     indrct_ncm_bhv       0.003                                  0.003    0.017
##     total_edu_stts     101.606                                101.606    0.802
# 提取路径系数
parameterEstimates(path_fit, standardized = TRUE)
##                         lhs op             rhs                    label
## 1                    income  ~       education                       b1
## 2           health_behavior  ~       education                       b2
## 3           health_behavior  ~          income                       b3
## 4             health_status  ~          income                       b4
## 5             health_status  ~ health_behavior                       b5
## 6                    income ~~          income                         
## 7           health_behavior ~~ health_behavior                         
## 8             health_status ~~   health_status                         
## 9                 education ~~       education                         
## 10      indirect_edu_health :=           b1*b4      indirect_edu_health
## 11    indirect_edu_behavior :=           b2*b5    indirect_edu_behavior
## 12 indirect_income_behavior :=           b3*b5 indirect_income_behavior
## 13         total_edu_status :=     b1*b4+b2*b5         total_edu_status
##            est se  z pvalue ci.lower ci.upper      std.lv std.all std.nox
## 1      507.603 NA NA     NA       NA       NA     507.603   0.816   0.286
## 2        0.367 NA NA     NA       NA       NA       0.367   0.047   0.016
## 3        0.011 NA NA     NA       NA       NA       0.011   0.854   0.854
## 4        0.200 NA NA     NA       NA       NA       0.200   0.982   0.982
## 5        0.314 NA NA     NA       NA       NA       0.314   0.020   0.020
## 6  1051345.173 NA NA     NA       NA       NA 1051345.173   0.334   0.334
## 7      102.830 NA NA     NA       NA       NA     102.830   0.203   0.203
## 8       56.173 NA NA     NA       NA       NA      56.173   0.000   0.000
## 9        8.131  0 NA     NA    8.131    8.131       8.131   1.000   8.131
## 10     101.491  0 NA     NA  101.491  101.491     101.491   0.802   0.281
## 11       0.115  0 NA     NA    0.115    0.115       0.115   0.001   0.000
## 12       0.003  0 NA     NA    0.003    0.003       0.003   0.017   0.017
## 13     101.606  0 NA     NA  101.606  101.606     101.606   0.802   0.281

8.2 验证性因子分析

意义与使用场景

核心意义：验证性因子分析（CFA）基于先验理论检验因子结构，是量表开发和构念效度验证的核心方法。

举例：验证生活质量量表的结构效度

为什么这种数据适合用验证性因子分析？

首先，生活质量量表根据理论设计包含多个维度（如生理健康、心理健康、社会功能），需要验证实际数据是否支持这一结构。其次，我们需要评估量表的构念效度：条目是否按预期归入各因子，因子之间是否相关。验证性因子分析能够基于先验理论检验因子结构，是量表验证的标准方法。

研究目的是什么？

本研究有三个层次的目的：1. 验证因子结构：检验量表是否包含预期的维度；2. 评估测量质量：计算因子载荷、组合信度、平均方差提取量等指标；3. 检验模型拟合：评估模型与数据的拟合程度。

可能得到什么样的结果？

假设验证性因子分析显示：CFI=0.95，TLI=0.94，RMSEA=0.05，SRMR=0.04。

  1. 模型拟合：CFI>0.90，RMSEA<0.08，模型拟合良好，支持预设的因子结构。
  2. 因子载荷：大部分条目的标准化载荷>0.6，说明条目与因子的关联较强。
  3. 组合信度：各因子的CR>0.7，说明量表内部一致性良好。
  4. 平均方差提取量：各因子的AVE>0.5，说明因子能解释条目的大部分变异。

需要注意什么？

验证性因子分析基于先验理论，需要明确预设因子结构和条目归属。模型拟合指数的判断标准：CFI、TLI>0.90（理想>0.95），RMSEA<0.08（理想<0.06），SRMR<0.08。若模型拟合不佳，可考虑修正模型（如增加误差相关），但需有理论依据。

数学基础

验证性因子分析（CFA）：

基于先验理论检验因子结构。

测量模型： \[\mathbf{X} = \mathbf{\Lambda}\mathbf{\xi} + \mathbf{\delta}\]

参数说明： - \(\mathbf{X}\)：观测变量 - \(\mathbf{\Lambda}\)：因子载荷矩阵 - \(\mathbf{\xi}\)：潜变量 - \(\mathbf{\delta}\)：测量误差

模型识别条件：

需要足够的约束条件（如固定载荷为1）使模型可识别。

代码实现

# 模拟CFA数据：两个潜变量各3个指标
set.seed(444)
n_cfa <- 300

# 潜变量
depression <- rnorm(n_cfa, 0, 1)
anxiety <- rnorm(n_cfa, 0, 1)

# 观测变量（各3个指标）
dep1 <- 0.8 * depression + rnorm(n_cfa, 0, 0.6)
dep2 <- 0.7 * depression + rnorm(n_cfa, 0, 0.7)
dep3 <- 0.9 * depression + rnorm(n_cfa, 0, 0.5)
anx1 <- 0.75 * anxiety + rnorm(n_cfa, 0, 0.65)
anx2 <- 0.85 * anxiety + rnorm(n_cfa, 0, 0.55)
anx3 <- 0.7 * anxiety + rnorm(n_cfa, 0, 0.7)

cfa_data <- data.frame(dep1, dep2, dep3, anx1, anx2, anx3)

# 定义CFA模型
cfa_model <- '
  # 测量模型
  depression =~ dep1 + dep2 + dep3
  anxiety =~ anx1 + anx2 + anx3
'

# 拟合CFA模型
cfa_fit <- lavaan::cfa(cfa_model, data = cfa_data)
summary(cfa_fit, fit.measures = TRUE, standardized = TRUE)
## lavaan 0.6-21 ended normally after 23 iterations
## 
##   Estimator                                         ML
##   Optimization method                           NLMINB
##   Number of model parameters                        13
## 
##   Number of observations                           300
## 
## Model Test User Model:
##                                                       
##   Test statistic                                 3.357
##   Degrees of freedom                                 8
##   P-value (Chi-square)                           0.910
## 
## Model Test Baseline Model:
## 
##   Test statistic                               628.869
##   Degrees of freedom                                15
##   P-value                                        0.000
## 
## User Model versus Baseline Model:
## 
##   Comparative Fit Index (CFI)                    1.000
##   Tucker-Lewis Index (TLI)                       1.014
## 
## Loglikelihood and Information Criteria:
## 
##   Loglikelihood user model (H0)              -2233.066
##   Loglikelihood unrestricted model (H1)      -2231.387
##                                                       
##   Akaike (AIC)                                4492.131
##   Bayesian (BIC)                              4540.281
##   Sample-size adjusted Bayesian (SABIC)       4499.052
## 
## Root Mean Square Error of Approximation:
## 
##   RMSEA                                          0.000
##   90 Percent confidence interval - lower         0.000
##   90 Percent confidence interval - upper         0.027
##   P-value H_0: RMSEA <= 0.050                    0.989
##   P-value H_0: RMSEA >= 0.080                    0.000
## 
## Standardized Root Mean Square Residual:
## 
##   SRMR                                           0.018
## 
## Parameter Estimates:
## 
##   Standard errors                             Standard
##   Information                                 Expected
##   Information saturated (h1) model          Structured
## 
## Latent Variables:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##   depression =~                                                         
##     dep1              1.000                               0.814    0.782
##     dep2              0.885    0.072   12.263    0.000    0.721    0.713
##     dep3              1.100    0.083   13.177    0.000    0.895    0.897
##   anxiety =~                                                            
##     anx1              1.000                               0.723    0.742
##     anx2              1.135    0.116    9.826    0.000    0.820    0.804
##     anx3              0.852    0.089    9.609    0.000    0.616    0.662
## 
## Covariances:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##   depression ~~                                                         
##     anxiety          -0.042    0.041   -1.011    0.312   -0.071   -0.071
## 
## Variances:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##    .dep1              0.421    0.051    8.186    0.000    0.421    0.389
##    .dep2              0.503    0.051    9.886    0.000    0.503    0.492
##    .dep3              0.195    0.049    3.975    0.000    0.195    0.195
##    .anx1              0.427    0.057    7.538    0.000    0.427    0.450
##    .anx2              0.368    0.065    5.677    0.000    0.368    0.354
##    .anx3              0.488    0.051    9.492    0.000    0.488    0.562
##     depression        0.662    0.090    7.353    0.000    1.000    1.000
##     anxiety           0.522    0.082    6.342    0.000    1.000    1.000
# 查看拟合指数
fitmeasures(cfa_fit, c("cfi", "tli", "rmsea", "srmr", "chisq", "df", "pvalue"))
##    cfi    tli  rmsea   srmr  chisq     df pvalue 
##  1.000  1.014  0.000  0.018  3.357  8.000  0.910
# 可视化
library(semPlot)
semPlot::semPaths(cfa_fit, what = "std", style = "lisrel", 
                   title = TRUE, curvePivot = TRUE)

8.3 结构模型与模型拟合评价

意义与使用场景

核心意义：结构模型将测量模型和路径分析结合，研究潜变量之间的因果关系，模型拟合评价验证模型与数据的匹配程度。

举例：研究生活质量、心理健康等潜变量与疾病预后的关系

为什么这种数据适合用结构方程模型？

首先，生活质量、心理健康等构念无法直接观测，需要通过多个指标测量（潜变量）。其次，这些潜变量之间存在因果关系，需要同时建模测量模型和结构模型。结构方程模型能够结合测量模型（因子分析）和结构模型（路径分析），是研究潜变量因果关系的理想方法。

研究目的是什么？

本研究有三个层次的目的：1. 建立测量模型：验证各潜变量的测量结构；2. 检验因果路径：分析潜变量之间的因果关系；3. 评估模型拟合：判断模型与数据的匹配程度。

可能得到什么样的结果？

假设结构方程模型显示：抑郁→焦虑β=0.45（p<0.001），CFI=0.96，RMSEA=0.04。

  1. 结构效应：抑郁对焦虑的效应β=0.45，抑郁水平越高，焦虑水平越高。
  2. 测量模型：各潜变量的因子载荷>0.6，测量模型拟合良好。
  3. 模型拟合：CFI=0.96>0.95，RMSEA=0.04<0.06，模型拟合优秀。
  4. 解释力：抑郁解释了焦虑变异的20%，还有其他因素影响焦虑。

需要注意什么？

结构方程模型的结果依赖于模型的正确设定，统计拟合好不代表因果正确。模型拟合指数的判断需综合考虑多个指标，单一指标可能误导。样本量要求较高，一般建议至少10倍于自由参数数量。修正模型（如增加路径）需有理论依据，避免过度拟合。

数学基础

完整SEM模型：

测量模型： \[\mathbf{X} = \mathbf{\Lambda}_x\mathbf{\xi} + \mathbf{\delta}\] \[\mathbf{Y} = \mathbf{\Lambda}_y\mathbf{\eta} + \mathbf{\varepsilon}\]

结构模型： \[\mathbf{\eta} = \mathbf{B}\mathbf{\eta} + \mathbf{\Gamma}\mathbf{\xi} + \mathbf{\zeta}\]

拟合指数：

指标 可接受标准 说明
\(\chi^2\)/df < 3 卡方与自由度比
CFI > 0.90 比较拟合指数
TLI > 0.90 Tucker-Lewis指数
RMSEA < 0.08 近似误差均方根
SRMR < 0.08 标准化残差均方根

代码实现

# 定义完整SEM模型
sem_model <- '
  # 测量模型
  depression =~ dep1 + dep2 + dep3
  anxiety =~ anx1 + anx2 + anx3
  
  # 结构模型（假设抑郁影响焦虑）
  anxiety ~ depression
'

# 拟合SEM模型
sem_fit <- lavaan::sem(sem_model, data = cfa_data)
summary(sem_fit, fit.measures = TRUE, standardized = TRUE)
## lavaan 0.6-21 ended normally after 22 iterations
## 
##   Estimator                                         ML
##   Optimization method                           NLMINB
##   Number of model parameters                        13
## 
##   Number of observations                           300
## 
## Model Test User Model:
##                                                       
##   Test statistic                                 3.357
##   Degrees of freedom                                 8
##   P-value (Chi-square)                           0.910
## 
## Model Test Baseline Model:
## 
##   Test statistic                               628.869
##   Degrees of freedom                                15
##   P-value                                        0.000
## 
## User Model versus Baseline Model:
## 
##   Comparative Fit Index (CFI)                    1.000
##   Tucker-Lewis Index (TLI)                       1.014
## 
## Loglikelihood and Information Criteria:
## 
##   Loglikelihood user model (H0)              -2233.066
##   Loglikelihood unrestricted model (H1)      -2231.387
##                                                       
##   Akaike (AIC)                                4492.131
##   Bayesian (BIC)                              4540.281
##   Sample-size adjusted Bayesian (SABIC)       4499.052
## 
## Root Mean Square Error of Approximation:
## 
##   RMSEA                                          0.000
##   90 Percent confidence interval - lower         0.000
##   90 Percent confidence interval - upper         0.027
##   P-value H_0: RMSEA <= 0.050                    0.989
##   P-value H_0: RMSEA >= 0.080                    0.000
## 
## Standardized Root Mean Square Residual:
## 
##   SRMR                                           0.018
## 
## Parameter Estimates:
## 
##   Standard errors                             Standard
##   Information                                 Expected
##   Information saturated (h1) model          Structured
## 
## Latent Variables:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##   depression =~                                                         
##     dep1              1.000                               0.814    0.782
##     dep2              0.885    0.072   12.263    0.000    0.721    0.713
##     dep3              1.100    0.083   13.177    0.000    0.895    0.897
##   anxiety =~                                                            
##     anx1              1.000                               0.723    0.742
##     anx2              1.135    0.116    9.826    0.000    0.820    0.804
##     anx3              0.852    0.089    9.609    0.000    0.616    0.662
## 
## Regressions:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##   anxiety ~                                                             
##     depression       -0.063    0.062   -1.015    0.310   -0.071   -0.071
## 
## Variances:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##    .dep1              0.421    0.051    8.186    0.000    0.421    0.389
##    .dep2              0.503    0.051    9.886    0.000    0.503    0.492
##    .dep3              0.195    0.049    3.975    0.000    0.195    0.195
##    .anx1              0.427    0.057    7.538    0.000    0.427    0.450
##    .anx2              0.368    0.065    5.677    0.000    0.368    0.354
##    .anx3              0.488    0.051    9.492    0.000    0.488    0.562
##     depression        0.662    0.090    7.353    0.000    1.000    1.000
##    .anxiety           0.520    0.082    6.338    0.000    0.995    0.995
# 提取拟合指数
fit_indices <- fitmeasures(sem_fit, c("chisq", "df", "pvalue", "cfi", "tli", "rmsea", "srmr"))
cat("\n========== 模型拟合指数 ==========\n")
## 
## ========== 模型拟合指数 ==========
print(round(fit_indices, 3))
##  chisq     df pvalue    cfi    tli  rmsea   srmr 
##  3.357  8.000  0.910  1.000  1.014  0.000  0.018
# 修正指数
mi <- modificationIndices(sem_fit)
head(mi[order(mi$mi, decreasing = TRUE), ], 10)
##           lhs op  rhs    mi    epc sepc.lv sepc.all sepc.nox
## 36       anx2 ~~ anx3 1.551  0.605   0.605    1.426    1.426
## 16 depression =~ anx1 1.551 -0.075  -0.061   -0.063   -0.063
## 29       dep2 ~~ anx2 0.908  0.032   0.032    0.075    0.075
## 26       dep1 ~~ anx3 0.828  0.029   0.029    0.064    0.064
## 35       anx1 ~~ anx3 0.642 -0.320  -0.320   -0.702   -0.702
## 17 depression =~ anx2 0.642  0.051   0.042    0.041    0.041
## 30       dep2 ~~ anx3 0.542 -0.025  -0.025   -0.050   -0.050
## 24       dep1 ~~ anx1 0.499 -0.022  -0.022   -0.053   -0.053
## 20    anxiety =~ dep2 0.247  0.035   0.025    0.025    0.025
## 23       dep1 ~~ dep3 0.247 -0.355  -0.355   -1.241   -1.241

8.4 潜变量增长模型

意义与使用场景

核心意义：潜变量增长模型研究潜变量随时间的变化轨迹，可分析个体差异和预测因子。

举例：研究患者生活质量随时间的变化轨迹

为什么这种数据适合用潜变量增长模型？

首先，生活质量是纵向测量的，需要分析其随时间的变化趋势。其次，不同患者的初始水平和变化速度可能不同，存在个体差异。潜变量增长模型能够估计总体的变化轨迹（截距和斜率的均值）和个体差异（截距和斜率的方差），是分析纵向数据的理想方法。

研究目的是什么？

本研究有三个层次的目的：1. 估计变化轨迹：分析生活质量随时间的平均变化趋势；2. 分析个体差异：判断患者之间的初始水平和变化速度是否存在差异；3. 识别预测因子：分析哪些因素影响初始水平和变化速度。

可能得到什么样的结果？

假设潜变量增长模型显示：截距均值=50，斜率均值=3，截距方差=80，斜率方差=5。

  1. 平均轨迹：初始生活质量平均为50分，每期增加3分，呈上升趋势。
  2. 个体差异：截距方差=80（p<0.001），斜率方差=5（p=0.02），患者间存在显著差异。
  3. 相关性：截距与斜率相关r=-0.3，初始水平低的患者改善更快。
  4. 预测因子：年龄负向预测斜率（β=-0.1），年轻患者改善更快。

需要注意什么？

潜变量增长模型假设线性增长轨迹，若增长非线性需使用非线性增长模型或分段模型。需要至少3个时间点的数据才能估计增长模型。模型拟合可通过CFI、RMSEA等指标评估。截距与斜率的相关性有重要临床意义：负相关表示”追赶效应”，正相关表示”马太效应”。

潜变量增长模型（LGM）：

研究潜变量随时间的变化轨迹。

模型形式：

\[Y_{it} = \eta_{0i} + \eta_{1i} \cdot \lambda_t + \varepsilon_{it}\]

参数说明： - \(\eta_{0i}\)：个体\(i\)的初始水平（截距因子） - \(\eta_{1i}\)：个体\(i\)的增长率（斜率因子） - \(\lambda_t\)：时间得分

代码实现

# 模拟纵向数据
set.seed(555)
n_lgm <- 200

# 潜变量：截距和斜率
eta0 <- rnorm(n_lgm, 50, 10)   # 初始水平
eta1 <- rnorm(n_lgm, 5, 2)     # 增长率

# 4个时间点的观测
y1 <- eta0 + rnorm(n_lgm, 0, 5)
y2 <- eta0 + eta1 * 1 + rnorm(n_lgm, 0, 5)
y3 <- eta0 + eta1 * 2 + rnorm(n_lgm, 0, 5)
y4 <- eta0 + eta1 * 3 + rnorm(n_lgm, 0, 5)

lgm_data <- data.frame(y1, y2, y3, y4)

# 定义LGM模型
lgm_model <- '
  # 截距因子
  i =~ 1*y1 + 1*y2 + 1*y3 + 1*y4
  # 斜率因子
  s =~ 0*y1 + 1*y2 + 2*y3 + 3*y4
'

# 拟合模型
lgm_fit <- lavaan::growth(lgm_model, data = lgm_data)
summary(lgm_fit, standardized = TRUE)
## lavaan 0.6-21 ended normally after 101 iterations
## 
##   Estimator                                         ML
##   Optimization method                           NLMINB
##   Number of model parameters                         9
## 
##   Number of observations                           200
## 
## Model Test User Model:
##                                                       
##   Test statistic                                10.711
##   Degrees of freedom                                 5
##   P-value (Chi-square)                           0.057
## 
## Parameter Estimates:
## 
##   Standard errors                             Standard
##   Information                                 Expected
##   Information saturated (h1) model          Structured
## 
## Latent Variables:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##   i =~                                                                  
##     y1                1.000                              10.165    0.908
##     y2                1.000                              10.165    0.884
##     y3                1.000                              10.165    0.841
##     y4                1.000                              10.165    0.768
##   s =~                                                                  
##     y1                0.000                               0.000    0.000
##     y2                1.000                               2.386    0.208
##     y3                2.000                               4.771    0.395
##     y4                3.000                               7.157    0.541
## 
## Covariances:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##   i ~~                                                                  
##     s                -0.500    2.785   -0.180    0.857   -0.021   -0.021
## 
## Intercepts:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##     i                50.304    0.772   65.168    0.000    4.949    4.949
##     s                 4.857    0.226   21.450    0.000    2.036    2.036
## 
## Variances:
##                    Estimate  Std.Err  z-value  P(>|z|)   Std.lv  Std.all
##    .y1               22.133    4.923    4.496    0.000   22.133    0.176
##    .y2               24.109    3.285    7.339    0.000   24.109    0.182
##    .y3               21.843    3.265    6.689    0.000   21.843    0.150
##    .y4               23.494    5.407    4.345    0.000   23.494    0.134
##     i               103.334   12.177    8.486    0.000    1.000    1.000
##     s                 5.691    1.248    4.561    0.000    1.000    1.000
# 提取截距和斜率的均值与方差
parameterEstimates(lgm_fit)[1:4, ]
##   lhs op rhs est se  z pvalue ci.lower ci.upper
## 1   i =~  y1   1  0 NA     NA        1        1
## 2   i =~  y2   1  0 NA     NA        1        1
## 3   i =~  y3   1  0 NA     NA        1        1
## 4   i =~  y4   1  0 NA     NA        1        1

第八章小结

核心知识点总结

主题 核心内容 关键函数
路径分析 因果关系网络 lavaan::sem()
CFA 潜变量测量模型 lavaan::cfa()
SEM 测量+结构模型 lavaan::sem()
拟合评价 CFI、RMSEA等 fitmeasures()
LGM 潜变量增长轨迹 lavaan::growth()

第九章：非参数与半参数回归

非参数回归不假设特定的函数形式，让数据”说话”，适用于探索变量间的复杂关系。本章将系统讲解核密度估计、局部回归、样条回归、广义加性模型等内容。

9.1 核密度估计

意义与使用场景

核心意义：核密度估计是一种非参数方法，用于估计数据的概率密度函数，无需假设特定分布形式。

举例：分析患者血压的分布特征

为什么这种数据适合用核密度估计？

首先，血压的分布可能不是标准的正态分布，可能存在偏态或多峰。其次，我们需要直观展示血压的分布形态，发现潜在的亚群（如双峰分布可能提示两个亚群）。核密度估计是非参数方法，无需假设特定分布形式，能够灵活地估计数据的真实分布形态。

研究目的是什么？

本研究有三个层次的目的：1. 探索分布形态：判断血压是否服从正态分布，是否存在偏态或多峰；2. 比较群体差异：比较不同群体（如男女、不同年龄组）的分布差异；3. 发现亚群：若分布呈多峰，可能提示存在不同的亚群。

可能得到什么样的结果？

假设核密度估计显示：血压分布呈轻微右偏，存在一个主峰和一个肩峰。

  1. 分布形态：血压分布呈轻微右偏，均值略高于中位数，高值尾部较长。
  2. 正态性检验：Shapiro-Wilk检验p<0.001，拒绝正态假设，核密度估计更准确。
  3. 亚群提示：分布存在肩峰，可能提示高血压亚群的存在。
  4. 群体比较：男性血压分布整体右移，均值比女性高5mmHg。

需要注意什么？

核密度估计的结果依赖于带宽的选择：带宽过小导致过拟合（噪声多），带宽过大导致欠拟合（过度平滑）。建议使用交叉验证或Silverman规则选择最优带宽。核函数的选择（如高斯核、Epanechnikov核）对结果影响较小。对于多峰分布，需谨慎解释是否真实存在亚群。

数学基础

核密度估计（KDE）：

\[\hat{f}(x) = \frac{1}{nh}\sum_{i=1}^{n} K\left(\frac{x - X_i}{h}\right)\]

参数说明： - \(K(\cdot)\)：核函数（如高斯核、Epanechnikov核） - \(h\)：带宽（平滑参数）

带宽选择：

方法 特点
Silverman法则 \(h = 1.06 \sigma n^{-1/5}\)
交叉验证 最小化积分平方误差
Sheather-Jones 自适应带宽选择

代码实现

# 模拟数据
set.seed(666)
n_kde <- 500
x_kde <- c(rnorm(n_kde * 0.6, mean = 50, sd = 8),
           rnorm(n_kde * 0.4, mean = 70, sd = 10))

# 核密度估计
density_est <- density(x_kde)

# 绘制密度曲线
plot(density_est, main = "核密度估计", xlab = "值", ylab = "密度")
rug(x_kde)

# 比较不同带宽
par(mfrow = c(2, 2))
plot(density(x_kde, bw = 2), main = "带宽 = 2（过小）")
plot(density(x_kde, bw = "nrd"), main = "带宽 = nrd0（默认）")
plot(density(x_kde, bw = "SJ"), main = "带宽 = SJ")
plot(density(x_kde, bw = 10), main = "带宽 = 10（过大）")

par(mfrow = c(1, 1))

# 比较不同核函数
plot(density(x_kde, kernel = "gaussian"), main = "不同核函数比较", col = "black")
lines(density(x_kde, kernel = "epanechnikov"), col = "red")
lines(density(x_kde, kernel = "rectangular"), col = "blue")
legend("topright", legend = c("Gaussian", "Epanechnikov", "Rectangular"),
       col = c("black", "red", "blue"), lty = 1)

9.2 局部加权回归

意义与使用场景

核心意义：局部加权回归（LOESS/LOWESS）通过局部拟合来探索变量间的非线性关系，无需指定函数形式。

举例：探索年龄与血压的非线性关系

为什么这种数据适合用局部加权回归？

首先，年龄与血压的关系可能是非线性的：中年以前血压随年龄增加，老年后可能趋于稳定甚至下降。其次，我们不知道具体的函数形式，不想假设线性或多项式关系。局部加权回归通过局部拟合，能够灵活地探索变量间的非线性关系，是数据探索的有效工具。

研究目的是什么？

本研究有三个层次的目的：1. 探索非线性关系：判断年龄与血压是否存在非线性关系；2. 发现转折点：识别血压变化的转折年龄；3. 指导后续建模：根据LOESS曲线选择合适的参数模型。

可能得到什么样的结果？

假设局部加权回归显示：血压随年龄增加，但在60岁后增速放缓。

  1. 非线性关系：LOESS曲线明显非线性，线性回归假设不合适。
  2. 转折点：约60岁处曲线斜率变化，血压增速放缓。
  3. 分段特征：40岁前血压增长较快（每年0.5mmHg），40-60岁增长中等（每年0.3mmHg），60岁后增长缓慢（每年0.1mmHg）。
  4. 建模建议：建议使用分段线性模型或样条回归进行正式分析。

需要注意什么？

LOESS的结果依赖于span参数的选择：span过小导致过拟合，span过大导致欠拟合。建议尝试多个span值，选择既能捕捉趋势又不过度波动的曲线。LOESS主要用于探索性分析，正式建模建议使用样条回归或GAM。边界区域的估计不稳定，需谨慎解释。

数学基础

LOESS/LOWESS：

局部加权散点图平滑。

\[\hat{y}(x_0) = \sum_{i=1}^{n} w_i(x_0) y_i\]

权重函数：

使用核函数计算权重，距离\(x_0\)越近的点权重越大。

参数说明： - span：邻域比例（通常0.3-0.8） - degree：局部多项式阶数（1或2）

代码实现

# 模拟非线性关系数据
set.seed(777)
n_loess <- 200
x_loess <- runif(n_loess, 0, 10)
y_loess <- sin(x_loess) + 0.5 * x_loess + rnorm(n_loess, 0, 0.3)

loess_data <- data.frame(x = x_loess, y = y_loess)

# LOESS回归
loess_fit <- loess(y ~ x, data = loess_data, span = 0.5)

# 预测
x_pred <- seq(0, 10, length.out = 100)
y_pred <- predict(loess_fit, newdata = data.frame(x = x_pred))

# 绘制拟合曲线
plot(loess_data$x, loess_data$y, main = "LOESS回归", xlab = "x", ylab = "y")
lines(x_pred, y_pred, col = "red", lwd = 2)

# 比较不同span值
ggplot2::ggplot(loess_data, ggplot2::aes(x = x, y = y)) +
  ggplot2::geom_point(alpha = 0.5) +
  ggplot2::geom_smooth(method = "loess", span = 0.3, ggplot2::aes(color = "span=0.3"), se = FALSE) +
  ggplot2::geom_smooth(method = "loess", span = 0.5, ggplot2::aes(color = "span=0.5"), se = FALSE) +
  ggplot2::geom_smooth(method = "loess", span = 0.8, ggplot2::aes(color = "span=0.8"), se = FALSE) +
  ggplot2::scale_color_manual(values = c("span=0.3" = "red", "span=0.5" = "blue", "span=0.8" = "green")) +
  ggplot2::labs(title = "不同span值的LOESS拟合", color = "参数") +
  ggplot2::theme_minimal()

9.3 样条回归

意义与使用场景

核心意义：样条回归使用分段多项式拟合非线性关系，在节点处保持连续，灵活且可解释。

举例：药物剂量-效应曲线拟合

为什么这种数据适合用样条回归？

首先，药物剂量与效应的关系可能是非线性的：低剂量时效应增长快，高剂量时趋于饱和。其次，我们需要一个灵活但可解释的模型，能够捕捉非线性特征同时控制复杂度。样条回归使用分段多项式，在节点处保持连续，能够灵活拟合非线性关系，同时通过自由度控制复杂度。

研究目的是什么？

本研究有三个层次的目的：1. 拟合剂量-效应曲线：估计药物剂量与效应的非线性关系；2. 估计有效剂量：计算ED50（半数有效剂量）等关键参数；3. 比较模型：通过AIC比较不同自由度的样条模型。

可能得到什么样的结果？

假设样条回归显示：使用5个自由度的自然样条，AIC=1250，ED50=50mg。

  1. 剂量-效应曲线：低剂量（0-30mg）效应增长快，中剂量（30-70mg）增长放缓，高剂量（>70mg）趋于饱和。
  2. 有效剂量：ED50=50mg，ED90=85mg，为临床用药提供参考。
  3. 非线性检验：非线性项的F检验p<0.001，剂量-效应关系显著非线性。
  4. 模型比较：5自由度样条比3自由度和7自由度样条AIC更低，拟合最优。

需要注意什么？

样条回归的结果依赖于节点数量和位置的选择。自由度越高，拟合越灵活但可能过拟合；自由度越低，拟合越平滑但可能欠拟合。建议通过AIC或交叉验证选择最优自由度。自然样条在边界外线性延伸，比B样条更稳定。惩罚样条（P-spline）通过惩罚项自动控制平滑度。

数学基础

B样条：

分段多项式，在节点处连续。

\[f(x) = \sum_{j=1}^{k} \beta_j B_j(x)\]

自然样条：

在边界外线性延伸，减少边界效应。

惩罚样条（P-spline）：

添加惩罚项控制平滑度： \[\min \sum_{i=1}^{n}(y_i - f(x_i))^2 + \lambda \int (f''(x))^2 dx\]

代码实现

# 使用样条回归
library(splines)

# B样条回归
bs_fit <- lm(y ~ bs(x, df = 5), data = loess_data)
summary(bs_fit)
## 
## Call:
## lm(formula = y ~ bs(x, df = 5), data = loess_data)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -1.34810 -0.26004 -0.06715  0.23288  1.05147 
## 
## Coefficients:
##                Estimate Std. Error t value Pr(>|t|)    
## (Intercept)     -0.2885     0.1321  -2.184   0.0301 *  
## bs(x, df = 5)1   3.5073     0.2586  13.563   <2e-16 ***
## bs(x, df = 5)2   0.2024     0.1866   1.085   0.2794    
## bs(x, df = 5)3   3.6520     0.2469  14.793   <2e-16 ***
## bs(x, df = 5)4   6.5791     0.2095  31.399   <2e-16 ***
## bs(x, df = 5)5   4.2491     0.2180  19.490   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.3959 on 194 degrees of freedom
## Multiple R-squared:  0.9396, Adjusted R-squared:  0.938 
## F-statistic: 603.3 on 5 and 194 DF,  p-value: < 2.2e-16
# 自然样条回归
ns_fit <- lm(y ~ ns(x, df = 5), data = loess_data)
summary(ns_fit)
## 
## Call:
## lm(formula = y ~ ns(x, df = 5), data = loess_data)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -1.16894 -0.21536  0.00389  0.22757  0.89189 
## 
## Coefficients:
##                Estimate Std. Error t value Pr(>|t|)    
## (Intercept)     0.08711    0.09829   0.886    0.377    
## ns(x, df = 5)1  0.56087    0.13206   4.247 3.36e-05 ***
## ns(x, df = 5)2  1.97014    0.16906  11.654  < 2e-16 ***
## ns(x, df = 5)3  5.02433    0.13218  38.012  < 2e-16 ***
## ns(x, df = 5)4  7.01163    0.24794  28.279  < 2e-16 ***
## ns(x, df = 5)5  2.71527    0.12284  22.103  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.3409 on 194 degrees of freedom
## Multiple R-squared:  0.9552, Adjusted R-squared:  0.9541 
## F-statistic: 827.4 on 5 and 194 DF,  p-value: < 2.2e-16
# 光滑样条
smooth_fit <- smooth.spline(x_loess, y_loess, df = 5)

# 绘制比较
plot(loess_data$x, loess_data$y, main = "样条回归比较", xlab = "x", ylab = "y")
lines(x_pred, predict(bs_fit, newdata = data.frame(x = x_pred)), col = "red", lwd = 2)
lines(x_pred, predict(ns_fit, newdata = data.frame(x = x_pred)), col = "blue", lwd = 2)
lines(smooth_fit, col = "green", lwd = 2)
legend("topleft", legend = c("B样条", "自然样条", "光滑样条"),
       col = c("red", "blue", "green"), lty = 1, lwd = 2)

# 交叉验证选择自由度
smooth_cv <- smooth.spline(x_loess, y_loess, cv = TRUE)
cat(sprintf("\n交叉验证选择的自由度: %.1f\n", smooth_cv$df))
## 
## 交叉验证选择的自由度: 9.4

9.4 广义加性模型

意义与使用场景

核心意义：广义加性模型（GAM）将加性模型与广义线性模型结合，每个预测变量用光滑函数拟合，灵活且可解释。

举例：分析多个环境因素对健康的非线性影响

为什么这种数据适合用广义加性模型？

首先，健康结果受多个环境因素影响（如PM2.5、温度、湿度），这些因素的效应可能是非线性的。其次，我们需要同时处理多个预测变量的非线性效应，同时保持模型的可解释性。广义加性模型能够为每个预测变量拟合光滑函数，自动选择光滑程度，同时保持加性结构的可解释性。

研究目的是什么？

本研究有三个层次的目的：1. 拟合非线性效应：估计各环境因素对健康的非线性影响；2. 控制混杂：在控制其他因素后，估计每个因素的独立效应；3. 比较效应强度：判断哪个环境因素对健康的影响最大。

可能得到什么样的结果？

假设广义加性模型显示：PM2.5效应非线性（EDF=4.5），温度效应非线性（EDF=3.2）。

  1. PM2.5效应：PM2.5对健康的影响呈阈值效应：低于50μg/m³影响较小，高于50μg/m³影响急剧增加。
  2. 温度效应：温度对健康的影响呈U型：极低和极高温度都有害，最适温度约20℃。
  3. 效应比较：PM2.5的效应强度（F=25.3）大于温度（F=15.6），是更重要的环境因素。
  4. 模型拟合：调整R²=0.45，GAM比线性模型（调整R²=0.32）拟合更好。

需要注意什么？

GAM的光滑函数有效自由度（EDF）反映非线性程度：EDF=1表示线性，EDF>1表示非线性。光滑参数通过GCV或REML自动选择，避免过拟合。GAM假设加性结构，不捕捉变量间的交互作用，可通过添加交互项解决。模型诊断需检查残差是否满足分布假设。

数学基础

GAM模型：

\[g(E[Y]) = \beta_0 + f_1(X_1) + f_2(X_2) + \cdots + f_p(X_p)\]

参数说明： - \(g(\cdot)\)：链接函数 - \(f_j(\cdot)\)：光滑函数（如样条）

光滑参数选择：

使用GCV（广义交叉验证）或REML选择。

代码实现

# 模拟GAM数据
set.seed(888)
n_gam <- 300

x1_gam <- runif(n_gam, 0, 10)
x2_gam <- runif(n_gam, 0, 10)
y_gam <- sin(x1_gam) + 0.5 * x2_gam^2 + rnorm(n_gam, 0, 1)

gam_data <- data.frame(x1 = x1_gam, x2 = x2_gam, y = y_gam)

# 拟合GAM模型
library(mgcv)
gam_fit <- mgcv::gam(y ~ s(x1) + s(x2), data = gam_data)
summary(gam_fit)
## 
## Family: gaussian 
## Link function: identity 
## 
## Formula:
## y ~ s(x1) + s(x2)
## 
## Parametric coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  16.3745     0.0539   303.8   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Approximate significance of smooth terms:
##         edf Ref.df        F p-value    
## s(x1) 6.415  7.569    20.07  <2e-16 ***
## s(x2) 5.898  7.065 10073.53  <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## R-sq.(adj) =  0.996   Deviance explained = 99.6%
## GCV = 0.91212  Scale est. = 0.87165   n = 300
# 查看光滑函数
par(mfrow = c(1, 2))
plot(gam_fit, pages = 1)

par(mfrow = c(1, 1))

# 检查模型
gam.check(gam_fit)

## 
## Method: GCV   Optimizer: magic
## Smoothing parameter selection converged after 8 iterations.
## The RMS GCV score gradient at convergence was 1.39935e-06 .
## The Hessian was positive definite.
## Model rank =  19 / 19 
## 
## Basis dimension (k) checking results. Low p-value (k-index<1) may
## indicate that k is too low, especially if edf is close to k'.
## 
##         k'  edf k-index p-value  
## s(x1) 9.00 6.41    1.02   0.635  
## s(x2) 9.00 5.90    0.92   0.065 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
# 比较不同基函数维度
gam_fit_k10 <- mgcv::gam(y ~ s(x1, k = 10) + s(x2, k = 10), data = gam_data)
gam_fit_k20 <- mgcv::gam(y ~ s(x1, k = 20) + s(x2, k = 20), data = gam_data)

cat("\n========== GAM模型比较 ==========\n")
## 
## ========== GAM模型比较 ==========
cat(sprintf("默认k AIC: %.2f\n", AIC(gam_fit)))
## 默认k AIC: 825.16
cat(sprintf("k=10 AIC: %.2f\n", AIC(gam_fit_k10)))
## k=10 AIC: 825.16
cat(sprintf("k=20 AIC: %.2f\n", AIC(gam_fit_k20)))
## k=20 AIC: 822.41
# 可视化拟合曲面
vis.gam(gam_fit, theta = 30, phi = 30, main = "GAM拟合曲面")

第九章小结

核心知识点总结

主题 核心内容 关键函数
核密度估计 非参数密度估计 density()
LOESS 局部加权回归 loess()
B样条 分段多项式 bs()
自然样条 边界线性延伸 ns()
光滑样条 惩罚平滑 smooth.spline()
GAM 加性模型 mgcv::gam()

第十章：计量经济学专门方法

计量经济学方法在医学研究中广泛应用于因果推断、政策评估等领域。本章将系统讲解工具变量、断点回归、双重差分、倾向得分匹配等方法。

10.1 工具变量法

意义与使用场景

核心意义：工具变量法用于解决内生性问题，当解释变量与误差项相关时，通过工具变量获得一致的估计。

举例：使用医生处方偏好作为药物使用的工具变量

为什么这种数据适合用工具变量法？

首先，药物使用可能存在内生性：选择用药的患者可能与未用药患者在不可观测因素上存在差异（如健康意识、疾病严重程度）。其次，我们有一个有效的工具变量：医生的处方偏好（与患者特征无关，但影响患者是否用药）。工具变量法能够利用工具变量的外生变异，获得药物效应的一致估计。

研究目的是什么？

本研究有三个层次的目的：1. 解决内生性：处理药物使用与误差项相关导致的内生性问题；2. 估计因果效应：获得药物使用对健康结果的因果效应估计；3. 检验工具变量：验证工具变量的相关性和外生性。

可能得到什么样的结果？

假设工具变量分析显示：2SLS估计β=0.25（p=0.02），OLS估计β=0.15（p=0.10）。

  1. 内生性检验：Durbin-Wu-Hausman检验p=0.03，拒绝外生性假设，OLS估计有偏。
  2. 第一阶段：医生处方偏好与药物使用显著相关（F=35.6），工具变量相关性强。
  3. 因果效应：2SLS估计药物效应β=0.25，比OLS估计（β=0.15）更大，说明OLS低估了药物效应。
  4. 外生性检验：Sargan检验p=0.45，不能拒绝工具变量外生性假设。

需要注意什么？

工具变量需满足两个条件：相关性（与内生变量强相关，第一阶段F>10）和外生性（与误差项不相关）。弱工具变量会导致估计不准确，需检验第一阶段F统计量。外生性无法直接检验，需基于理论和背景知识判断。工具变量估计是局部平均处理效应（LATE），仅对”依从者”有效。

数学基础

内生性问题：

当\(Cov(X, \varepsilon) \neq 0\)时，OLS估计有偏。

工具变量（IV）条件：

  1. 相关性：\(Cov(Z, X) \neq 0\)
  2. 外生性：\(Cov(Z, \varepsilon) = 0\)

两阶段最小二乘（2SLS）：

第一阶段：\(\hat{X} = \hat{\pi}_0 + \hat{\pi}_1 Z\) 第二阶段：\(\hat{Y} = \hat{\beta}_0 + \hat{\beta}_1 \hat{X}\)

弱工具变量检验：

第一阶段F统计量 > 10表示工具变量足够强。

代码实现

# 模拟IV数据
set.seed(1111)
n_iv <- 500

# 工具变量
z <- rnorm(n_iv)

# 内生变量（与误差相关）
epsilon <- rnorm(n_iv)
x <- 0.5 * z + epsilon + rnorm(n_iv, 0, 0.5)

# 因变量
y <- 2 + 1.5 * x + epsilon + rnorm(n_iv, 0, 1)

iv_data <- data.frame(y = y, x = x, z = z)

# OLS估计（有偏）
ols_model <- lm(y ~ x, data = iv_data)
cat("========== OLS估计（有偏） ==========\n")
## ========== OLS估计（有偏） ==========
print(coef(ols_model))
## (Intercept)           x 
##    1.993248    2.158038
# 2SLS估计
library(AER)
iv_model <- AER::ivreg(y ~ x | z, data = iv_data)
summary(iv_model, diagnostics = TRUE)
## 
## Call:
## AER::ivreg(formula = y ~ x | z, data = iv_data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -4.0255 -1.0088 -0.0434  1.0222  4.7738 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  1.90249    0.06934  27.439   <2e-16 ***
## x            1.33331    0.14226   9.372   <2e-16 ***
## 
## Diagnostic tests:
##                  df1 df2 statistic p-value    
## Weak instruments   1 498     97.79  <2e-16 ***
## Wu-Hausman         1 497     78.97  <2e-16 ***
## Sargan             0  NA        NA      NA    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.51 on 498 degrees of freedom
## Multiple R-Squared: 0.7062,  Adjusted R-squared: 0.7056 
## Wald test: 87.84 on 1 and 498 DF,  p-value: < 2.2e-16
# 第一阶段回归
first_stage <- lm(x ~ z, data = iv_data)
cat("\n========== 第一阶段F统计量 ==========\n")
## 
## ========== 第一阶段F统计量 ==========
f_stat <- summary(first_stage)$fstatistic
cat(sprintf("F = %.2f (> 10表示强工具变量)\n", f_stat[1]))
## F = 97.79 (> 10表示强工具变量)
# 弱工具变量检验
cat("\n========== 弱工具变量检验 ==========\n")
## 
## ========== 弱工具变量检验 ==========
print(summary(iv_model, diagnostics = TRUE)$diagnostics)
##                  df1 df2 statistic      p-value
## Weak instruments   1 498  97.78914 3.574747e-21
## Wu-Hausman         1 497  78.96734 1.162513e-17
## Sargan             0  NA        NA           NA

10.2 断点回归设计

意义与使用场景

核心意义：断点回归设计（RDD）利用政策实施的临界点进行因果推断，是准实验方法中最接近随机对照试验的设计。

举例：评估医保政策（年龄≥65岁获得补贴）的健康效应

为什么这种数据适合用断点回归设计？

首先，医保补贴政策有明确的年龄门槛（65岁），形成自然的临界点。其次，在临界点附近，年龄略小于65岁和略大于65岁的人群在可观测和不可观测特征上应该相似（局部随机化假设）。断点回归设计利用这一临界点，比较临界点两侧的结果差异，估计政策的因果效应。

研究目的是什么？

本研究有三个层次的目的：1. 估计政策效应：计算医保补贴对医疗支出或健康结果的因果效应；2. 检验局部随机化：验证临界点附近人群的特征是否平衡；3. 敏感性分析：检验结果对带宽选择的敏感性。

可能得到什么样的结果？

假设断点回归分析显示：在65岁临界点处，医疗支出下降500元（p<0.001）。

  1. 处理效应：医保补贴使医疗支出下降500元，效应显著。
  2. 局部随机化：临界点附近人群的年龄、性别、收入等特征平衡，支持局部随机化假设。
  3. 带宽敏感性：在不同带宽（5岁、10岁）下结果稳健。
  4. 平滑性检验：结果变量在临界点处存在跳跃，支持断点存在。

需要注意什么？

断点回归的核心假设是临界点附近个体特征的连续性。需检验临界点附近人群的特征是否平衡，运行变量的密度是否连续（无操纵）。带宽选择影响估计精度和偏差：带宽越小偏差越小但方差越大。建议使用最优带宽选择方法（如IK、CCT）并进行敏感性分析。

数学基础

断点回归（RDD）：

利用政策实施的临界点进行因果推断。

清晰断点：

处理状态在临界点处完全确定： \[D_i = \mathbf{1}(X_i \geq c)\]

模糊断点：

处理概率在临界点处跳跃。

估计量：

\[\tau_{RD} = \lim_{x \downarrow c} E[Y|X=x] - \lim_{x \uparrow c} E[Y|X=x]\]

代码实现

# 模拟RDD数据
set.seed(2222)
n_rdd <- 500

# 运行变量（如年龄）
x_rdd <- rnorm(n_rdd, 65, 10)

# 处理：年龄>=65岁获得补贴
treatment <- as.integer(x_rdd >= 65)

# 结果：医疗支出（处理效应为-500）
y_rdd <- 3000 - 500 * treatment + 20 * (x_rdd - 65) + 
         10 * (x_rdd - 65)^2 / 100 + rnorm(n_rdd, 0, 300)

rdd_data <- data.frame(x = x_rdd, treatment = treatment, y = y_rdd)

# 可视化断点
ggplot2::ggplot(rdd_data, ggplot2::aes(x = x, y = y, color = factor(treatment))) +
  ggplot2::geom_point(alpha = 0.5) +
  ggplot2::geom_vline(xintercept = 65, linetype = "dashed", color = "red") +
  ggplot2::geom_smooth(data = subset(rdd_data, x < 65), method = "loess", se = FALSE) +
  ggplot2::geom_smooth(data = subset(rdd_data, x >= 65), method = "loess", se = FALSE) +
  ggplot2::labs(title = "断点回归设计", x = "运行变量", y = "结果", color = "处理") +
  ggplot2::theme_minimal()

# 使用rdrobust包
library(rdrobust)
rdd_result <- rdrobust::rdrobust(y_rdd, x_rdd, c = 65)
summary(rdd_result)
## Sharp RD estimates using local polynomial regression.
## 
## Number of Obs.                  500
## BW type                       mserd
## Kernel                   Triangular
## VCE method                       NN
## 
## Number of Obs.                  247          253
## Eff. Number of Obs.             124          131
## Order est. (p)                    1            1
## Order bias  (q)                   2            2
## BW est. (h)                   6.954        6.954
## BW bias (b)                  11.580       11.580
## rho (h/b)                     0.601        0.601
## Unique Obs.                     247          253
## 
## =====================================================================
##                    Point    Robust Inference
##                 Estimate         z     P>|z|      [ 95% C.I. ]       
## ---------------------------------------------------------------------
##      RD Effect  -484.482    -4.743     0.000  [-656.350 , -272.509]  
## =====================================================================
# 带宽敏感性分析
rdbwselect(y_rdd, x_rdd, c = 65)
## Call: rdbwselect
## 
## Number of Obs.                  500
## BW type                       mserd
## Kernel                   Triangular
## VCE method                       NN
## 
## Number of Obs.                  247          253
## Order est. (p)                    1            1
## Order bias  (q)                   2            2
## Unique Obs.                     247          253

10.3 双重差分法

意义与使用场景

核心意义：双重差分法（DID）通过比较处理组和对照组在政策实施前后的变化差异，估计政策效应。

举例：评估医保政策改革的健康效应

为什么这种数据适合用双重差分法？

首先，医保政策改革在某个时间点实施，形成自然实验。其次，我们有处理组（受政策影响的地区）和对照组（不受影响的地区）在政策前后的数据。双重差分法通过比较两组在政策前后的变化差异，消除组间固有差异和时间趋势，估计政策的因果效应。

研究目的是什么？

本研究有三个层次的目的：1. 估计政策效应：计算医保改革对医疗支出或健康结果的因果效应；2. 检验平行趋势：验证处理组和对照组在政策前是否有相同的趋势；3. 控制混杂：消除组间差异和时间趋势的影响。

可能得到什么样的结果？

假设双重差分分析显示：DID效应=15（p=0.02），平行趋势假设成立。

  1. 处理效应：医保改革使处理组的健康结果提高15个单位，效应显著。
  2. 平行趋势检验：政策前处理组和对照组的趋势无显著差异（p=0.45），平行趋势假设成立。
  3. 时间效应：两组随时间都有改善，但处理组改善更多。
  4. 组间差异：处理组基线水平比对照组高10个单位，但DID消除了这一差异。

需要注意什么？

双重差分法的核心假设是平行趋势：若无政策，两组的变化趋势相同。建议绘制趋势图直观检验，并进行事件研究分析。若平行趋势假设不成立，可考虑使用合成控制法或倾向得分匹配结合DID。还需注意政策的外溢效应和处理组的选择偏差。

数学基础

双重差分（DID）：

比较处理组和对照组在政策实施前后的变化差异。

模型形式： \[Y_{it} = \beta_0 + \beta_1 Post_t + \beta_2 Treat_i + \beta_3 (Post_t \times Treat_i) + \varepsilon_{it}\]

DID估计量： \[\hat{\tau}_{DID} = (\bar{Y}_{Treat,Post} - \bar{Y}_{Treat,Pre}) - (\bar{Y}_{Control,Post} - \bar{Y}_{Control,Pre})\]

平行趋势假设：

处理组和对照组在无政策情况下的趋势相同。

代码实现

# 模拟DID数据
set.seed(3333)
n_units <- 100
n_periods <- 6

did_data <- data.frame(
  id = rep(1:n_units, each = n_periods),
  time = rep(1:n_periods, n_units),
  treat = rep(c(0, 1), each = n_units * n_periods / 2)
)

# 政策实施时间点（第4期）
did_data$post <- as.integer(did_data$time >= 4)

# 生成结果
did_data$y <- 100 + 
              5 * did_data$time +                           # 时间趋势
              10 * did_data$treat +                         # 组间差异
              15 * did_data$post * did_data$treat +         # DID效应
              rnorm(nrow(did_data), 0, 5)

# DID估计
did_model <- lm(y ~ treat * post + factor(time), data = did_data)
summary(did_model)
## 
## Call:
## lm(formula = y ~ treat * post + factor(time), data = did_data)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -17.6062  -3.4153  -0.1053   3.7769  19.8222 
## 
## Coefficients: (1 not defined because of singularities)
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   105.4245     0.5981 176.259  < 2e-16 ***
## treat           9.4204     0.5981  15.750  < 2e-16 ***
## post           24.3948     0.8459  28.840  < 2e-16 ***
## factor(time)2   5.1617     0.7325   7.046 5.13e-12 ***
## factor(time)3   9.9177     0.7325  13.539  < 2e-16 ***
## factor(time)4  -9.1285     0.7325 -12.461  < 2e-16 ***
## factor(time)5  -5.0587     0.7325  -6.906 1.29e-11 ***
## factor(time)6       NA         NA      NA       NA    
## treat:post     14.9238     0.8459  17.643  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 5.18 on 592 degrees of freedom
## Multiple R-squared:  0.8937, Adjusted R-squared:  0.8924 
## F-statistic: 710.7 on 7 and 592 DF,  p-value: < 2.2e-16
# 提取DID效应
did_effect <- coef(did_model)["treat:post"]
cat(sprintf("\nDID效应: %.2f\n", did_effect))
## 
## DID效应: 14.92
# 平行趋势检验（事件研究法）
did_data$time_to_treat <- did_data$time - 4
did_data$time_to_treat <- factor(did_data$time_to_treat)

es_model <- lm(y ~ treat * time_to_treat, data = did_data)
summary(es_model)
## 
## Call:
## lm(formula = y ~ treat * time_to_treat, data = did_data)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -17.7200  -3.3967  -0.1658   3.6491  19.4456 
## 
## Coefficients:
##                       Estimate Std. Error t value Pr(>|t|)    
## (Intercept)           105.5383     0.7323 144.114  < 2e-16 ***
## treat                   9.1929     1.0357   8.876  < 2e-16 ***
## time_to_treat-2         4.9748     1.0357   4.804 1.98e-06 ***
## time_to_treat-1         9.7634     1.0357   9.427  < 2e-16 ***
## time_to_treat0         14.7758     1.0357  14.267  < 2e-16 ***
## time_to_treat1         18.7262     1.0357  18.081  < 2e-16 ***
## time_to_treat2         25.1539     1.0357  24.288  < 2e-16 ***
## treat:time_to_treat-2   0.3738     1.4646   0.255    0.799    
## treat:time_to_treat-1   0.3086     1.4646   0.211    0.833    
## treat:time_to_treat0   15.9046     1.4646  10.859  < 2e-16 ***
## treat:time_to_treat1   16.1436     1.4646  11.022  < 2e-16 ***
## treat:time_to_treat2   13.4056     1.4646   9.153  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 5.178 on 588 degrees of freedom
## Multiple R-squared:  0.8944, Adjusted R-squared:  0.8925 
## F-statistic: 452.9 on 11 and 588 DF,  p-value: < 2.2e-16
# 可视化平行趋势
trend_data <- did_data %>%
  dplyr::group_by(time, treat) %>%
  dplyr::summarise(mean_y = mean(y), .groups = "drop")

ggplot2::ggplot(trend_data, ggplot2::aes(x = time, y = mean_y, color = factor(treat))) +
  ggplot2::geom_line(linewidth = 1) +
  ggplot2::geom_vline(xintercept = 3.5, linetype = "dashed", color = "red") +
  ggplot2::labs(title = "双重差分平行趋势", x = "时间", y = "结果均值", color = "组别") +
  ggplot2::theme_minimal()

10.4 倾向得分匹配

意义与使用场景

核心意义：倾向得分匹配（PSM）通过匹配倾向得分相似的个体，模拟随机对照试验，减少选择偏差。

举例：比较不同治疗方案的效果

为什么这种数据适合用倾向得分匹配？

首先，治疗方案的选择是非随机的：病情严重的患者更可能选择积极治疗，导致选择偏差。其次，我们有多个可观测的混杂因素（如年龄、病情严重程度、合并症），需要控制这些因素。倾向得分匹配通过匹配倾向得分相似的个体，模拟随机对照试验，减少可观测混杂因素的影响。

研究目的是什么？

本研究有三个层次的目的：1. 减少选择偏差：通过匹配控制可观测混杂因素；2. 估计处理效应：计算平均处理效应（ATT）；3. 检验平衡性：验证匹配后处理组和对照组的协变量分布是否平衡。

可能得到什么样的结果？

假设倾向得分匹配分析显示：ATT=8.5（p=0.01），匹配后协变量平衡。

  1. 处理效应：积极治疗比保守治疗的平均处理效应为8.5个单位，效应显著。
  2. 平衡性检验：匹配后处理组和对照组在年龄、病情严重程度等协变量上标准化差异<0.1，平衡良好。
  3. 匹配质量：匹配后样本量从400减少到320，损失20%的样本。
  4. 敏感性分析：敏感性分析显示结果对未观测混杂因素较稳健。

需要注意什么？

倾向得分匹配只能控制可观测混杂因素，无法处理未观测混杂。需检验匹配后的平衡性，标准化差异应<0.1。匹配方法（最近邻、半径、核匹配）的选择可能影响结果，建议进行敏感性分析。共同支撑假设要求处理组和对照组的倾向得分有足够的重叠区域。

数学基础

倾向得分：

给定协变量，接受处理的概率： \[e(X) = P(D = 1 | X)\]

匹配方法：

方法 描述
最近邻匹配 选择倾向得分最接近的对照
半径匹配 在指定半径内匹配
核匹配 使用核函数加权

平衡性检验：

匹配后处理组和对照组的协变量分布应相似。

代码实现

# 模拟PSM数据
set.seed(4444)
n_psm <- 400

# 协变量
age_psm <- rnorm(n_psm, 50, 10)
gender_psm <- rbinom(n_psm, 1, 0.5)
severity_psm <- rnorm(n_psm, 0, 1)

# 处理（与协变量相关）
ps <- 1 / (1 + exp(-(-2 + 0.05 * age_psm + 0.3 * gender_psm + 0.5 * severity_psm)))
treatment_psm <- rbinom(n_psm, 1, ps)

# 结果（处理效应为10）
y_psm <- 50 + 0.5 * age_psm + 5 * gender_psm + 10 * severity_psm + 
         10 * treatment_psm + rnorm(n_psm, 0, 5)

psm_data <- data.frame(
  age = age_psm,
  gender = factor(gender_psm, levels = c(0, 1), labels = c("女", "男")),
  severity = severity_psm,
  treatment = factor(treatment_psm, levels = c(0, 1), labels = c("对照", "处理")),
  y = y_psm
)

# 估计倾向得分
ps_model <- glm(treatment ~ age + gender + severity, 
                data = psm_data, family = binomial(link = "logit"))
summary(ps_model)
## 
## Call:
## glm(formula = treatment ~ age + gender + severity, family = binomial(link = "logit"), 
##     data = psm_data)
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -2.68186    0.61555  -4.357 1.32e-05 ***
## age          0.06301    0.01227   5.135 2.83e-07 ***
## gender男     0.39506    0.22510   1.755   0.0793 .  
## severity     0.52500    0.11589   4.530 5.89e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 520.39  on 399  degrees of freedom
## Residual deviance: 464.19  on 396  degrees of freedom
## AIC: 472.19
## 
## Number of Fisher Scoring iterations: 4
psm_data$ps <- fitted(ps_model)

# 使用MatchIt包进行匹配
library(MatchIt)
match_result <- MatchIt::matchit(treatment ~ age + gender + severity, 
                                  data = psm_data, method = "nearest")

# 查看匹配结果
summary(match_result)
## 
## Call:
## MatchIt::matchit(formula = treatment ~ age + gender + severity, 
##     data = psm_data, method = "nearest")
## 
## Summary of Balance for All Data:
##          Means Treated Means Control Std. Mean Diff. Var. Ratio eCDF Mean
## distance        0.6926        0.5586          0.8407     0.8843    0.2180
## age            52.4786       46.8038          0.5793     1.0434    0.1553
## gender女        0.4651        0.5704         -0.2111          .    0.1053
## gender男        0.5349        0.4296          0.2111          .    0.1053
## severity        0.1974       -0.3069          0.4931     1.0443    0.1476
##          eCDF Max
## distance   0.3512
## age        0.2551
## gender女   0.1053
## gender男   0.1053
## severity   0.2612
## 
## Summary of Balance for Matched Data:
##          Means Treated Means Control Std. Mean Diff. Var. Ratio eCDF Mean
## distance        0.8121        0.5586          1.5907     0.1784    0.4308
## age            57.9816       46.8038          1.1411     0.7181    0.3233
## gender女        0.3803        0.5704         -0.3812          .    0.1901
## gender男        0.6197        0.4296          0.3812          .    0.1901
## severity        0.6429       -0.3069          0.9288     0.8655    0.2676
##          eCDF Max Std. Pair Dist.
## distance   0.7887          1.5907
## age        0.4718          1.2636
## gender女   0.1901          0.9742
## gender男   0.1901          0.9742
## severity   0.3732          1.1413
## 
## Sample Sizes:
##           Control Treated
## All           142     258
## Matched       142     142
## Unmatched       0     116
## Discarded       0       0
# 平衡性检验
plot(match_result, type = "jitter")

## To identify the units, use first mouse button; to stop, use second.
# 提取匹配后的数据
matched_data <- MatchIt::match.data(match_result)

# 估计处理效应
att_model <- lm(y ~ treatment, data = matched_data)
summary(att_model)
## 
## Call:
## lm(formula = y ~ treatment, data = matched_data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -26.818  -8.302  -0.805   7.438  32.237 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept)    72.0977     0.9452   76.28   <2e-16 ***
## treatment处理  26.8852     1.3367   20.11   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 11.26 on 282 degrees of freedom
## Multiple R-squared:  0.5893, Adjusted R-squared:  0.5878 
## F-statistic: 404.6 on 1 and 282 DF,  p-value: < 2.2e-16
cat(sprintf("\nATT（平均处理效应）: %.2f\n", coef(att_model)[2]))
## 
## ATT（平均处理效应）: 26.89

10.5 分位数回归

意义与使用场景

核心意义：分位数回归估计不同分位数的条件分布，比均值回归提供更全面的变量关系描述。

举例：分析不同收入水平对医疗支出的影响差异

为什么这种数据适合用分位数回归？

首先，医疗支出分布通常右偏，均值受极端值影响大，不能代表典型情况。其次，收入对医疗支出的影响可能因支出水平不同而异：对低支出群体影响小（基本医疗需求），对高支出群体影响大（选择性医疗）。分位数回归能够估计不同分位数的条件分布，揭示变量效应的异质性。

研究目的是什么？

本研究有三个层次的目的：1. 全面描述关系：估计收入对医疗支出在不同分位数上的影响；2. 揭示异质性：判断收入效应是否因支出水平不同而异；3. 对比均值回归：比较分位数回归与均值回归的结果差异。

可能得到什么样的结果？

假设分位数回归显示：收入对医疗支出的效应在0.25分位数为0.2，在0.5分位数为0.3，在0.75分位数为0.5。

  1. 低支出群体（0.25分位数）：收入每增加1000元，医疗支出增加0.2千元，效应较小。
  2. 中等支出群体（0.5分位数）：收入每增加1000元，医疗支出增加0.3千元，效应中等。
  3. 高支出群体（0.75分位数）：收入每增加1000元，医疗支出增加0.5千元，效应较大。
  4. 异质性：收入对医疗支出的影响随支出水平增加而增强，存在异质性效应。

需要注意什么？

分位数回归对异常值稳健，但需要足够的样本量来估计极端分位数（如0.1、0.9）。分位数回归的系数解释与均值回归不同：系数表示自变量对因变量特定分位数的边际效应。建议同时估计多个分位数并绘制系数变化图，全面了解变量效应的异质性。

数学基础

分位数回归：

估计条件分位数函数： \[Q_\tau(Y|X) = X'\beta(\tau)\]

参数说明： - \(\tau\)：分位数（如0.25, 0.5, 0.75） - \(\beta(\tau)\)：第\(\tau\)分位数的回归系数

估计方法：

最小化加权绝对误差： \[\min_{\beta} \sum_{i=1}^{n} \rho_\tau(y_i - x_i'\beta)\]

其中\(\rho_\tau(u) = u(\tau - I(u < 0))\)。

代码实现

# 模拟异质性数据
set.seed(5555)
n_qr <- 300
x_qr <- rnorm(n_qr, 50, 10)

# 不同分位数有不同的效应
y_qr <- 100 + 0.5 * x_qr + (5 + 0.1 * x_qr) * rnorm(n_qr, 0, 1)

qr_data <- data.frame(x = x_qr, y = y_qr)

# 分位数回归
library(quantreg)
qr_25 <- quantreg::rq(y ~ x, data = qr_data, tau = 0.25)
qr_50 <- quantreg::rq(y ~ x, data = qr_data, tau = 0.5)
qr_75 <- quantreg::rq(y ~ x, data = qr_data, tau = 0.75)

# 比较结果
cat("========== 分位数回归系数比较 ==========\n")
## ========== 分位数回归系数比较 ==========
cat(sprintf("25%%分位数: 截距=%.2f, 斜率=%.3f\n", coef(qr_25)[1], coef(qr_25)[2]))
## 25%分位数: 截距=100.18, 斜率=0.336
cat(sprintf("50%%分位数: 截距=%.2f, 斜率=%.3f\n", coef(qr_50)[1], coef(qr_50)[2]))
## 50%分位数: 截距=102.53, 斜率=0.447
cat(sprintf("75%%分位数: 截距=%.2f, 斜率=%.3f\n", coef(qr_75)[1], coef(qr_75)[2]))
## 75%分位数: 截距=105.52, 斜率=0.525
# OLS比较
ols_qr <- lm(y ~ x, data = qr_data)
cat(sprintf("OLS均值: 截距=%.2f, 斜率=%.3f\n", coef(ols_qr)[1], coef(ols_qr)[2]))
## OLS均值: 截距=100.59, 斜率=0.480
# 可视化
ggplot2::ggplot(qr_data, ggplot2::aes(x = x, y = y)) +
  ggplot2::geom_point(alpha = 0.5) +
  ggplot2::geom_abline(intercept = coef(qr_25)[1], slope = coef(qr_25)[2], 
                       color = "blue", linetype = "dashed") +
  ggplot2::geom_abline(intercept = coef(qr_50)[1], slope = coef(qr_50)[2], 
                       color = "red") +
  ggplot2::geom_abline(intercept = coef(qr_75)[1], slope = coef(qr_75)[2], 
                       color = "blue", linetype = "dashed") +
  ggplot2::geom_abline(intercept = coef(ols_qr)[1], slope = coef(ols_qr)[2], 
                       color = "green") +
  ggplot2::labs(title = "分位数回归 vs OLS",
                subtitle = "蓝线=25%/75%分位数，红线=中位数，绿线=OLS均值",
                x = "x", y = "y") +
  ggplot2::theme_minimal()

# 多分位数回归
qr_multi <- quantreg::rq(y ~ x, data = qr_data, tau = seq(0.1, 0.9, 0.1))
plot(summary(qr_multi), parm = "x", main = "不同分位数的斜率系数")

第十章小结

核心知识点总结

主题 核心内容 关键函数
工具变量 2SLS估计 AER::ivreg()
断点回归 临界点因果推断 rdrobust::rdrobust()
双重差分 政策评估 lm() 交互项
倾向得分匹配 因果推断 MatchIt::matchit()
分位数回归 条件分位数估计 quantreg::rq()

第十一章：模型选择与诊断

模型选择与诊断是统计建模的重要环节，确保模型的合理性和可靠性。本章将系统讲解信息准则、交叉验证、残差诊断等内容。

11.1 信息准则

意义与使用场景

核心意义：信息准则用于在模型拟合优度和复杂度之间取得平衡，帮助选择最优模型。

举例：选择疾病风险预测模型的最优变量组合

为什么这种数据适合用信息准则？

首先，我们有多个候选预测变量（年龄、性别、血压、血糖等），需要选择最优的变量组合。其次，增加变量会提高拟合优度但也增加复杂度，可能导致过拟合。信息准则通过惩罚项平衡拟合优度和复杂度，帮助选择既能很好拟合数据又不过度复杂的模型。

研究目的是什么？

本研究有三个层次的目的：1. 比较候选模型：评估不同变量组合的模型质量；2. 选择最优模型：根据信息准则选择最优模型；3. 避免过拟合：通过惩罚项防止选择过于复杂的模型。

可能得到什么样的结果？

假设信息准则比较显示：模型2（年龄+血压+血糖）AIC=850，BIC=865，均为最小。

  1. 模型选择：模型2包含年龄、血压、血糖三个变量，比模型1（仅年龄）拟合更好，比模型3（加性别）更简洁。
  2. AIC vs BIC：AIC选择模型2，BIC也选择模型2，结果一致。
  3. 预测性能：模型2的交叉验证误差最低，验证了信息准则的选择。
  4. 变量重要性：血压的系数最大，是最重要的预测变量。

需要注意什么？

AIC倾向于选择较复杂的模型，BIC倾向于选择较简单的模型。当样本量较大时，BIC的惩罚更重，可能选择更简单的模型。信息准则只能比较同一数据上的模型，不能比较不同数据或不同因变量的模型。建议结合交叉验证评估预测性能。

数学基础

常用信息准则：

准则 公式 特点
AIC \(-2\ell + 2k\) 倾向选择复杂模型
BIC \(-2\ell + k\log(n)\) 倾向选择简单模型
HQIC \(-2\ell + 2k\log(\log(n))\) 介于AIC和BIC之间

参数说明： - \(\ell\)：对数似然 - \(k\)：参数个数 - \(n\)：样本量

选择原则：信息准则值越小，模型越好。

代码实现

# 模拟数据
set.seed(6666)
n_info <- 200
x1 <- rnorm(n_info)
x2 <- rnorm(n_info)
x3 <- rnorm(n_info)
x4 <- rnorm(n_info)
y <- 1 + 2*x1 + 3*x2 + rnorm(n_info, 0, 2)

info_data <- data.frame(y = y, x1 = x1, x2 = x2, x3 = x3, x4 = x4)

# 拟合多个模型
model1 <- lm(y ~ x1, data = info_data)
model2 <- lm(y ~ x1 + x2, data = info_data)
model3 <- lm(y ~ x1 + x2 + x3, data = info_data)
model4 <- lm(y ~ x1 + x2 + x3 + x4, data = info_data)

# 比较信息准则
info_compare <- data.frame(
  Model = c("x1", "x1+x2", "x1+x2+x3", "x1+x2+x3+x4"),
  AIC = c(AIC(model1), AIC(model2), AIC(model3), AIC(model4)),
  BIC = c(BIC(model1), BIC(model2), BIC(model3), BIC(model4))
)
cat("========== 信息准则比较 ==========\n")
## ========== 信息准则比较 ==========
print(info_compare)
##         Model       AIC       BIC
## 1          x1 1094.1624 1104.0573
## 2       x1+x2  870.2638  883.4571
## 3    x1+x2+x3  870.2093  886.7009
## 4 x1+x2+x3+x4  871.8023  891.5922
# 使用AICc（小样本校正）
library(AICcmodavg)
cat("\n========== AICc比较 ==========\n")
## 
## ========== AICc比较 ==========
cat(sprintf("Model 1 AICc: %.2f\n", AICcmodavg::AICc(model1)))
## Model 1 AICc: 1094.28
cat(sprintf("Model 2 AICc: %.2f\n", AICcmodavg::AICc(model2)))
## Model 2 AICc: 870.47

11.2 交叉验证

意义与使用场景

核心意义：交叉验证通过多次训练-验证分割评估模型的预测性能，是模型评估的金标准方法。

举例：评估疾病预测模型的泛化能力

为什么这种数据适合用交叉验证？

首先，我们需要评估模型在新数据上的预测性能，而不仅仅是在训练数据上的拟合效果。其次，我们担心模型过拟合：在训练数据上表现好，但在新数据上表现差。交叉验证通过多次训练-验证分割，评估模型的泛化能力，是避免过拟合、评估预测性能的标准方法。

研究目的是什么？

本研究有三个层次的目的：1. 评估预测性能：估计模型在新数据上的预测误差；2. 模型比较：比较不同模型的预测性能；3. 避免过拟合：检测模型是否过度拟合训练数据。

可能得到什么样的结果？

假设10折交叉验证显示：模型2的CV误差=2.5，低于模型1（3.2）和模型3（2.6）。

  1. 预测性能：模型2的交叉验证误差最低，预测性能最好。
  2. 过拟合检测：模型3的训练误差（2.0）低于模型2（2.3），但验证误差更高，说明存在过拟合。
  3. 模型稳定性：模型2在不同折的误差变化较小（标准差=0.3），模型稳定性好。
  4. 最终选择：综合考虑预测性能和稳定性，选择模型2作为最终模型。

需要注意什么？

K折交叉验证的K值选择：K=5或10是常用选择，K越大计算成本越高。留一交叉验证（LOOCV）计算成本高但偏差小。交叉验证结果受数据分割影响，建议设置随机种子保证可重复性。对于时间序列数据，应使用时间序列交叉验证（前向验证）。

数学基础

K折交叉验证：

  1. 将数据随机分为K份
  2. 每次用K-1份训练，1份验证
  3. 计算平均预测误差

留一交叉验证（LOOCV）：

K = n，每次留一个样本验证。

预测误差： \[CV_{(K)} = \frac{1}{K}\sum_{k=1}^{K} MSE_k\]

代码实现

# K折交叉验证
library(boot)

# 定义交叉验证函数
cv_function <- function(data, indices) {
  fit <- lm(y ~ x1 + x2, data = data[indices, ])
  return(mean((data$y[-indices] - predict(fit, data[-indices, ]))^2))
}

# 10折交叉验证
set.seed(7777)
cv_result <- boot::boot(data = info_data, statistic = cv_function, R = 10)
cat("========== 10折交叉验证MSE ==========\n")
## ========== 10折交叉验证MSE ==========
print(cv_result)
## 
## ORDINARY NONPARAMETRIC BOOTSTRAP
## 
## 
## Call:
## boot::boot(data = info_data, statistic = cv_function, R = 10)
## 
## 
## Bootstrap Statistics :
##     original  bias    std. error
## t1*      NaN     NaN   0.5931205
# 使用caret包
library(caret)
set.seed(8888)
train_control <- caret::trainControl(method = "cv", number = 10)
cv_model <- caret::train(y ~ x1 + x2, data = info_data, 
                          method = "lm", trControl = train_control)
print(cv_model)
## Linear Regression 
## 
## 200 samples
##   2 predictor
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold) 
## Summary of sample sizes: 180, 180, 180, 180, 180, 180, ... 
## Resampling results:
## 
##   RMSE      Rsquared   MAE     
##   2.087978  0.7778203  1.704433
## 
## Tuning parameter 'intercept' was held constant at a value of TRUE
# 比较不同模型的交叉验证误差
models <- list(
  model1 = y ~ x1,
  model2 = y ~ x1 + x2,
  model3 = y ~ x1 + x2 + x3
)

cv_results <- sapply(models, function(f) {
  set.seed(9999)
  result <- caret::train(f, data = info_data, method = "lm", 
                         trControl = caret::trainControl(method = "cv", number = 10))
  return(result$results$RMSE)
})

cat("\n========== 交叉验证RMSE比较 ==========\n")
## 
## ========== 交叉验证RMSE比较 ==========
print(cv_results)
##   model1   model2   model3 
## 3.682796 2.103963 2.104490

11.3 残差诊断

意义与使用场景

核心意义：残差诊断用于检验模型假设是否满足，发现数据中的问题，指导模型改进。

举例：检验线性回归的正态性、异方差性假设

为什么这种数据适合用残差诊断？

首先，线性回归模型有多个假设需要满足：残差正态性、同方差性、独立性、线性关系等。其次，违反这些假设会影响统计推断的有效性。残差诊断通过分析残差的分布和模式，检验模型假设是否满足，发现数据中的问题，指导模型改进。

研究目的是什么？

本研究有三个层次的目的：1. 检验模型假设：验证残差是否满足正态性、同方差性等假设；2. 发现问题：识别异常值、非线性关系、异方差等问题；3. 指导改进：根据诊断结果改进模型。

可能得到什么样的结果？

假设残差诊断显示：Shapiro-Wilk检验p=0.35，Breusch-Pagan检验p=0.02。

  1. 正态性：Shapiro-Wilk检验p=0.35>0.05，残差正态性假设满足。
  2. 异方差性：Breusch-Pagan检验p=0.02<0.05，存在异方差问题。
  3. 残差图：残差与拟合值的关系图呈漏斗形，确认异方差存在。
  4. 改进建议：考虑使用加权最小二乘或对因变量进行对数变换。

需要注意什么？

残差诊断应在模型拟合后立即进行，是建模的标准步骤。多种诊断方法应结合使用，不要仅依赖单一检验。发现问题后应分析原因，可能是模型设定错误、数据问题或异常值。残差诊断结果应结合专业背景解释，不要盲目追求统计假设满足。

数学基础

残差类型：

类型 公式 用途
普通残差 \(e_i = y_i - \hat{y}_i\) 基本诊断
标准化残差 \(r_i = e_i / \hat{\sigma}\) 异常值检测
学生化残差 \(t_i = e_i / (s\sqrt{1-h_{ii}})\) 异常值检测

诊断检验：

检验 目的 R函数
Shapiro-Wilk 正态性 shapiro.test()
Breusch-Pagan 异方差性 bptest()
Durbin-Watson 自相关 dwtest()
VIF 多重共线性 vif()

代码实现

# 使用模型进行诊断
diagnostic_model <- lm(y ~ x1 + x2, data = info_data)

# 残差图
par(mfrow = c(2, 2))
plot(diagnostic_model)

par(mfrow = c(1, 1))

# 正态性检验
shapiro_test <- shapiro.test(residuals(diagnostic_model))
cat("========== 正态性检验 ==========\n")
## ========== 正态性检验 ==========
print(shapiro_test)
## 
##  Shapiro-Wilk normality test
## 
## data:  residuals(diagnostic_model)
## W = 0.99286, p-value = 0.4417
# Q-Q图
qqnorm(residuals(diagnostic_model))
qqline(residuals(diagnostic_model), col = "red")

# 异方差检验
library(lmtest)
bp_test <- lmtest::bptest(diagnostic_model)
cat("\n========== Breusch-Pagan异方差检验 ==========\n")
## 
## ========== Breusch-Pagan异方差检验 ==========
print(bp_test)
## 
##  studentized Breusch-Pagan test
## 
## data:  diagnostic_model
## BP = 5.421, df = 2, p-value = 0.06651
# White检验
white_test <- lmtest::bptest(diagnostic_model, ~ x1 + x2 + I(x1^2) + I(x2^2) + x1:x2)
cat("\n========== White检验 ==========\n")
## 
## ========== White检验 ==========
print(white_test)
## 
##  studentized Breusch-Pagan test
## 
## data:  diagnostic_model
## BP = 7.9771, df = 5, p-value = 0.1575
# 自相关检验
dw_test <- lmtest::dwtest(diagnostic_model)
cat("\n========== Durbin-Watson检验 ==========\n")
## 
## ========== Durbin-Watson检验 ==========
print(dw_test)
## 
##  Durbin-Watson test
## 
## data:  diagnostic_model
## DW = 2.1292, p-value = 0.8199
## alternative hypothesis: true autocorrelation is greater than 0
# 多重共线性检验
library(car)
vif_values <- car::vif(diagnostic_model)
cat("\n========== VIF（方差膨胀因子） ==========\n")
## 
## ========== VIF（方差膨胀因子） ==========
print(vif_values)
##       x1       x2 
## 1.002271 1.002271
cat("VIF > 10表示严重多重共线性\n")
## VIF > 10表示严重多重共线性

11.4 影响点诊断

意义与使用场景

核心意义：影响点诊断识别对模型估计有重大影响的观测值，帮助发现数据问题或特殊个体。

举例：识别极端患者和发现数据录入错误

为什么这种数据适合用影响点诊断？

首先，医学数据中可能存在极端患者（如年龄特别大、病情特别严重）或数据录入错误（如身高输入为250cm）。其次，这些影响点可能对回归结果产生重大影响，改变系数估计和统计推断。影响点诊断通过计算Cook距离、杠杆值等指标，识别对模型有重大影响的观测值。

研究目的是什么？

本研究有三个层次的目的：1. 识别影响点：找出对模型估计有重大影响的观测值；2. 分析原因：判断影响点是数据错误还是真实的极端值；3. 处理影响点：决定是否删除或调整影响点。

可能得到什么样的结果？

假设影响点诊断显示：发现3个高影响点，Cook距离均>4/n。

  1. 影响点识别：第45、128、256号观测的Cook距离分别为0.15、0.12、0.18，均超过临界值4/n=0.02。
  2. 原因分析：第45号患者年龄为120岁（数据录入错误），第128号患者病情极重（真实极端值），第256号患者为特殊病例。
  3. 处理建议：删除第45号（数据错误），保留第128、256号（真实极端值但需报告）。
  4. 敏感性分析：删除影响点后，血压系数从0.25变为0.28，结果稳健。

需要注意什么？

影响点不一定是错误数据，可能是真实的极端值，删除前应仔细分析原因。删除影响点后应重新拟合模型并比较结果。高杠杆点不一定是影响点，需结合残差分析。建议进行敏感性分析，报告有无影响点时的结果差异。

数学基础

影响点度量：

指标 公式 临界值
杠杆值 \(h_{ii}\) \(2(p+1)/n\)
Cook距离 \(D_i = \frac{e_i^2}{p\hat{\sigma}^2}\frac{h_{ii}}{(1-h_{ii})^2}\) \(4/n\)
DFFITS \(DFFITS_i = \frac{\hat{y}_i - \hat{y}_{i(i)}}{s_{(i)}\sqrt{h_{ii}}}\) \(2\sqrt{p/n}\)
DFBETAS \(DFBETAS_{ij} = \frac{\hat{\beta}_j - \hat{\beta}_{j(i)}}{s_{(i)}\sqrt{(X'X)^{-1}_{jj}}}\) \(2/\sqrt{n}\)

代码实现

# 计算影响度量
influence_measures <- influence.measures(diagnostic_model)
cat("========== 影响点检测 ==========\n")
## ========== 影响点检测 ==========
print(summary(influence_measures))
## Potentially influential observations of
##   lm(formula = y ~ x1 + x2, data = info_data) :
## 
##     dfb.1_ dfb.x1 dfb.x2 dffit   cov.r   cook.d hat    
## 8   -0.16  -0.08   0.00  -0.17    0.95_*  0.01   0.01  
## 9    0.15  -0.06   0.05   0.18    0.95_*  0.01   0.01  
## 53   0.07   0.05  -0.13   0.15    1.05_*  0.01   0.04  
## 56  -0.01   0.01  -0.04  -0.04    1.05_*  0.00   0.04  
## 61  -0.16  -0.05  -0.15  -0.23    0.94_*  0.02   0.01  
## 69   0.01   0.00  -0.03   0.03    1.05_*  0.00   0.03  
## 78  -0.01   0.05   0.00  -0.05    1.06_*  0.00   0.05_*
## 90   0.15  -0.13  -0.01   0.21    0.94_*  0.01   0.01  
## 117 -0.03  -0.06  -0.03  -0.08    1.05_*  0.00   0.04  
## 156 -0.25  -0.35  -0.01  -0.41_*  0.90_*  0.05   0.02  
## 179  0.16  -0.06  -0.08   0.19    0.94_*  0.01   0.01  
## 198 -0.23   0.04   0.19  -0.30    0.89_*  0.03   0.01  
##          dfb.1_       dfb.x1       dfb.x2       dffit     cov.r       cook.d
## 8   -0.15866243 -0.075506257  0.002058165 -0.16895236 0.9539369 0.0093470185
## 9    0.14510139 -0.058858909  0.053859334  0.17728567 0.9467972 0.0102662429
## 53   0.06832986  0.051771640 -0.131279182  0.14785058 1.0530006 0.0073055911
## 56  -0.01032581  0.007459975 -0.036336440 -0.03964577 1.0525822 0.0005264890
## 61  -0.15939414 -0.048274190 -0.149681632 -0.23280704 0.9407328 0.0176463084
## 69   0.01490993 -0.001120730 -0.028218911  0.03099748 1.0466406 0.0003218649
## 78  -0.01027563  0.046347773 -0.002426090 -0.04914764 1.0625982 0.0008090609
## 90   0.14728834 -0.133108011 -0.014110460  0.21238486 0.9444895 0.0147110124
## 117 -0.03101069 -0.059104437 -0.034501098 -0.07507579 1.0528444 0.0018869918
## 156 -0.25364250 -0.347997366 -0.012145691 -0.41007002 0.9028486 0.0538446579
## 179  0.16329570 -0.058261724 -0.081661736  0.19421642 0.9424433 0.0122987521
## 198 -0.23009847  0.038697410  0.193039481 -0.29631855 0.8882785 0.0280493435
##             hat
## 8   0.006248516
## 9   0.006198515
## 53  0.042887421
## 56  0.035961509
## 61  0.009436255
## 69  0.030319608
## 78  0.045178717
## 90  0.008362316
## 117 0.037700434
## 156 0.018187378
## 179 0.006938887
## 198 0.009100399
# Cook距离
cook_d <- cooks.distance(diagnostic_model)
plot(cook_d, type = "h", main = "Cook距离", ylab = "Cook距离")
abline(h = 4/nrow(info_data), col = "red", lty = 2)

# 识别高影响点
influential <- which(cook_d > 4/nrow(info_data))
cat(sprintf("\n高影响点数量: %d\n", length(influential)))
## 
## 高影响点数量: 10
# 杠杆值
leverage <- hatvalues(diagnostic_model)
plot(leverage, type = "h", main = "杠杆值", ylab = "杠杆值")
abline(h = 2 * (length(coef(diagnostic_model)) / nrow(info_data)), col = "red", lty = 2)

# DFFITS
dffits_values <- dffits(diagnostic_model)
plot(dffits_values, type = "h", main = "DFFITS", ylab = "DFFITS")
abline(h = c(-2, 2) * sqrt(length(coef(diagnostic_model)) / nrow(info_data)), 
       col = "red", lty = 2)

# 移除影响点后重新拟合
if (length(influential) > 0) {
  model_clean <- lm(y ~ x1 + x2, data = info_data[-influential, ])
  cat("\n========== 移除影响点后的系数 ==========\n")
  print(coef(model_clean))
}
## 
## ========== 移除影响点后的系数 ==========
## (Intercept)          x1          x2 
##    1.354166    2.254154    3.057949

第十一章小结

核心知识点总结

主题 核心内容 关键函数
信息准则 AIC、BIC AIC(), BIC()
交叉验证 K折CV、LOOCV caret::train()
正态性检验 Shapiro-Wilk shapiro.test()
异方差检验 Breusch-Pagan lmtest::bptest()
多重共线性 VIF car::vif()
影响点 Cook距离、DFFITS cooks.distance()

第十二章：贝叶斯统计建模

贝叶斯统计提供了一种基于概率的推断框架，通过结合先验信息和数据来更新对参数的认识。本章将系统讲解贝叶斯推断原理、MCMC方法、贝叶斯回归等内容。

12.1 贝叶斯推断原理

意义与使用场景

核心意义：贝叶斯推断通过结合先验信息和观测数据，得到参数的后验分布，提供完整的概率描述。

举例：结合历史研究结果的药物效应估计

为什么这种数据适合用贝叶斯推断？

首先，我们有历史研究提供的先验信息：既往研究表明该药物的效应约为0.5，标准误为0.1。其次，当前临床试验样本量较小（n=30），仅依靠当前数据估计不确定性较大。贝叶斯推断能够整合先验信息和当前数据，得到更精确的效应估计和完整的后验分布。

研究目的是什么？

本研究有三个层次的目的：1. 整合先验信息：结合历史研究结果和当前试验数据；2. 获得完整分布：得到参数的后验分布而非点估计；3. 量化不确定性：提供可信区间而非置信区间。

可能得到什么样的结果？

假设贝叶斯分析显示：后验均值=0.45，95%可信区间=[0.32, 0.58]。

  1. 先验与数据结合：先验均值=0.5，数据均值=0.4，后验均值=0.45，介于两者之间。
  2. 精度提高：后验标准差（0.065）小于先验标准差（0.1）和数据标准误（0.08），整合信息提高了精度。
  3. 可信区间：95%可信区间[0.32, 0.58]，表示参数真值有95%概率在此区间内。
  4. 概率陈述：药物效应>0的概率为99.8%，效应>0.3的概率为95%。

需要注意什么？

先验分布的选择会影响后验结果，应进行先验敏感性分析。无信息先验可以让数据主导推断，但可能需要更多数据。贝叶斯可信区间与频率派置信区间的解释不同：可信区间是参数的概率陈述，置信区间是方法的长期性质。

数学基础

贝叶斯定理：

\[P(\theta|Y) = \frac{P(Y|\theta)P(\theta)}{P(Y)} \propto P(Y|\theta)P(\theta)\]

参数说明： - \(P(\theta|Y)\)：后验分布（Posterior） - \(P(Y|\theta)\)：似然函数（Likelihood） - \(P(\theta)\)：先验分布（Prior） - \(P(Y)\)：边际似然（Evidence）

贝叶斯推断步骤：

  1. 选择似然函数
  2. 设定先验分布
  3. 计算后验分布
  4. 进行推断和预测

代码实现

# 贝叶斯推断示例：估计正态分布均值
# 似然：Y ~ N(θ, σ²)
# 先验：θ ~ N(μ₀, τ₀²)

set.seed(11111)
n_bayes <- 50
true_theta <- 10
sigma <- 2

# 生成数据
y_bayes <- rnorm(n_bayes, mean = true_theta, sd = sigma)

# 先验参数
mu0 <- 0      # 先验均值
tau0 <- 5     # 先验标准差

# 计算后验参数（共轭先验）
y_bar <- mean(y_bayes)
tau0_sq <- tau0^2
sigma_sq <- sigma^2

# 后验均值和方差
post_var <- 1 / (1/tau0_sq + n_bayes/sigma_sq)
post_mean <- post_var * (mu0/tau0_sq + n_bayes*y_bar/sigma_sq)
post_sd <- sqrt(post_var)

cat("========== 贝叶斯推断结果 ==========\n")
## ========== 贝叶斯推断结果 ==========
cat(sprintf("样本均值: %.3f\n", y_bar))
## 样本均值: 9.604
cat(sprintf("先验均值: %.3f, 先验标准差: %.3f\n", mu0, tau0))
## 先验均值: 0.000, 先验标准差: 5.000
cat(sprintf("后验均值: %.3f, 后验标准差: %.3f\n", post_mean, post_sd))
## 后验均值: 9.573, 后验标准差: 0.282
cat(sprintf("真实值: %.3f\n", true_theta))
## 真实值: 10.000
# 可视化
theta_range <- seq(5, 15, length.out = 100)
prior_density <- dnorm(theta_range, mu0, tau0)
likelihood_density <- dnorm(theta_range, y_bar, sigma/sqrt(n_bayes))
posterior_density <- dnorm(theta_range, post_mean, post_sd)

plot_df <- data.frame(
  theta = rep(theta_range, 3),
  density = c(prior_density, likelihood_density, posterior_density),
  type = rep(c("先验", "似然", "后验"), each = length(theta_range))
)

ggplot2::ggplot(plot_df, ggplot2::aes(x = theta, y = density, color = type)) +
  ggplot2::geom_line(linewidth = 1) +
  ggplot2::geom_vline(xintercept = true_theta, linetype = "dashed", color = "black") +
  ggplot2::labs(title = "贝叶斯推断：先验、似然与后验", x = "θ", y = "密度", color = "") +
  ggplot2::theme_minimal()

12.2 MCMC方法

意义与使用场景

核心意义：MCMC方法用于从复杂的后验分布中抽样，是贝叶斯推断的核心计算工具。

举例：复杂层次模型的参数推断

为什么这种数据适合用MCMC方法？

首先，层次模型的后验分布通常没有解析解，涉及多个参数的联合分布，形式复杂。其次，我们需要从后验分布中抽取样本来进行推断，如计算后验均值、可信区间等。MCMC方法通过构建马尔可夫链，从复杂的后验分布中抽取样本，是解决这类问题的标准方法。

研究目的是什么？

本研究有三个层次的目的：1. 从后验分布抽样：获得参数的后验样本；2. 收敛诊断：确保马尔可夫链已收敛到目标分布；3. 后验推断：基于后验样本进行统计推断。

可能得到什么样的结果？

假设MCMC分析显示：4条链收敛，有效样本量>1000，后验均值稳定。

  1. 收敛诊断：Gelman-Rubin统计量\(\hat{R}\)=1.02<1.1，4条链已收敛。
  2. 有效样本量：截距项ESS=2500，斜率项ESS=1800，均>1000，样本量充足。
  3. 迹图：4条链的迹图混合良好，无明显趋势，支持收敛。
  4. 后验统计：截距后验均值=2.5（95%CI: [1.8, 3.2]），斜率后验均值=0.8（95%CI: [0.6, 1.0]）。

需要注意什么？

MCMC需要足够的迭代次数和预热期（burn-in）确保收敛。应使用多条链（至少4条）并检查收敛诊断。有效样本量（ESS）应足够大（>1000）以获得稳定的后验估计。对于复杂模型，可能需要调整采样器参数或使用更高效的算法（如HMC、NUTS）。

数学基础

马尔可夫链蒙特卡罗（MCMC）：

通过构建马尔可夫链来从后验分布中抽样。

Gibbs抽样：

依次从各参数的条件分布中抽样。

Metropolis-Hastings算法：

  1. 提出新值：\(\theta^* \sim q(\theta^*|\theta^{(t)})\)
  2. 计算接受概率：\(\alpha = \min\left(1, \frac{p(\theta^*|Y)q(\theta^{(t)}|\theta^*)}{p(\theta^{(t)}|Y)q(\theta^*|\theta^{(t)})}\right)\)
  3. 以概率\(\alpha\)接受新值

收敛诊断：

  • Gelman-Rubin统计量（\(\hat{R} < 1.1\)）
  • 迹图（Trace plot）
  • 有效样本量（ESS）

代码实现

# 使用rstanarm进行贝叶斯推断（无需编译）
library(rstanarm)

# 使用rstanarm的stan_glm估计正态分布均值
# 模拟数据
set.seed(11111)
n_bayes <- 50
true_theta <- 10
sigma <- 2
y_bayes <- rnorm(n_bayes, mean = true_theta, sd = sigma)

# 使用stan_glm拟合（仅截距模型）
bayes_fit <- rstanarm::stan_glm(y_bayes ~ 1, 
                                 family = gaussian(),
                                 prior_intercept = rstanarm::normal(0, 5),
                                 chains = 4, iter = 2000, seed = 123,
                                 refresh = 0)

# 查看结果
summary(bayes_fit)
## 
## Model Info:
##  function:     stan_glm
##  family:       gaussian [identity]
##  formula:      y_bayes ~ 1
##  algorithm:    sampling
##  sample:       4000 (posterior sample size)
##  priors:       see help('prior_summary')
##  observations: 50
##  predictors:   1
## 
## Estimates:
##               mean   sd   10%   50%   90%
## (Intercept)  9.6    0.3  9.2   9.6  10.0 
## sigma        2.3    0.2  2.0   2.3   2.6 
## 
## Fit Diagnostics:
##            mean   sd   10%   50%   90%
## mean_PPD  9.6    0.5  9.0   9.6  10.2 
## 
## The mean_ppd is the sample average posterior predictive distribution of the outcome variable (for details see help('summary.stanreg')).
## 
## MCMC diagnostics
##               mcse Rhat n_eff
## (Intercept)   0.0  1.0  2536 
## sigma         0.0  1.0  2594 
## mean_PPD      0.0  1.0  3273 
## log-posterior 0.0  1.0  1694 
## 
## For each parameter, mcse is Monte Carlo standard error, n_eff is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence Rhat=1).
# 后验统计量
cat("\n========== 后验统计量 ==========\n")
## 
## ========== 后验统计量 ==========
post_samples <- as.matrix(bayes_fit)[, "(Intercept)"]
cat(sprintf("后验均值: %.3f\n", mean(post_samples)))
## 后验均值: 9.570
cat(sprintf("后验中位数: %.3f\n", median(post_samples)))
## 后验中位数: 9.577
cat(sprintf("后验标准差: %.3f\n", sd(post_samples)))
## 后验标准差: 0.323
cat(sprintf("95%%可信区间: [%.3f, %.3f]\n", 
            quantile(post_samples, 0.025), quantile(post_samples, 0.975)))
## 95%可信区间: [8.920, 10.219]
cat(sprintf("真实值: %.3f\n", true_theta))
## 真实值: 10.000
# 后验分布可视化
plot(bayes_fit, plotfun = "hist")

12.3 贝叶斯线性回归

意义与使用场景

核心意义：贝叶斯线性回归将线性回归置于贝叶斯框架下，提供参数的完整后验分布和预测不确定性。

举例：小样本研究的风险因素分析

为什么这种数据适合用贝叶斯线性回归？

首先，样本量较小（n=50），传统频率派方法估计的不确定性较大。其次，我们有先验信息：既往研究表明血压对心血管风险的效应约为0.5。贝叶斯线性回归能够整合先验信息，获得参数的完整后验分布，并提供带有不确定性的预测区间。

研究目的是什么？

本研究有三个层次的目的：1. 整合先验信息：结合既往研究和当前数据；2. 获得完整分布：得到回归系数的后验分布；3. 预测不确定性：提供预测值和预测区间。

可能得到什么样的结果？

假设贝叶斯线性回归显示：血压系数后验均值=0.48，95%可信区间=[0.35, 0.61]。

  1. 系数估计：血压系数后验均值=0.48，介于先验（0.5）和数据估计（0.45）之间。
  2. 不确定性量化：95%可信区间[0.35, 0.61]，比频率派置信区间更窄（整合了先验信息）。
  3. 概率陈述：血压效应>0的概率>99.9%，效应>0.3的概率=98%。
  4. 预测区间：新患者的预测值=25，95%预测区间=[18, 32]，包含参数和误差的不确定性。

需要注意什么？

先验分布的选择会影响后验结果，应报告先验敏感性分析结果。贝叶斯预测区间包含参数不确定性和误差不确定性，比频率派预测区间更宽。对于复杂模型，需检查MCMC收敛性。建议使用弱信息先验作为默认选择，避免先验过于主导数据。

数学基础

贝叶斯线性回归模型：

\[Y = X\beta + \varepsilon, \quad \varepsilon \sim N(0, \sigma^2)\]

先验分布： \[\beta \sim N(\mu_\beta, \Sigma_\beta)\] \[\sigma^2 \sim \text{Inverse-Gamma}(a, b)\]

后验分布：

在共轭先验下有解析解；一般情况使用MCMC。

代码实现

# 贝叶斯线性回归
library(rstanarm)

# 模拟数据
set.seed(22222)
n_blr <- 100
x_blr <- rnorm(n_blr, 50, 10)
y_blr <- 5 + 0.5 * x_blr + rnorm(n_blr, 0, 3)

blr_data <- data.frame(x = x_blr, y = y_blr)

# 拟合贝叶斯线性回归
bayes_lm <- rstanarm::stan_glm(y ~ x, data = blr_data, 
                                family = gaussian(),
                                prior = rstanarm::normal(0, 10),
                                prior_intercept = rstanarm::normal(0, 10),
                                chains = 4, iter = 2000, seed = 123)
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 1).
## Chain 1: 
## Chain 1: Gradient evaluation took 2.6e-05 seconds
## Chain 1: 1000 transitions using 10 leapfrog steps per transition would take 0.26 seconds.
## Chain 1: Adjust your expectations accordingly!
## Chain 1: 
## Chain 1: 
## Chain 1: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 1: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 1: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 1: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 1: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 1: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 1: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 1: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 1: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 1: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 1: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 1: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 1: 
## Chain 1:  Elapsed Time: 0.036 seconds (Warm-up)
## Chain 1:                0.037 seconds (Sampling)
## Chain 1:                0.073 seconds (Total)
## Chain 1: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 2).
## Chain 2: 
## Chain 2: Gradient evaluation took 1.9e-05 seconds
## Chain 2: 1000 transitions using 10 leapfrog steps per transition would take 0.19 seconds.
## Chain 2: Adjust your expectations accordingly!
## Chain 2: 
## Chain 2: 
## Chain 2: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 2: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 2: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 2: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 2: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 2: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 2: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 2: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 2: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 2: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 2: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 2: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 2: 
## Chain 2:  Elapsed Time: 0.034 seconds (Warm-up)
## Chain 2:                0.028 seconds (Sampling)
## Chain 2:                0.062 seconds (Total)
## Chain 2: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 3).
## Chain 3: 
## Chain 3: Gradient evaluation took 1.7e-05 seconds
## Chain 3: 1000 transitions using 10 leapfrog steps per transition would take 0.17 seconds.
## Chain 3: Adjust your expectations accordingly!
## Chain 3: 
## Chain 3: 
## Chain 3: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 3: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 3: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 3: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 3: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 3: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 3: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 3: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 3: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 3: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 3: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 3: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 3: 
## Chain 3:  Elapsed Time: 0.033 seconds (Warm-up)
## Chain 3:                0.029 seconds (Sampling)
## Chain 3:                0.062 seconds (Total)
## Chain 3: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 4).
## Chain 4: 
## Chain 4: Gradient evaluation took 1.6e-05 seconds
## Chain 4: 1000 transitions using 10 leapfrog steps per transition would take 0.16 seconds.
## Chain 4: Adjust your expectations accordingly!
## Chain 4: 
## Chain 4: 
## Chain 4: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 4: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 4: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 4: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 4: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 4: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 4: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 4: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 4: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 4: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 4: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 4: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 4: 
## Chain 4:  Elapsed Time: 0.03 seconds (Warm-up)
## Chain 4:                0.027 seconds (Sampling)
## Chain 4:                0.057 seconds (Total)
## Chain 4:
# 查看结果
summary(bayes_lm)
## 
## Model Info:
##  function:     stan_glm
##  family:       gaussian [identity]
##  formula:      y ~ x
##  algorithm:    sampling
##  sample:       4000 (posterior sample size)
##  priors:       see help('prior_summary')
##  observations: 100
##  predictors:   2
## 
## Estimates:
##               mean   sd   10%   50%   90%
## (Intercept) 4.1    1.6  2.1   4.1   6.1  
## x           0.5    0.0  0.5   0.5   0.6  
## sigma       3.1    0.2  2.8   3.1   3.4  
## 
## Fit Diagnostics:
##            mean   sd   10%   50%   90%
## mean_PPD 30.5    0.4 30.0  30.5  31.1 
## 
## The mean_ppd is the sample average posterior predictive distribution of the outcome variable (for details see help('summary.stanreg')).
## 
## MCMC diagnostics
##               mcse Rhat n_eff
## (Intercept)   0.0  1.0  3917 
## x             0.0  1.0  3961 
## sigma         0.0  1.0  2521 
## mean_PPD      0.0  1.0  3441 
## log-posterior 0.0  1.0  1706 
## 
## For each parameter, mcse is Monte Carlo standard error, n_eff is a crude measure of effective sample size, and Rhat is the potential scale reduction factor on split chains (at convergence Rhat=1).
# 后验分布可视化
plot(bayes_lm)

# 预测
new_data <- data.frame(x = c(40, 50, 60))
pred_posterior <- posterior_predict(bayes_lm, newdata = new_data)

cat("\n========== 预测后验分布 ==========\n")
## 
## ========== 预测后验分布 ==========
for (i in 1:nrow(new_data)) {
  cat(sprintf("x = %d: 预测均值 = %.2f, 95%%PI = [%.2f, %.2f]\n",
              new_data$x[i], mean(pred_posterior[, i]),
              quantile(pred_posterior[, i], 0.025),
              quantile(pred_posterior[, i], 0.975)))
}
## x = 40: 预测均值 = 25.16, 95%PI = [18.93, 31.26]
## x = 50: 预测均值 = 30.41, 95%PI = [24.15, 36.57]
## x = 60: 预测均值 = 35.73, 95%PI = [29.66, 41.75]

12.4 贝叶斯模型比较

意义与使用场景

核心意义：贝叶斯模型比较通过贝叶斯因子或信息准则评估不同模型的相对证据强度，指导模型选择。

举例：比较不同预测模型的优劣

为什么这种数据适合用贝叶斯模型比较？

首先，我们有多个候选模型：简单模型（仅年龄）、中等模型（年龄+血压）、复杂模型（年龄+血压+血糖+交互项）。其次，需要在贝叶斯框架下比较这些模型，评估哪个模型更受数据支持。贝叶斯模型比较通过贝叶斯因子或信息准则（WAIC、LOO-CV），量化不同模型的相对证据强度，指导模型选择。

研究目的是什么？

本研究有三个层次的目的：1. 比较竞争模型：评估不同模型的相对证据强度；2. 选择最优模型：根据贝叶斯因子或信息准则选择模型；3. 评估预测性能：使用交叉验证评估预测能力。

可能得到什么样的结果？

假设贝叶斯模型比较显示：中等模型的WAIC最低，贝叶斯因子支持中等模型。

  1. WAIC比较：简单模型WAIC=850，中等模型WAIC=820，复杂模型WAIC=825。中等模型WAIC最低，预测性能最好。
  2. 贝叶斯因子：中等模型vs简单模型的BF=15，强证据支持中等模型。
  3. LOO-CV：中等模型的LOO误差最低，交叉验证支持中等模型。
  4. 模型权重：中等模型的模型权重=0.65，是最优模型。

需要注意什么？

贝叶斯因子对先验分布敏感，应进行先验敏感性分析。WAIC和LOO-CV更关注预测性能，对先验选择相对稳健。模型比较应在同一数据上进行，缺失数据可能导致问题。贝叶斯模型平均可以综合考虑多个模型的不确定性，避免过度依赖单一模型。

数学基础

贝叶斯因子：

\[BF_{12} = \frac{P(Y|M_1)}{P(Y|M_2)} = \frac{P(M_1|Y)/P(M_2|Y)}{P(M_1)/P(M_2)}\]

解释：

BF值 证据强度
1-3 弱
3-10 中等
10-100 强
>100 非常强

信息准则：

  • DIC（Deviance Information Criterion）
  • WAIC（Widely Applicable Information Criterion）

代码实现

# 比较不同模型
# 模型1：简单线性回归
model1_bayes <- rstanarm::stan_glm(y ~ x, data = blr_data, 
                                    family = gaussian(),
                                    chains = 4, iter = 2000, seed = 123)
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 1).
## Chain 1: 
## Chain 1: Gradient evaluation took 2.2e-05 seconds
## Chain 1: 1000 transitions using 10 leapfrog steps per transition would take 0.22 seconds.
## Chain 1: Adjust your expectations accordingly!
## Chain 1: 
## Chain 1: 
## Chain 1: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 1: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 1: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 1: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 1: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 1: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 1: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 1: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 1: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 1: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 1: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 1: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 1: 
## Chain 1:  Elapsed Time: 0.026 seconds (Warm-up)
## Chain 1:                0.031 seconds (Sampling)
## Chain 1:                0.057 seconds (Total)
## Chain 1: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 2).
## Chain 2: 
## Chain 2: Gradient evaluation took 1.4e-05 seconds
## Chain 2: 1000 transitions using 10 leapfrog steps per transition would take 0.14 seconds.
## Chain 2: Adjust your expectations accordingly!
## Chain 2: 
## Chain 2: 
## Chain 2: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 2: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 2: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 2: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 2: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 2: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 2: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 2: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 2: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 2: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 2: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 2: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 2: 
## Chain 2:  Elapsed Time: 0.022 seconds (Warm-up)
## Chain 2:                0.025 seconds (Sampling)
## Chain 2:                0.047 seconds (Total)
## Chain 2: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 3).
## Chain 3: 
## Chain 3: Gradient evaluation took 2.4e-05 seconds
## Chain 3: 1000 transitions using 10 leapfrog steps per transition would take 0.24 seconds.
## Chain 3: Adjust your expectations accordingly!
## Chain 3: 
## Chain 3: 
## Chain 3: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 3: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 3: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 3: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 3: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 3: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 3: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 3: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 3: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 3: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 3: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 3: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 3: 
## Chain 3:  Elapsed Time: 0.02 seconds (Warm-up)
## Chain 3:                0.028 seconds (Sampling)
## Chain 3:                0.048 seconds (Total)
## Chain 3: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 4).
## Chain 4: 
## Chain 4: Gradient evaluation took 1.6e-05 seconds
## Chain 4: 1000 transitions using 10 leapfrog steps per transition would take 0.16 seconds.
## Chain 4: Adjust your expectations accordingly!
## Chain 4: 
## Chain 4: 
## Chain 4: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 4: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 4: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 4: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 4: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 4: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 4: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 4: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 4: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 4: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 4: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 4: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 4: 
## Chain 4:  Elapsed Time: 0.024 seconds (Warm-up)
## Chain 4:                0.032 seconds (Sampling)
## Chain 4:                0.056 seconds (Total)
## Chain 4:
# 模型2：添加二次项
blr_data$x2 <- blr_data$x^2
model2_bayes <- rstanarm::stan_glm(y ~ x + x2, data = blr_data, 
                                    family = gaussian(),
                                    chains = 4, iter = 2000, seed = 123)
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 1).
## Chain 1: 
## Chain 1: Gradient evaluation took 2.2e-05 seconds
## Chain 1: 1000 transitions using 10 leapfrog steps per transition would take 0.22 seconds.
## Chain 1: Adjust your expectations accordingly!
## Chain 1: 
## Chain 1: 
## Chain 1: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 1: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 1: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 1: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 1: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 1: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 1: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 1: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 1: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 1: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 1: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 1: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 1: 
## Chain 1:  Elapsed Time: 0.126 seconds (Warm-up)
## Chain 1:                0.135 seconds (Sampling)
## Chain 1:                0.261 seconds (Total)
## Chain 1: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 2).
## Chain 2: 
## Chain 2: Gradient evaluation took 1.6e-05 seconds
## Chain 2: 1000 transitions using 10 leapfrog steps per transition would take 0.16 seconds.
## Chain 2: Adjust your expectations accordingly!
## Chain 2: 
## Chain 2: 
## Chain 2: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 2: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 2: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 2: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 2: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 2: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 2: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 2: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 2: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 2: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 2: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 2: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 2: 
## Chain 2:  Elapsed Time: 0.139 seconds (Warm-up)
## Chain 2:                0.195 seconds (Sampling)
## Chain 2:                0.334 seconds (Total)
## Chain 2: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 3).
## Chain 3: 
## Chain 3: Gradient evaluation took 1.4e-05 seconds
## Chain 3: 1000 transitions using 10 leapfrog steps per transition would take 0.14 seconds.
## Chain 3: Adjust your expectations accordingly!
## Chain 3: 
## Chain 3: 
## Chain 3: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 3: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 3: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 3: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 3: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 3: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 3: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 3: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 3: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 3: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 3: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 3: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 3: 
## Chain 3:  Elapsed Time: 0.127 seconds (Warm-up)
## Chain 3:                0.129 seconds (Sampling)
## Chain 3:                0.256 seconds (Total)
## Chain 3: 
## 
## SAMPLING FOR MODEL 'continuous' NOW (CHAIN 4).
## Chain 4: 
## Chain 4: Gradient evaluation took 2.7e-05 seconds
## Chain 4: 1000 transitions using 10 leapfrog steps per transition would take 0.27 seconds.
## Chain 4: Adjust your expectations accordingly!
## Chain 4: 
## Chain 4: 
## Chain 4: Iteration:    1 / 2000 [  0%]  (Warmup)
## Chain 4: Iteration:  200 / 2000 [ 10%]  (Warmup)
## Chain 4: Iteration:  400 / 2000 [ 20%]  (Warmup)
## Chain 4: Iteration:  600 / 2000 [ 30%]  (Warmup)
## Chain 4: Iteration:  800 / 2000 [ 40%]  (Warmup)
## Chain 4: Iteration: 1000 / 2000 [ 50%]  (Warmup)
## Chain 4: Iteration: 1001 / 2000 [ 50%]  (Sampling)
## Chain 4: Iteration: 1200 / 2000 [ 60%]  (Sampling)
## Chain 4: Iteration: 1400 / 2000 [ 70%]  (Sampling)
## Chain 4: Iteration: 1600 / 2000 [ 80%]  (Sampling)
## Chain 4: Iteration: 1800 / 2000 [ 90%]  (Sampling)
## Chain 4: Iteration: 2000 / 2000 [100%]  (Sampling)
## Chain 4: 
## Chain 4:  Elapsed Time: 0.13 seconds (Warm-up)
## Chain 4:                0.137 seconds (Sampling)
## Chain 4:                0.267 seconds (Total)
## Chain 4:
# 使用loo包比较模型
library(loo)
loo1 <- loo(model1_bayes)
loo2 <- loo(model2_bayes)

cat("========== LOO-CV比较 ==========\n")
## ========== LOO-CV比较 ==========
print(loo_compare(loo1, loo2))
##              elpd_diff se_diff
## model2_bayes  0.0       0.0   
## model1_bayes -0.3       1.6
# WAIC比较
waic1 <- waic(model1_bayes)
waic2 <- waic(model2_bayes)

cat("\n========== WAIC比较 ==========\n")
## 
## ========== WAIC比较 ==========
cat(sprintf("模型1 WAIC: %.2f\n", waic1$estimates["waic", "Estimate"]))
## 模型1 WAIC: 510.25
cat(sprintf("模型2 WAIC: %.2f\n", waic2$estimates["waic", "Estimate"]))
## 模型2 WAIC: 509.55

第十二章小结

核心知识点总结

主题 核心内容 关键函数
贝叶斯定理 后验∝似然×先验 手动计算
MCMC Gibbs、MH算法 rstanarm::stan_glm()
贝叶斯回归 后验推断 rstanarm::stan_glm()
模型比较 贝叶斯因子、WAIC loo::loo_compare()

全书总结

本教程系统讲解了R语言统计与建模的12个核心主题：

章节 主题 核心方法
第一章 线性回归模型 OLS、诊断、正则化
第二章 广义线性模型 逻辑回归、泊松回归
第三章 混合效应模型 LMM、GLMM、BLUP
第四章 时间序列分析 ARIMA、GARCH
第五章 生存分析 KM、Cox、竞争风险
第六章 多元统计分析 PCA、因子分析、聚类
第七章 面板数据模型 FE、RE、动态面板
第八章 结构方程模型 CFA、SEM、路径分析
第九章 非参数回归 LOESS、样条、GAM
第十章 计量经济学方法 IV、RDD、DID、PSM
第十一章 模型诊断 信息准则、交叉验证
第十二章 贝叶斯建模 MCMC、贝叶斯回归

学习建议：

  1. 理论与实践结合：每个主题都配有模拟数据和代码实现
  2. 循序渐进：从基础线性回归到高级贝叶斯方法
  3. 注重诊断：模型拟合后务必进行诊断检验
  4. 医学应用：所有示例均采用医学研究场景

延伸阅读：

  • 《Regression Methods in Biostatistics》
  • 《Applied Longitudinal Analysis》
  • 《Bayesian Data Analysis》
  • 《The Elements of Statistical Learning》