diff --git a/.github/workflows/quarto-book-macos.yaml b/.github/workflows/quarto-book-macos.yaml index d6b2d04e..9d09348d 100644 --- a/.github/workflows/quarto-book-macos.yaml +++ b/.github/workflows/quarto-book-macos.yaml @@ -11,7 +11,6 @@ jobs: runs-on: macos-14 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - CMDSTAN_VERSION: "2.34.1" PANDOC_VERSION: "3.1.11" RETICULATE_PYTHON_ENV: /opt/.virtualenvs/r-tensorflow steps: @@ -26,7 +25,7 @@ jobs: with: use-public-rspm: true r-version: '4.3.2' - extra-repositories: 'https://mc-stan.org/r-packages https://inla.r-inla-download.org/R/stable https://grantmcdermott.r-universe.dev' + extra-repositories: 'https://grantmcdermott.r-universe.dev' - uses: r-lib/actions/setup-r-dependencies@v2 @@ -41,15 +40,6 @@ jobs: # install full prebuilt version TINYTEX_INSTALLER: TinyTeX - - name: Setup CmdStan - run: | - curl -fLo cmdstan-${CMDSTAN_VERSION}.tar.gz https://github.com/stan-dev/cmdstan/releases/download/v${CMDSTAN_VERSION}/cmdstan-${CMDSTAN_VERSION}.tar.gz - sudo mkdir -p /opt/cmdstan/ - sudo chown -R $(whoami):staff /opt/cmdstan/ - tar -xzf cmdstan-${CMDSTAN_VERSION}.tar.gz -C /opt/cmdstan/ - make build -C /opt/cmdstan/cmdstan-${CMDSTAN_VERSION} - rm cmdstan-${CMDSTAN_VERSION}.tar.gz - - name: Install Fonts From System run: | export HOMEBREW_NO_INSTALLED_DEPENDENTS_CHECK=1 @@ -93,7 +83,6 @@ jobs: env: RETICULATE_PYTHON_ENV: /opt/.virtualenvs/r-tensorflow RETICULATE_PYTHON: /opt/.virtualenvs/r-tensorflow/bin/python - CMDSTAN: /opt/cmdstan/cmdstan-${{ env.CMDSTAN_VERSION }} - name: Deploy book to bookdown.org if: github.event_name == 'push' diff --git a/.github/workflows/quarto-book-ubuntu.yaml b/.github/workflows/quarto-book-ubuntu.yaml index 2ea78ae5..c59656c4 100644 --- a/.github/workflows/quarto-book-ubuntu.yaml +++ b/.github/workflows/quarto-book-ubuntu.yaml @@ -11,7 +11,6 @@ jobs: runs-on: ubuntu-22.04 env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - CMDSTAN_VERSION: "2.34.1" PANDOC_VERSION: "3.1.11" RETICULATE_PYTHON_ENV: /opt/.virtualenvs/r-tensorflow steps: @@ -26,7 +25,7 @@ jobs: with: use-public-rspm: true r-version: '4.3.2' - extra-repositories: 'https://mc-stan.org/r-packages https://inla.r-inla-download.org/R/stable https://grantmcdermott.r-universe.dev' + extra-repositories: 'https://grantmcdermott.r-universe.dev' - uses: r-lib/actions/setup-r-dependencies@v2 @@ -52,14 +51,6 @@ jobs: python -m spacy download zh_core_web_sm deactivate - - name: Setup CmdStan - run: | - curl -fLo cmdstan-${CMDSTAN_VERSION}.tar.gz https://github.com/stan-dev/cmdstan/releases/download/v${CMDSTAN_VERSION}/cmdstan-${CMDSTAN_VERSION}.tar.gz - mkdir -p /opt/cmdstan/ - tar -xzf cmdstan-${CMDSTAN_VERSION}.tar.gz -C /opt/cmdstan/ - make build -C /opt/cmdstan/cmdstan-${CMDSTAN_VERSION} - rm cmdstan-${CMDSTAN_VERSION}.tar.gz - - name: Install Fonts From System run: | sudo apt-get install -y ghostscript graphviz optipng @@ -96,7 +87,6 @@ jobs: env: RETICULATE_PYTHON_ENV: /opt/.virtualenvs/r-tensorflow RETICULATE_PYTHON: /opt/.virtualenvs/r-tensorflow/bin/python - CMDSTAN: /opt/cmdstan/cmdstan-${{ env.CMDSTAN_VERSION }} - name: Deploy to Github Pages uses: JamesIves/github-pages-deploy-action@v4 diff --git a/.gitignore b/.gitignore index 3c231c79..32885f7c 100755 --- a/.gitignore +++ b/.gitignore @@ -18,22 +18,7 @@ _book/ rsconnect/ site_libs/ data-raw/ -code/poisson_log_glm -code/bernoulli_logit_glm_normal -code/bernoulli_logit_glm_lasso -code/bernoulli_logit_glm_horseshoe -code/gaussian_process_simu -code/gaussian_process_fitted -code/gaussian_process_pred -code/multi_normal_simu -code/multi_normal_fitted -code/rongelap_poisson_pred -code/rongelap_poisson_processes -code/faithful_finite_mixtures -code/faithful_2d_finite_mixtures -code/eight_schools -code/rats -code/stochastic_volatility_models + *.log *-tikzDictionary *.aux diff --git a/DESCRIPTION b/DESCRIPTION index c65b4c24..2bea9706 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -10,16 +10,10 @@ BugReports: https://github.com/XiangyunHuang/data-analysis-in-action/issues Depends: R (>= 4.3.0) Imports: - abess, - bayesplot, BB, beanplot, - BH, - blme, - brms, broom, car, - cmdstanr (>= 0.7.1), coin, data.table, datasauRus, @@ -31,15 +25,8 @@ Imports: dygraphs, e1071, ECOSolveR, - expm, - fastmatrix, - fGarch (>= 4031.90), - fmesher, - FRK (>= 2.2.0), - keras, kernlab, GA (>= 3.2.3), - geodata (>= 0.4.13), gifski, ggalluvial, gganimate (>= 1.0.9), @@ -63,44 +50,28 @@ Imports: ggTimeSeries, ggVennDiagram, ggwordcloud, - glmmTMB, - glmnet, - GLMMadaptive, gt (>= 0.10.1), hexbin, HistData, - hglm, - INLA (>= 23.9.9), jiebaR, knitr (>= 1.44), - lars, latticeExtra, - lavaan, - lme4, - loo (>= 2.6.0), lvplot (>= 0.2.1), magick, maps, - MCMCglmm, misc3d, - ncvreg, nloptr, nomnoml (>= 0.3.0), patchwork, pdftools, plot3D, plotly (>= 4.10.1), - pls, pROC, - projpred, pwr, purrr (>= 1.0.0), quadprog, quantmod, ragg, - randomForest, - reticulate, - rjags, ROI, ROI.plugin.ecos, ROI.plugin.glpk, @@ -108,21 +79,11 @@ Imports: ROI.plugin.quadprog, ROI.plugin.scs, rootSolve, - rpart.plot, RSQLite, - rstan (>= 2.32.3), scs, - sf (>= 1.0.9), showtext, spacyr, - spaMM, - spdep, - splancs, - spatstat, - stars (>= 0.6.0), - tensorflow, text2vec, - tidycensus, tidygraph, tinyplot, titanic, @@ -130,14 +91,11 @@ Imports: treemapify, TSP, vcd, - VGAM, vioplot, visNetwork, webshot2, - xgboost, xml2, xts -LinkingTo: StanHeaders (>= 2.32.2), RcppParallel (>= 5.1.0) Remotes: davidsjoberg/ggbump, davidsjoberg/ggstream @@ -148,8 +106,6 @@ Enhances: sp (>= 2.0-0) SystemRequirements: pgf (>= 3.00), JAGS 4.x.y Additional_repositories: - https://mc-stan.org/r-packages/, - https://grantmcdermott.r-universe.dev, - https://inla.r-inla-download.org/R/stable + https://grantmcdermott.r-universe.dev Encoding: UTF-8 License: CC NC ND 4.0 diff --git a/README.md b/README.md index c83ec0d8..35cc3c25 100755 --- a/README.md +++ b/README.md @@ -24,24 +24,11 @@ - 数据建模 - 网络分析（R 语言社区开发者协作网络） - 时序分析（美团股价收益率的风险建模） - - 空间分析（预测核辐射强度的空间分布） - 优化建模 - 统计计算（统计模型与优化问题的关系） - 数值优化（线性、非线性、约束和无约束） - 优化问题（TSP 问题、投资组合问题等） -- 贝叶斯建模 - - 概率推理框架 - - 广义线性模型 - - 分层正态模型 - - 混合效应模型 - - 广义可加模型 - - 高斯过程回归 -- 机器学习 - - 分类问题 - - 回归问题 - 附录 - - 数学符号 - - 矩阵运算 - Git 和 Github ## 在线编译网页书籍 diff --git a/_quarto.yml b/_quarto.yml index 357c7a07..f688e606 100755 --- a/_quarto.yml +++ b/_quarto.yml @@ -64,34 +64,13 @@ book: - analyze-text-data.qmd - analyze-survival-data.qmd - analyze-time-series-data.qmd - - part: "空间分析" - chapters: - - analyze-point-pattern.qmd - - analyze-spatial-data.qmd - - analyze-areal-data.qmd - part: "优化建模" chapters: - statistical-computation.qmd - numerical-optimization.qmd - optimization-problems.qmd - - part: "贝叶斯建模" - chapters: - - probabilistic-reasoning-framework.qmd - - generalized-linear-models.qmd - - hierarchical-normal-models.qmd - - mixed-effects-models.qmd - - generalized-additive-models.qmd - - gaussian-processes-regression.qmd - - time-series-regression.qmd - - part: "机器学习" - chapters: - - classification-problems.qmd - - clustering-problems.qmd - - regression-problems.qmd - references.qmd appendices: - - notations.qmd - - matrix-operations.qmd - git-github.qmd repo-branch: main search: true diff --git a/analyze-areal-data.qmd b/analyze-areal-data.qmd deleted file mode 100644 index 028f4501..00000000 --- a/analyze-areal-data.qmd +++ /dev/null @@ -1,137 +0,0 @@ -# 区域数据分析 {#sec-analyze-areal-data} - -## 苏格兰唇癌数据分析 {#sec-scotland-lip-cancer} - -> Everything is related to everything else, but near things are more related than distant things. -> -> --- Waldo Tobler [@Tobler1970] - -::: {#spatial-areal-data .callout-note title="空间区域数据分析"} -空间区域数据的贝叶斯建模 - -- Bayesian spatial and spatio-temporal GLMMs with possible extremes [glmmfields](https://github.com/seananderson/glmmfields) -- Bayesian spatial analysis [geostan](https://github.com/ConnorDonegan/geostan/) -- [Spatial Models in Stan: Intrinsic Auto-Regressive Models for Areal Data](https://mc-stan.org/users/documentation/case-studies/icar_stan.html) -- [Exact sparse CAR models in Stan](https://github.com/mbjoseph/CARstan) [网页文档](https://mc-stan.org/users/documentation/case-studies/mbjoseph-CARStan.html) -- [Spatial Models in Stan: Intrinsic Auto-Regressive Models for Areal Data](https://github.com/stan-dev/example-models/tree/master/knitr/car-iar-poisson) [网页文档](https://mc-stan.org/users/documentation/case-studies/icar_stan.html) 原始数据和代码，接上面苏格兰唇癌数据分析，用 CmdStanR 更新后的[代码](https://github.com/stan-dev/example-models/tree/master/knitr/car-iar-poisson) -- [Spatial modeling of areal data. Lip cancer in Scotland](https://www.paulamoraga.com/book-geospatial/sec-arealdataexamplespatial.html) INLA 建模 -- [CAR models Scotland Lip cancer dataset](https://rafaelcabral96.github.io/nigstan/sar-and-car-models.html#car-models) Stan 建模 -- 空间计量 [区域数据分析](https://rsbivand.github.io/emos_talk_2304/bivand_emos_230419.pdf) [on-the-use-of-r-for-spatial-econometrics](https://github.com/rsbivand/emos_talk_2304) -::: - -响应变量服从泊松分布 - -- BYM-INLA [@blangiardo2013; @moraga2020] -- BYM-Stan [@morris2019; @donegan2022; @cabral2022] - -记录 1975-1986 年苏格兰 56 个地区的唇癌病例数，这是一个按地区汇总的数据。 - -```{r} -library(sf) -scotlips <- st_read('data/scotland/scotland.shp', crs = st_crs("EPSG:27700")) -str(scotlips) -``` - -```{r} -#| label: fig-lip-cancer-map -#| fig-cap: 苏格兰各地区唇癌病例数分布 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true - -library(ggplot2) -ggplot() + - geom_sf(data = scotlips, aes(fill = Observed)) + - scale_fill_viridis_c() + - theme_minimal() -``` - -## 美国各州犯罪率分析 - -响应变量服从高斯分布的调查数据 [@bivand2001] - -数据集 USArrests 记录 1973 年美国各州每 10 万居民中因谋杀 Murder、袭击 Assault 和强奸 Rape 被警察逮捕的人数以及城市人口所占百分比（可以看作城市化率）。 - -```{r} -#| echo: false -#| label: tbl-us-arrests -#| tbl-cap: "数据集 USArrests（部分）" - -us_arrests <- data.frame( - state_name = rownames(USArrests), - state_region = state.region, - USArrests, check.names = FALSE -) - -knitr::kable(head(us_arrests), col.names = c( - "州名", "区域划分", "谋杀犯", "袭击犯", "城市化率", "强奸犯" -), row.names = FALSE) -``` - -```{r} -#| label: fig-us-arrests-sf -#| fig-cap: 因袭击被逮捕的人数分布 -#| fig-showtext: true -#| fig-width: 7 -#| fig-height: 4 - -library(sf) -# 州数据 -us_state_sf <- readRDS("data/us-state-map-2010.rds") -# 观测数据 -us_state_df <- merge(x = us_state_sf, y = us_arrests, - by.x = "NAME", by.y = "state_name", all.x = TRUE) - -ggplot() + - geom_sf( - data = us_state_df, aes(fill = Assault), color = "gray80", lwd = 0.25) + - scale_fill_viridis_c(option = "plasma", na.value = "white") + - theme_void() -``` - -1973 年美国各州因袭击被逮捕的人数与城市化率的关系：相关分析 - -```{r} -#| label: fig-us-arrests-point -#| fig-cap: 逮捕人数比例与城市化率的关系 -#| fig-width: 7 -#| fig-height: 5.5 -#| code-fold: true -#| echo: !expr knitr::is_html_output() -#| fig-showtext: true - -library(ggrepel) -ggplot(data = us_arrests, aes(x = UrbanPop, y = Assault)) + - geom_point(aes(color = state_region)) + - geom_text_repel(aes(label = state_name), size = 3, seed = 2022) + - theme_classic() + - labs(x = "城市化率（%）", y = "因袭击被逮捕人数", color = "区域划分") -``` - -阿拉斯加州和夏威夷州与其它州都不相连，属于孤立的情况，下面在空间相关性的分析中排除这两个州。 - -```{r} -# 州的中心 -centers48 <- subset( - x = data.frame(x = state.center$x, y = state.center$y), - subset = !state.name %in% c("Alaska", "Hawaii") -) -# 观测数据 -arrests48 <- subset( - x = USArrests, - subset = !rownames(USArrests) %in% c("Alaska", "Hawaii") -) -``` - -```{r} -#| message: false - -library(spData) -library(spdep) -# KNN -k4.48 <- knn2nb(knearneigh(as.matrix(centers48), k = 4)) -# Moran I test -moran.test(x = arrests48$Assault, listw = nb2listw(k4.48)) -# Permutation test for Moran's I statistic -moran.mc(x = arrests48$Assault, listw = nb2listw(k4.48), nsim = 499) -``` diff --git a/analyze-point-pattern.qmd b/analyze-point-pattern.qmd deleted file mode 100644 index 8c4c4da8..00000000 --- a/analyze-point-pattern.qmd +++ /dev/null @@ -1,193 +0,0 @@ -# 点模式数据分析 {#sec-analyze-point-pattern} - -```{r} -#| echo: false - -source("_common.R") -``` - -本章以斐济地震数据集 quakes 为例介绍空间点模式数据的操作、探索和分析。 - -```{r} -#| message: false - -library(spatstat) -library(sf) -library(ggplot2) -``` - -[**spatstat**](https://github.com/spatstat/spatstat/) 是一个伞包，囊括 8 个子包，构成一套完整的空间点模式分析工具。 - -1. spatstat.utils 基础的辅助分析函数 -2. spatstat.data 点模式分析用到的示例数据集 -3. spatstat.sparse 稀疏数组 -4. spatstat.geom 空间数据类和几何操作 -5. spatstat.random 生成空间随机模式 -6. spatstat.explore 空间数据的探索分析 -7. spatstat.model 空间数据的参数建模和推理 -8. spatstat.linnet 线性网络上的空间分析 - -**sf** 包是一个专门用于空间矢量数据操作的 R 包。**ggplot2** 包提供的几何图层函数 `geom_sf()` 和坐标参考系图层函数 `coord_sf()` 支持可视化空间点模式数据。 - -## 数据操作 - -### 类型转化 - -先对斐济地震数据 quakes 数据集做一些数据类型转化，从 data.frame 转 Simple feature 对象。 - -```{r} -library(sf) -quakes_sf <- st_as_sf(quakes, coords = c("long", "lat"), crs = st_crs(4326)) -quakes_sf -``` - -### 坐标转化 - -如果知道两个投影坐标系的 EPSG 代码，输入坐标就可以完成转化。如将坐标系 `EPSG:4326` 下的坐标 $(2,49)$ 投影到另一个坐标系 `EPSG:3857` 。 - -```{r} -st_transform( - x = st_sfc(st_point(x = c(2, 49)), crs = 4326), crs = 3857 -) -``` - -| 名称 | EPSG | 赤道半径 | 半轴 | 发明者 | -|-------|------|-------------|------------------|----------------------| -| GRS80 | 3857 | a=6378137.0 | rf=298.257222101 | GRS 1980(IUGG, 1980) | -| WGS84 | 4326 | a=6378137.0 | rf=298.257223563 | WGS 84 | - -函数 `st_crs()` 查看坐标参考系的信息，比如 EPSG 代码为 4326 对应的坐标参考系统信息。我们也可以通过[网站](https://epsg.io/3832)查询 EPSG 代码对应的坐标参考系统的详细介绍。 - -```{r} -st_crs("EPSG:4326") -``` - -地球看作一个椭球体 ELLIPSOID，长半轴 6378137 米，短半轴 298.257223563 米，椭圆形的两个轴，纬度单位 0.0174532925199433， 经度单位 0.0174532925199433 。 - -地球是一个不规则的球体，不同的坐标参考系对地球的抽象简化不同，会体现在坐标原点、长半轴、短半轴等属性上。为了方便在平面上展示地理信息，需要将地球表面投影到平面上，墨卡托投影是其中非常重要的一种投影方式，墨卡托投影的详细介绍见 [PROJ 网站](https://proj.org/operations/projections/merc.html) 。WGS 84 / Pseudo-Mercator 投影主要用于网页上的地理可视化，UTM 是 Universal Transverse Mercator 的缩写。360 度对应全球 60 个时区，每个时区横跨 6 经度。 - -```{r} -st_transform( - x = st_sfc(st_point(x = c(2, 49)), crs = 4326), - crs = st_crs("+proj=utm +zone=32 +ellps=GRS80") -) -``` - -快速简单绘图，可采用图层 `geom_sf()`，它相当于统计图层 `stat_sf()` 和坐标映射图层 `coord_sf()` 的叠加，`geom_sf()` 支持点、线和多边形等数据数据对象，可以混合叠加。 `coord_sf()` 有几个重要的参数： - -1. `crs`：在绘图前将各个 `geom_sf()` 图层中的**数据**映射到该坐标参考系。 - -2. `default_crs`：将非 sf 图层（没有携带 CRS 信息）的数据映射到该坐标参考系，默认使用 `crs` 参数的值，常用设置 `default_crs = sf::st_crs(4326)` 将非 sf 图层中的横纵坐标转化为经纬度，采用 World Geodetic System 1984 (WGS84)。 - -3. `datum`：经纬网线的坐标参考系，默认值 `sf::st_crs(4326)`。 - -下图的右子图将 quakes_sf 数据集投影到坐标参考系统[EPSG:3460](https://epsg.io/3460)。 - -```{r} -#| label: fig-quakes-ggplot2-grid -#| fig-cap: 斐济地震的空间分布 -#| fig-subcap: -#| - 坐标参考系 4326（默认） -#| - 坐标参考系 3460 -#| fig-width: 4 -#| fig-height: 4 -#| fig-showtext: true -#| layout-ncol: 2 - -library(ggplot2) -ggplot() + - geom_sf(data = quakes_sf, aes(color = mag)) -ggplot() + - geom_sf(data = quakes_sf, aes(color = mag)) + - coord_sf(crs = 3460) -``` - -数据集 quakes_sf 已经准备了坐标参考系统，此时，`coord_sf()` 就会采用数据集相应的坐标参考系统，即 `sf::st_crs(4326)`。上图的左子图相当于： - -```{r} -#| eval: false - -ggplot() + - geom_sf(data = quakes_sf, aes(color = mag)) + - coord_sf( - crs = 4326, datum = sf::st_crs(4326), - default_crs = sf::st_crs(4326) - ) -``` - -### 凸包操作 - -```{r} -quakes_sf <- st_transform(quakes_sf, crs = 3460) -# 组合 POINT 构造 POLYGON -quakes_sfp <- st_cast(st_combine(st_geometry(quakes_sf)), "POLYGON") -# 构造 POLYGON 的凸包 -quakes_sfp_hull <- st_convex_hull(st_geometry(quakes_sfp)) -``` - -```{r} -#| label: fig-convex-hull -#| fig-cap: 凸包 -#| fig-subcap: -#| - 凸包（base R） -#| - 凸包（ggplot2） -#| fig-showtext: true -#| fig-width: 4 -#| fig-height: 4 -#| layout-ncol: 2 -#| par: true - -# 绘制点及其包络 -plot(st_geometry(quakes_sf)) -# 添加凸包曲线 -plot(quakes_sfp_hull, add = TRUE) - -ggplot() + - geom_sf(data = quakes_sf) + - geom_sf(data = quakes_sfp_hull, fill = NA) + - coord_sf(crs = 3460, xlim = c(569061, 3008322), ylim = c(1603260, 4665206)) -``` - -## 数据探索 - -### 核密度估计 - -给定边界内的[核密度估计与绘制热力图](https://stackoverflow.com/questions/68643517) - -```{r} -# spatial point pattern ppp 类型 -quakes_ppp <- spatstat.geom::as.ppp(quakes_sf) -# 限制散点在给定的窗口边界内平滑 -spatstat.geom::Window(quakes_ppp) <- spatstat.geom::as.owin(quakes_sfp_hull) -# 密度估计 -density_spatstat <- spatstat.explore::density.ppp(quakes_ppp, dimyx = 256) -# 转化为 stars 对象 栅格数据 -density_stars <- stars::st_as_stars(density_spatstat) -# 设置坐标参考系 -density_sf <- st_set_crs(st_as_sf(density_stars), 3460) -``` - -### 绘制热力图 - -```{r} -#| label: fig-kernel-heatmap -#| fig-cap: 热力图 -#| fig-subcap: -#| - 核密度估计 -#| - 核密度估计（原始数据） -#| fig-showtext: true -#| fig-width: 4 -#| fig-height: 4 -#| layout-ncol: 2 - -ggplot() + - geom_sf(data = density_sf, aes(fill = v), col = NA) + - scale_fill_viridis_c() + - geom_sf(data = st_boundary(quakes_sfp_hull)) - -ggplot() + - geom_sf(data = density_sf, aes(fill = v), col = NA) + - scale_fill_viridis_c() + - geom_sf(data = st_boundary(quakes_sfp_hull)) + - geom_sf(data = quakes_sf, size = 1, col = "black") -``` diff --git a/analyze-spatial-data.qmd b/analyze-spatial-data.qmd deleted file mode 100755 index 7d38fb37..00000000 --- a/analyze-spatial-data.qmd +++ /dev/null @@ -1,928 +0,0 @@ -# 点参考数据分析 {#sec-nuclear-pollution-concentration} - -```{r} -#| echo: false - -source("_common.R") -``` - -本章内容属于空间分析的范畴，空间分析的内容十分广泛，主要分三大块，分别是空间点参考数据分析、空间点模式分析和空间区域数据分析。本章仅以一个模型和一个数据简略介绍空间点参考数据分析。一个模型是空间广义线性混合效应模型，空间广义线性混合效应模型在流行病学、生态学、环境学等领域有广泛的应用，如预测某地区内的疟疾流行度分布，预测某地区 PM 2.5 污染物浓度分布等。一个数据来自生态学领域，数据集所含样本量不大，但每个样本收集成本不小，采集样本前也都有实验设计，数据采集的地点是预先设定的。下面将对真实数据分析和建模，任务是预测核辐射强度在朗格拉普岛上的分布。 - -## 数据说明 {#sec-rongelap-data} - -在第二次世界大战的吉尔伯特及马绍尔群岛战斗中，美国占领了马绍尔群岛。战后，美国在该群岛的比基尼环礁中陆续进行了许多氢弹核试验，对该群岛造成无法弥补的环境损害。位于南太平洋的朗格拉普环礁是马绍尔群岛的一部分，其中，朗格拉普岛是朗格拉普环礁的主岛，修建有机场，在太平洋战争中是重要的军事基地。朗格拉普岛距离核爆炸的位置较近，因而被放射性尘埃笼罩了，受到严重的核辐射影响，从度假胜地变成人间炼狱，居民出现上吐下泻、皮肤灼烧、脱发等症状。即便是 1985 年以后，那里仍然无人居住，居民担心核辐射对身体健康的影响。又几十年后，一批科学家来到该岛研究生态恢复情况，评估当地居民重返家园的可行性。实际上，该岛目前仍然不适合人类居住，只有经批准的科学研究人员才能登岛。 - -```{r} -#| label: fig-rongelap-atoll -#| fig-cap: "朗格拉普环礁和朗格拉普岛" -#| code-fold: true -#| echo: !expr knitr::is_html_output() -#| fig-showtext: true -#| message: false -#| fig-width: 5.6 -#| fig-height: 4 - -# 从网站 https://gadm.org/ 下载国家各级行政区划数据 -# geodata 包返回 SpatVector 类型的数据对象 -mhl_map_gadm <- geodata::gadm(country = "MHL", level = 1, path = "data/") -library(sf) -# SpatVector 类型转为 sf 类型 -mhl_map_gadm <- st_as_sf(mhl_map_gadm) -library(ggplot2) -# 添加虚线框用来圈选朗格拉普岛 -rongelap_sfp <- st_sfc(st_polygon(x = list(rbind( - c(166.82, 11.14), - c(166.82, 11.183), - c(166.92, 11.183), - c(166.92, 11.14), - c(166.82, 11.14) -)), dim = "XY"), crs = 4326) -# 文本标记 -text_df <- tibble::tribble( - ~x, ~y, ~text, - 166.75, 11.35, "朗格拉普环礁", - 166.97, 11.16, "朗格拉普岛" -) -text_df <- as.data.frame(text_df) -text_sf <- st_as_sf(text_df, coords = c("x", "y"), dim = "XY", crs = 4326) -# 朗格拉普环礁 -ggplot() + - geom_sf(data = mhl_map_gadm) + - geom_sf(data = rongelap_sfp, fill = NA, linewidth = 0.75, lty = 2) + - geom_sf_text(data = text_sf, aes(label = text), color = "gray20", - fun.geometry = sf::st_centroid) + - coord_sf(xlim = c(166.6, 167.1), ylim = c(11.14, 11.5)) + - theme_bw() + - labs(x = "经度", y = "纬度") -``` - -[Ole F. Christensen](https://orcid.org/0000-0002-8230-8062) 和 Paulo J. Ribeiro Jr 将 `rongelap` 数据集存放在 [**geoRglm**](https://cran.r-project.org/package=geoRglm)[@Christensen2002] 包内，后来，**geoRglm** 不维护，已从 CRAN 移除了，笔者从他们主页下载了数据。数据集 `rongelap` 记录了 157 个测量点的伽马射线强度，即在时间间隔 `time` （秒）内放射的粒子数目 `counts`（个），测量点的横纵坐标分别为 `cX` （米）和 `cY`（米），下 @tbl-rongelap-nuclear-data 展示部分朗格拉普岛核辐射检测数据及海岸线坐标数据。 - -```{r} -#| label: tbl-rongelap-nuclear-data -#| tbl-cap: "朗格拉普岛核辐射检测数据及海岸线坐标数据" -#| tbl-subcap: -#| - "核辐射检测数据" -#| - "海岸线坐标数据" -#| layout-ncol: 2 -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -# 加载数据 -rongelap <- readRDS(file = "data/rongelap.rds") -rongelap_coastline <- readRDS(file = "data/rongelap_coastline.rds") - -library(knitr) -knitr::kable(head(rongelap, 6), - col.names = c("cX 横坐标", "cY 纵坐标", "counts 数目", "time 时间") -) -knitr::kable(head(rongelap_coastline, 6), - col.names = c("cX 横坐标", "cY 纵坐标") -) -``` - -坐标原点在岛的东北，下 @fig-rongelap-location-1 右上角的位置。采样点的编号见下 @fig-rongelap-location-2，基本上按照从下（南）到上（北），从左（西）到右（东）的顺序依次测量。 - -```{r} -#| label: fig-rongelap-location -#| fig-cap: "采样点在岛上的分布" -#| fig-subcap: -#| - 采样分布 -#| - 采样顺序 -#| fig-showtext: true -#| fig-width: 6.2 -#| fig-height: 3.2 -#| code-fold: true -#| layout-nrow: 2 -#| layout-ncol: 1 -#| echo: !expr knitr::is_html_output() - -library(ggplot2) -ggplot() + - geom_point(data = rongelap, aes(x = cX, y = cY), size = 0.2) + - geom_path(data = rongelap_coastline, aes(x = cX, y = cY)) + - theme_bw() + - coord_fixed() + - labs(x = "横坐标（米）", y = "纵坐标（米）") - -rongelap$dummy <- rownames(rongelap) -ggplot(rongelap, aes(x = cX, y = cY)) + - geom_text(aes(label = dummy), size = 2) + - theme_bw() + - coord_fixed() + - labs(x = "横坐标（米）", y = "纵坐标（米）") -``` - -## 数据探索 {#sec-rongelap-exploration} - -朗格拉普岛呈月牙形，有数千米长，但仅几百米宽，十分狭长。采样点在岛上的分布如 @fig-rongelap-location 所示，主网格以约 200 米的间隔采样，在岛屿的东北和西南方各有两个密集采样区，每个网格采样区是 $5 \times 5$ 方式排列的，上下左右间隔均为 40 米。朗格拉普岛上各个检测站点的核辐射强度如 @fig-rongelap-location-zoom 所示，越亮表示核辐射越强，四个检测区的采样阵列非常密集，通过局部放大展示了最左侧的一个检测区，它将作为后续模型比较的参照区域。 - -```{r} -#| label: fig-rongelap-location-zoom -#| fig-cap: "岛上各采样点的核辐射强度" -#| fig-width: 6.2 -#| fig-height: 3.2 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -p1 <- ggplot() + - geom_path(data = rongelap_coastline, aes(x = cX, y = cY)) + - geom_point(data = rongelap, aes(x = cX, y = cY, color = counts / time), size = 0.2) + - scale_x_continuous(n.breaks = 7) + - scale_color_viridis_c(option = "C") + - geom_segment( - data = data.frame(x = -5560, xend = -5000, y = -3000, yend = -2300), - aes(x = x, y = y, xend = xend, yend = yend), - arrow = arrow(length = unit(0.03, "npc")) - ) + - theme_bw() + - coord_fixed() + - labs(x = "横坐标（米）", y = "纵坐标（米）", color = "辐射强度") - -p2 <- ggplot() + - geom_point(data = rongelap, aes(x = cX, y = cY, color = counts / time), - size = 1, show.legend = FALSE) + - scale_color_viridis_c(option = "C") + - coord_fixed(xlim = c(-5700, -5540), ylim = c(-3260, -3100)) + - theme_bw() + - labs(x = NULL, y = NULL) - -p1 -print(p2, vp = grid::viewport(x = .25, y = .66, width = .275, height = .45)) -``` - -**ggplot2** 包只能在二维平面上展示数据，对于空间数据，立体图形更加符合数据产生背景。如 @fig-rongelap-concentration 所示，以三维图形展示朗格拉普岛上采样点的位置及检测到的辐射强度。**lattice** 包的函数 `cloud()` 可以绘制三维的散点图，将自定义的面板函数 `panel.3dcoastline()` 传递给参数 `panel.3d.cloud` 绘制岛屿海岸线。组合点和线两种绘图元素构造出射线，线的长短表示放射性的强弱，以射线表示粒子辐射现象更加贴切。 - -```{r} -#| label: fig-rongelap-concentration -#| fig-cap: "岛上各采样点的辐射强度" -#| fig-showtext: true -#| fig-width: 5.2 -#| fig-height: 3.5 -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -library(lattice) -# 参考 lattice 书籍的图 6.5 的绘图代码 -panel.3dcoastline <- function(..., rot.mat, distance, xlim, ylim, zlim, - xlim.scaled, ylim.scaled, zlim.scaled) { - scale.vals <- function(x, original, scaled) { - scaled[1] + (x - original[1]) * diff(scaled) / diff(original) - } - scaled.map <- rbind( - scale.vals(rongelap_coastline$cX, xlim, xlim.scaled), - scale.vals(rongelap_coastline$cY, ylim, ylim.scaled), - zlim.scaled[1] - ) - m <- ltransform3dto3d(scaled.map, rot.mat, distance) - panel.lines(m[1, ], m[2, ], col = "black") -} - -cloud(counts / time ~ cX * cY, - data = rongelap, col = "black", - xlim = c(-6500, 100), ylim = c(-3800, 150), - scales = list(arrows = FALSE, col = "black"), - aspect = c(0.75, 0.5), - xlab = list("横坐标（米）", rot = 20), - ylab = list("纵坐标（米）", rot = -50), - zlab = list("辐射强度", rot = 90), - type = c("p", "h"), pch = 16, lwd = 0.5, - panel.3d.cloud = function(...) { - panel.3dcoastline(...) # 海岸线 - panel.3dscatter(...) - }, - # 减少三维图形的边空 - lattice.options = list( - layout.widths = list( - left.padding = list(x = -0.5, units = "inches"), - right.padding = list(x = -1.0, units = "inches") - ), - layout.heights = list( - bottom.padding = list(x = -1.5, units = "inches"), - top.padding = list(x = -1.5, units = "inches") - ) - ), - par.settings = list( - # 移除几条内框线 - # box.3d = list(col = c(1, 1, NA, NA, 1, NA, 1, 1, 1)), - # 刻度标签字体大小 - axis.text = list(cex = 0.8), - # 去掉外框线 - axis.line = list(col = "transparent") - ), - # 设置三维图的观察方位 - screen = list(z = 30, x = -65, y = 0) -) -``` - -## 数据建模 {#sec-rongelap-modeling} - -### 广义线性模型 {#sec-rongelap-glm} - -核辐射是由放射元素衰变产生的，通常用单位时间释放出来的粒子数目表示辐射强度，因此，建立如下泊松型广义线性模型来拟合核辐射强度。 - -$$ -\begin{aligned} -\log(\lambda_i) &= \beta \\ -y_i & \sim \mathrm{Poisson}(t_i\lambda_i) -\end{aligned} -$$ - -其中，$\lambda_i$ 表示核辐射强度，$\beta$ 表示未知的截距，$y_i$ 表示观测到的粒子数目，$t_i$ 表示相应的观测时间，$i = 1,\ldots, 157$ 表示采样点的位置编号。R 软件内置的 **stats** 包有函数 `glm()` 可以拟合上述广义线性模型，代码如下。 - -```{r} -fit_rongelap_poisson <- glm(counts ~ 1, - family = poisson(link = "log"), offset = log(time), data = rongelap -) -summary(fit_rongelap_poisson) -``` - -当 `family = poisson(link = "log")` 时，响应变量只能是正整数，所以不能放 `counts / time`。泊松广义线性模型是对辐射强度建模，辐射强度与位置 `cX` 和 `cY` 有关。当响应变量为放射出来的粒子数目 `counts` 时，为了表示辐射强度，需要设置参数 `offset`，表示与放射粒子数目对应的时间间隔 `time`。联系函数是对数函数，因此时间间隔需要取对数。 - -从辐射强度的拟合残差的空间分布 @fig-rongelap-poisson-residuals 不难看出，颜色深和颜色浅的点分别聚集在一起，且与周围点的颜色呈现层次变化，拟合残差存在明显的空间相关性。如果将位置变量 `cX` 和 `cY` 加入广义线性模型，也会达到统计意义上的显著。 - -```{r} -#| label: fig-rongelap-poisson-residuals -#| fig-cap: "残差的空间分布" -#| fig-width: 6.2 -#| fig-height: 3.2 -#| fig-showtext: true - -rongelap$poisson_residuals <- residuals(fit_rongelap_poisson) -ggplot(rongelap, aes(x = cX, y = cY)) + - geom_point(aes(colour = poisson_residuals / time), size = 0.2) + - scale_color_viridis_c(option = "C") + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", color = "残差") -``` - -@fig-poisson-residuals 描述残差的分布，从 @fig-poisson-residuals-1 发现残差存在一定的线性趋势，岛屿的东南方，残差基本为正，而在岛屿的西北方，残差基本为负，说明有一定的异方差性。从 @fig-poisson-residuals-2 发现残差在水平方向上的分布像个哑铃，说明异方差现象明显。从 @fig-poisson-residuals-3 发现残差在垂直方向上的分布像棵松树，也说明异方差现象明显。 - -```{r} -#| label: fig-poisson-residuals -#| fig-cap: 残差分布图 -#| fig-subcap: -#| - 残差与编号的关系 -#| - 残差与横坐标的关系 -#| - 残差与纵坐标的关系 -#| fig-showtext: true -#| fig-width: 4 -#| fig-height: 3 -#| layout-ncol: 2 -#| layout-nrow: 2 - -ggplot(rongelap, aes(x = 1:157, y = poisson_residuals / time)) + - geom_point(size = 1) + - theme_bw() + - labs(x = "编号", y = "残差") - -ggplot(rongelap, aes(x = cX, y = poisson_residuals / time)) + - geom_point(size = 1) + - theme_bw() + - labs(x = "横坐标", y = "残差") - -ggplot(rongelap, aes(x = cY, y = poisson_residuals / time)) + - geom_point(size = 1) + - theme_bw() + - labs(x = "纵坐标", y = "残差") -``` - -### 空间线性混合效应模型 {#sec-rongelap-slmm} - -从实际场景出发，也不难理解，位置信息是非常关键的。进一步，充分利用位置信息，精细建模是很有必要的。相邻位置的核辐射强度是相关的，离得近的比离得远的更相关。下面对辐射强度建模，假定随机效应之间存在相关性结构，去掉随机效应相互独立的假设，这更符合位置效应存在相互影响的实际情况。 - -$$ -\log\big(\lambda(x_i)\big) = \beta + S(x_{i}) + Z_{i} -$$ {#eq-rongelap-gaussian-slmm} - -其中，$\beta$ 表示截距，相当于平均水平，$\lambda(x_i)$ 表示位置 $x_i$ 处的辐射强度，$S(x_{i})$ 表示位置 $x_i$ 处的空间效应，$S(x),x \in \mathcal{D} \subset{\mathbb{R}^2}$ 是二维平稳空间高斯过程 $\mathcal{S}$ 的具体实现。 $\mathcal{D}$ 表示研究区域，可以理解为朗格拉普岛，它是二维实平面 $\mathbb{R}^2$ 的子集。 $Z_i$ 之间相互独立同正态分布 $\mathcal{N}(0,\tau^2)$ ，$Z_i$ 表示非空间的随机效应，在空间统计中，常称之为块金效应，可以理解为测量误差、空间变差或背景辐射。值得注意，此时，块金效应和模型残差是合并在一起的。 - -#### 自协方差函数 {#sec-covariance-function} - -随机过程 $S(x)$ 的自协方差函数常用的有指数型、幂二次指数型（高斯型）和梅隆型，形式如下： - -$$ -\begin{aligned} -\mathsf{Cov}\{ S(x_i), S(x_j) \} &= \sigma^2 \exp\big( -\frac{\|x_i -x_j\|_{2}}{\phi} \big) \\ -\mathsf{Cov}\{ S(x_i), S(x_j) \} &= \sigma^2 \exp\big( -\frac{\|x_i -x_j\|_{2}^{2}}{2\phi^2} \big) \\ -\mathsf{Cov}\{ S(x_i), S(x_j) \} &= \sigma^2 \frac{2^{1 - \nu}}{\Gamma(\nu)} -\left(\sqrt{2\nu}\frac{\|x_i -x_j\|_{2}}{\phi}\right)^{\nu} -K_{\nu}\left(\sqrt{2\nu}\frac{\|x_i -x_j\|_{2}}{\phi}\right) \\ -K_{\nu}(x) &= \int_{0}^{\infty}\exp(-x \cosh t) \cosh (\nu t) \mathrm{dt} -\end{aligned} -$$ {#eq-matern-formula} - -其中，$K_{\nu}$ 表示阶数为 $\nu$ 的修正的第二类贝塞尔函数，$\Gamma(\cdot)$ 表示伽马函数，当 $\nu = 1/2$ ，梅隆型将简化为指数型，当 $\nu = \infty$ 时，梅隆型将简化为幂二次指数型。 - -$$ -\mathsf{Cov}\{ S(x_i), S(x_j) \} = \sigma^2 \rho(u_{ij}) -$$ - -其中，$\rho(u_{ij})$ 表示自相关函数。 $u_{ij}$ 表示位置 $x_i$ 与 $x_j$ 之间的距离，常用的有欧氏距离。梅隆型自相关函数图像如 @fig-matern-fun 所示，不难看出，$\nu$ 影响自相关函数的平滑性，控制点与点之间相关性的变化，$\nu$ 越大相关性越迅速地递减。$\phi$ 控制自相关函数的范围，$\phi$ 越大相关性辐射距离越远。对模型来说，它们都是超参数。 - -```{r} -#| label: fig-matern-fun -#| fig-cap: "梅隆型自相关函数曲线" -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() -#| fig-width: 5 -#| fig-height: 4 - -# 参数 x 两点之间的距离，要求 x 大于 0 -# 参数 sigma nu phi 分别与前述公式参数对应 -cov_matern_nu <- function(x, sigma = 1, nu = 3 / 2, phi = 5) { - phi <- sqrt(2 * nu) * x / phi - sigma^2 * 2^(1 - nu) / gamma(nu) * phi^nu * besselK(x = phi, nu = nu) -} -library(ggplot2) -mesh_matern <- expand.grid( - x = seq(from = 0.01, to = 20, by = 0.04), - sigma = 1, nu = c(5 / 2, 3 / 2, 1 / 2), phi = c(5, 2.5) -) - -mesh_matern$fv <- cov_matern_nu( - x = mesh_matern$x, sigma = mesh_matern$sigma, - nu = mesh_matern$nu, phi = mesh_matern$phi -) - -mesh_matern$nu_math <- paste("nu==", mesh_matern$nu, sep = "") -mesh_matern$phi_math <- paste("phi==", mesh_matern$phi, sep = "") - -ggplot(data = mesh_matern, aes(x = x, y = fv)) + - geom_line(aes(color = nu_math)) + - facet_wrap(vars(phi_math), ncol = 1, labeller = ggplot2::label_parsed) + - scale_color_viridis_d( - labels = expression(nu == 0.5, nu == 1.5, nu == 2.5), - begin = 0.3, end = 0.7, option = "C" - ) + - theme_bw() + - labs(x = "距离", y = "相关性", color = expression(nu)) -``` - -#### nlme 包的自相关函数 {#sec-correlation-function} - -**nlme** 包中带块金效应的指数型自相关函数设定如下： - -$$ -\rho(u; \phi, \tau_{rel}^2 ) = \tau_{rel}^2 + (1 - \tau_{rel}^2) \big(1 - \exp(- \frac{u}{\phi}) \big) -$$ - -为了方便参数估计，**nlme** 包对参数做了一些重参数化的操作。 - -$$ -\begin{aligned} -\tau_{rel}^2 &= \frac{\tau^2}{\tau^2 + \sigma^2} \\ -\sigma_{tol}^2 &= \tau^2 + \sigma^2 -\end{aligned} -$$ {#eq-reparameterization} - -当 $u$ 趋于 0 时， $\rho(u; \phi, \tau_{rel}^2 ) = \tau_{rel}^2$ 。另外，$\phi$ 取值为正，$\tau_{rel}^2$ 取值介于 0-1 之间，在默认设置下，$\phi$ 的初始值为 $0.1 \times \max_{i,j \in A} u_{ij}$，即所有点之间距离的最大值的 10%， $\tau_{rel}^2$ 为 0.1 ，这只是作为参考，用户可根据实际情况调整。 - -下面以一个简单示例理解自相关函数 `corExp()` 的作用，令 $\phi = 1.2, \tau_{rel}^2 = 0.2$，则由距离矩阵和自相关函数构造的自相关矩阵如下： - -```{r} -library(nlme) -spatDat <- data.frame(x = (1:4) / 4, y = (1:4) / 4) -cs3Exp <- corExp(c(1.2, 0.2), form = ~ x + y, nugget = TRUE) -cs3Exp <- Initialize(cs3Exp, spatDat) -corMatrix(cs3Exp) -``` - -自相关矩阵的初始化结果等价于如下矩阵： - -```{r} -diag(0.2, 4) + (1 - 0.2) * exp(-as.matrix(dist(spatDat)) / 1.2) -``` - -除了函数 `corExp()` ，**nlme** 包还有好些自相关函数，如高斯自相关函数 `corGaus()` ，线性自相关函数 `corLin()` ，有理自相关函数 `corRatio()` ，球型自相关函数 `corSpher()` 等。它们的作用与函数 `corExp()` 类似，使用方式也一样，如下是高斯型自相关函数的示例，其他的不再一一举例。 - -```{r} -cs3Gaus <- corGaus(c(1.2, 0.2), form = ~ x + y, nugget = TRUE) -cs3Gaus <- Initialize(cs3Gaus, spatDat) -corMatrix(cs3Gaus) -# 等价于 -diag(0.2, 4) + (1 - 0.2) * exp(-as.matrix(dist(spatDat))^2 / 1.2^2) -``` - -#### nlme 包的拟合函数 `gls()` {#sec-gls-function} - -**nlme** 包的函数 `gls()` 实现限制极大似然估计方法，可以拟合存在异方差的一般线性模型。所谓一般线性模型，即在简单线性模型的基础上，残差不再是独立同分布的，而是存在相关性。函数 `gls()` 可以拟合具有空间自相关性的残差结构。这种线性模型又可以看作是一种带空间自相关结构的线性混合效应模型，空间随机效应的结构可以看作异方差的结构。 - -```{r} -fit_rongelap_gls <- gls( - log(counts / time) ~ 1, data = rongelap, - correlation = corExp( - value = c(200, 0.1), form = ~ cX + cY, nugget = TRUE - ) -) -summary(fit_rongelap_gls) -``` - -**nlme** 包给出截距项 $\beta$ 、相对块金效应 $\tau_{rel}^2$ 、范围参数 $\phi$ 和残差标准差 $\sigma_{tol}$ 的估计， - -$$ -\begin{aligned} -\beta &= 1.812914, \quad \phi = 169.7472088 \\ -\tau_{rel}^2 &= 0.1092496, \quad \sigma_{tol} = 0.5739672 -\end{aligned} -$$ - -根据前面的 @eq-reparameterization ，可以得到 $\tau^2$ 和 $\sigma^2$ 的估计。 - -$$ -\begin{aligned} -\tau^2 &= \tau^2_{rel} \times \sigma^2_{tol} = 0.1092496 \times 0.3294383 = 0.035991 \\ -\sigma^2 &= \sigma^2_{tol} - \tau^2_{rel} \times \sigma^2_{tol} = 0.5739672^2 - 0.1092496 \times 0.3294383 = 0.2934473 -\end{aligned} -$$ - -#### 经验半变差函数图 {#sec-semi-variogram} - -接下来用经验半变差函数图检查空间相关性。为方便表述起见，令 $T(x_i)$ 代表 @eq-rongelap-gaussian-slmm 等号右侧的部分，即表示线性预测（Linear Predictor）。 - -$$ -T(x_i) = \beta + S(x_{i}) + Z_{i} -$$ - -令 $\gamma(u_{ij}) = \frac{1}{2}\mathsf{Var}\{T(x_i) - T(x_j)\}$ 表示半变差函数（Semivariogram），这里 $u_{ij}$ 表示采样点 $x_i$ 与 $x_j$ 之间的距离。考虑到 - -$$ -\gamma(u_{ij}) = \frac{1}{2}\mathsf{E}\big\{\big[T(x_i) - T(x_j)\big]^2\big\} = \tau^2 + \sigma^2\big(1-\rho(u_{ij})\big) -$$ {#eq-semi-variogram} - -上式第一个等号右侧期望可以用样本代入来计算，称之为经验半变差函数，第二个等号右侧为理论半变差函数。为了便于计算，将距离做一定划分，尽量使得各个距离区间的样本点对的数目接近。此时，第 $i$ 个距离区间上经验半变差函数值 $\hat{\gamma}(h_i)$ 的计算公式如下： - -$$ -\hat{\gamma}(h_i) = \frac{1}{2N(h_i)}\sum_{j=1}^{N(h_i)}(T(x_i)-T(x_i+h'))^2, \ \ h_{i,0} \le h' < h_{i,1} -$$ - -其中，$[h_{i,0},h_{i,1}]$ 表示第 $i$ 个距离区间，$N(h_i)$ 表示第 $i$ 个距离区间内所有样本点对的数目，只要两个点之间的距离在这个区间内，就算是一对。`rongelap` 数据集包含 157 个采样点，两两配对，共有 $(157 - 1) \times 157 / 2 = 12246$ 对。下面举个例子说明函数 `Variogram()` 的作用。假设模型参数已经估计出来了，可以根据理论变差公式 @eq-semi-variogram 计算， 设置为 $\phi = 200, \tau_{rel}^2 = 0.1$ 。 - -```{r} -0.1 + (1 - 0.1) * (1 - exp(- 40 / 200 )) -``` - -可知当距离为 40 时，半变差函数值为 0.2631423 ，当距离为 175.9570 时，半变差函数值为 0.6266151 。下面基于 **nlme** 包中自相关函数计算半变差函数值 ，将 rongelap 数据代入函数 `Variogram()` 可以计算每个距离对应的函数值，默认计算 50 个，如 @fig-rongelap-vario-theory 所示。 - -```{r} -cs <- corExp(value = c(200, 0.1), form = ~ cX + cY, nugget = TRUE) -cs <- Initialize(cs, rongelap) -vario <- Variogram(cs) -head(vario) -``` - -可以看到，当距离为 40 时，计算的结果与上面是一致的，也知道了函数 `Variogram()` 的作用。 - -```{r} -#| label: fig-rongelap-vario-theory -#| fig-cap: "理论半变差函数图" -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -# 经验半变差图 -plot(vario, - col.line = "black", scales = list( - # 去掉图形上边、右边多余的刻度线 - x = list(alternating = 1, tck = c(1, 0)), - y = list(alternating = 1, tck = c(1, 0)) - ), par.settings = list( - plot.symbol = list(pch = 20, col = "black"), - plot.line = list(lwd = 1) - ), - xlab = "距离（米）", ylab = "半变差函数值" -) -``` - -**nlme** 包的函数 `Variogram()` 根据函数 `gls()` 估计的参数值计算模型残差的经验半变差函数值： - -```{r} -fit_rongelap_vario <- Variogram(fit_rongelap_gls, - form = ~ cX + cY, data = rongelap, resType = "response" -) -fit_rongelap_vario -``` - -::: callout-note -请思考 `fit_rongelap_vario` 输出的 `n.pairs` 的总对数为什么是 12090 而不是 12246？ -::: - -结果显示，距离在 0-89.44272 米之间的坐标点有 510 对，经验半变差函数值为 0.07006716。距离在 89.44272-144.22205 米之间的坐标点有 601 对，经验半变差函数值为 0.12719889，依此类推。将距离和计算的经验半变差函数值绘制出来，即得到经验半变差图，如 @fig-rongelap-vario 所示。刚开始，半变差值很小，之后随距离增加而增大，一直到达一个平台。半变差反比于空间相关性的程度，随着距离增加，空间相关性减弱。这说明数据中确含有空间相关性，模型中添加指数型自相关空间结构是合理的。 - -```{r} -#| label: fig-rongelap-vario -#| fig-cap: "残差的经验半变差图" -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -# 经验半变差图 -plot(fit_rongelap_vario, - col.line = "black", scales = list( - # 去掉图形上边、右边多余的刻度线 - x = list(alternating = 1, tck = c(1, 0)), - y = list(alternating = 1, tck = c(1, 0)) - ), par.settings = list( - plot.symbol = list(pch = 20, col = "black"), - plot.line = list(lwd = 1) - ), - xlab = "距离（米）", ylab = "半变差函数值" -) -``` - -如果空间相关性提取得很充分，则标准化残差的半变差图中的数据点应是围绕标准差 1 上下波动，无明显趋势，拟合线几乎是一条水平线，从 @fig-rongelap-vario-norm 来看，存在一些非均匀的波动，是采样点在空间的分布不均匀所致，岛屿狭长的中部地带采样点稀疏。如前所述，刻画空间相关性，除了指数型，还可以用其它自相关结构来拟合，留待读者练习。 - -```{r} -#| label: fig-rongelap-vario-norm -#| fig-cap: "标准化残差的经验半变差图" -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -fit_rongelap_vario_norm <- nlme::Variogram(fit_rongelap_gls, - form = ~ cX + cY, data = rongelap, resType = "normalized" -) -# 经验半变差图 -plot(fit_rongelap_vario_norm, - col.line = "black", scales = list( - # 去掉图形上边、右边多余的刻度线 - x = list(alternating = 1, tck = c(1, 0)), - y = list(alternating = 1, tck = c(1, 0)) - ), par.settings = list( - plot.symbol = list(pch = 20, col = "black"), - plot.line = list(lwd = 1) - ), - xlab = "距离（米）", ylab = "半变差函数值" -) -``` - -### 空间广义线性混合效应模型 {#sec-rongelap-sglmm} - -简单的广义线性模型并没有考虑距离相关性，它认为各个观测点的数据是相互独立的。因此，考虑采用广义线性混合效应模型，在广义线性模型的基础上添加位置相关的随机效应，用以刻画未能直接观测到的潜在影响。 ${}^{137}\mathrm{Cs}$ 放出伽马射线，在 $n=157$ 个采样点，分别以时间间隔 $t_i$ 测量辐射量 $y(x_i)$，建立泊松型空间广义线性混合效应模型。 - -$$ -\begin{aligned} -\log\{\lambda(x_i)\} & = \beta + S(x_{i}) + Z_{i} \\ -y(x_{i}) &\sim \mathrm{Poisson}\big(t_i\lambda(x_i)\big) -\end{aligned} -$$ {#eq-rongelap-poisson-sglmmm} - -模型中，放射粒子数 $y(x_{i})$ 作为响应变量服从均值为 $t_i\lambda(x_i)$ 的泊松分布，其它模型成分的说明同前。简单起见，下面不添加块金效应，即。掉模型中的 $Z_i$ 。此时，块金效应对模型预测效果的提升很有限，由于 $\tau^2$ 和 $\sigma^2$ 之间存在的可识别性问题，会显著增加参数估计的复杂度。 - -**nlme** 包不能拟合空间广义线性混合效应模型， **spaMM** 包可以，它的使用语法与前面介绍的函数 `glm()` 、 **nlme** 包都类似，函数 `fitme()` 可以拟合从线性模型到广义线性混合效应模型的一大类模型，且使用统一的语法，输出一个 `HLfit` 类型的数据对象。 **spaMM** 包的函数 `Matern()` 实现了梅隆型自协方差函数，指数型和幂二次指数型是它的特例。当固定 $\nu = 0.5$ 时，梅隆型自协方差函数 `Matern()` 的形式退化为 $\sigma^2\exp(- \alpha u)$ ，其中，$\alpha$ 与范围参数关联，相当于前面出现的 $1/\phi$ 。 - -```{r} -#| message: false - -library(spaMM) -fit_rongelap_spamm <- fitme( - formula = counts ~ 1 + Matern(1 | cX + cY) + offset(log(time)), - family = poisson(link = "log"), data = rongelap, - fixed = list(nu = 0.5), method = "REML" -) -summary(fit_rongelap_spamm) -``` - -从输出结果来看，模型固定效应的截距项 $\beta$ 为 `1.829`，空间随机效应的方差 $\sigma^2$ 为 `0.3069`，对比函数 `Matern()` 实现的指数型自协方差函数公式与 @eq-matern-formula ，将输出结果转化一下，则 $\phi = 1 / 0.00921 = 108.57$ ，表示在这个模型的设定下，空间相关性的最大影响距离约为 108.5 米。 - -## 模型预测 {#sec-rongelap-predict} - -接下来，预测给定的边界（海岸线）内任意位置的核辐射强度，展示全岛的核辐射强度分布。先从点构造多边形数据，再将多边形做网格划分，继而将网格中心点作为模型输入获得核辐射强度的预测值。 - -### 海岸线数据 {#sec-rongelap-coastline} - -海岸线上取一些点，点的数量越多，对海岸线的刻画越精确，这在转弯处体现得非常明显。海岸线的数据是以成对的坐标构成，导入 R 语言中，是以数据框的形式存储，为了方便后续的操作，引入空间数据操作的 **sf** 包[@Pebesma2018]，将核辐射数据和海岸线数据转化为 POINT 类型的空间点数据。 - -```{r} -library(sf) -rongelap_sf <- st_as_sf(rongelap, coords = c("cX", "cY"), dim = "XY") -rongelap_coastline_sf <- st_as_sf(rongelap_coastline, coords = c("cX", "cY"), dim = "XY") -``` - -**sf** 包提供了大量操作空间数据的函数，比如函数 `st_bbox()` 计算一组空间数据的矩形边界，获得左下和右上两个点的坐标 `(xmin,ymin)` 和`(xmax,ymax)`，下面还会陆续涉及其它空间数据操作。 - -```{r} -st_bbox(rongelap_coastline_sf) -``` - -`rongelap_coastline_sf` 数据集是朗格拉普岛海岸线的采样点坐标，是一个 POINT 类型的数据，为了以海岸线为边界生成规则网格，首先连接点 POINT 构造多边形 POLYGON 对象。POINT 和 POLYGON 是 **sf** 包内建的基础的几何类型，其它复杂的空间类型是由它们衍生而来。函数 `st_geometry` 提取空间点数据中的几何元素，再用函数 `st_combine` 将点组合起来，最后用函数 `st_cast` 转换成 POLYGON 多边形类型。 - -```{r} -rongelap_coastline_sfp <- st_cast(st_combine(st_geometry(rongelap_coastline_sf)), "POLYGON") -``` - -@fig-point-to-polygon 上下两个子图分别展示空间点集和多边形。上图是原始的采样点数据，下图是以点带线，串联 POINT 数据构造 POLYGON 数据后的多边形。后续的数据操作将围绕这个多边形展开。 - -```{r} -#| label: fig-point-to-polygon -#| fig-cap: "朗格拉普岛海岸线的表示" -#| fig-subcap: -#| - 点数据 -#| - 多边形数据 -#| layout-ncol: 1 -#| fig-width: 5 -#| fig-height: 3 -#| fig-showtext: true -#| code-fold: true - -# 点集 -ggplot(rongelap_coastline_sf) + - geom_sf(size = 0.5) + - theme_void() -# 多边形 -ggplot(rongelap_coastline_sfp) + - geom_sf(fill = "white", linewidth = 0.5) + - theme_void() -``` - -### 边界处理 {#sec-rongelap-border} - -为了确保覆盖整个岛，处理好边界问题，需要一点缓冲空间，就是说在给定的边界线外围再延伸一段距离，构造一个更大的多边形，这可以用函数 `st_buffer()` 实现，根据海岸线构造缓冲区，得到一个 POLYGON 类型的几何数据对象。考虑到朗格拉普岛的实际大小，缓冲距离选择 50 米。 - -```{r} -rongelap_coastline_buffer <- st_buffer(rongelap_coastline_sfp, dist = 50) -``` - -缓冲区构造出来的效果如 @fig-rongelap-buffer 所示，为了便于与海岸线对比，图中将采样点、海岸线和缓冲区都展示出来了。 - -```{r} -#| label: fig-rongelap-buffer -#| fig-cap: "朗格拉普岛海岸线及其缓冲区" -#| fig-width: 6.2 -#| fig-height: 3.2 -#| fig-showtext: true -#| code-fold: true - -ggplot() + - geom_sf(data = rongelap_sf, size = 0.2) + - geom_sf(data = rongelap_coastline_sfp, fill = NA, color = "gray30") + - geom_sf(data = rongelap_coastline_buffer, fill = NA, color = "black") + - theme_void() -``` - -### 构造网格 {#sec-rongelap-grid} - -接下来，利用函数 `st_make_grid()` 根据朗格拉普岛海岸缓冲线构造网格，朗格拉普岛是狭长的，因此，网格是 $75\times 150$ 的，意味着水平方向 75 行，垂直方向 150 列。网格的疏密程度是可以调整的，网格越密，格点越多，核辐射强度分布越精确，计算也越耗时。 - -```{r} -# 构造带边界约束的网格 -rongelap_coastline_grid <- st_make_grid(rongelap_coastline_buffer, n = c(150, 75)) -``` - -函数 `st_make_grid()` 根据 `rongelap_coastline_buffer` 的矩形边界网格化，效果如 @fig-rongelap-grid 所示，依次添加了网格、海岸线和缓冲区。实际上，网格只需要覆盖朗格拉普岛即可，岛外的部分是大海，不需要覆盖，根据现有数据和模型对岛外区域预测核辐射强度也没有意义，因此，在后续的操作中，岛外的网格都要去掉。函数 `st_make_grid()` 除了支持方形网格划分，还支持六边形网格划分。 - -```{r} -#| label: fig-rongelap-coastline-grid -#| fig-cap: "朗格拉普岛规则化网格操作" -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true -#| code-fold: true - -ggplot() + - geom_sf(data = rongelap_coastline_grid, fill = NA, color = "gray") + - geom_sf(data = rongelap_coastline_sfp, fill = NA, color = "gray30") + - geom_sf(data = rongelap_coastline_buffer, fill = NA, color = "black") + - theme_void() -``` - -接下来，调用 **sf** 包函数 `st_intersects()` 将小网格落在缓冲区和岛内的筛选出来，一共 1612 个小网格，再用函数 `st_centroid()` 计算这些网格的中心点坐标。函数 `st_intersects()` 的作用是对多边形和网格取交集，包含与边界线交叉的网格，默认返回值是一个稀疏矩阵，与索引函数 `[.sf` （这是 **sf** 包扩展 `[` 函数的一个例子）搭配可以非常方便地过滤出目标网格。与之相关的函数 `st_crosses()` 可以获得与边界线交叉的网格。 - -```{r} -# 将 sfc 类型转化为 sf 类型 -rongelap_coastline_grid <- st_as_sf(rongelap_coastline_grid) -rongelap_coastline_buffer <- st_as_sf(rongelap_coastline_buffer) -rongelap_grid <- rongelap_coastline_grid[rongelap_coastline_buffer, op = st_intersects] -# 计算网格中心点坐标 -rongelap_grid_centroid <- st_centroid(rongelap_grid) -``` - -过滤出来的网格如 @fig-rongelap-grid 所示，全岛网格化后，图中将朗格拉普岛海岸线、网格都展示出来了。网格的中心点将作为新的坐标数据，后续要在这些新的坐标点上预测核辐射强度。 - -```{r} -#| label: fig-rongelap-grid -#| fig-cap: "朗格拉普岛规则网格划分结果" -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true -#| code-fold: true - -ggplot() + - geom_sf(data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.5) + - geom_sf(data = rongelap_grid, fill = NA, color = "gray30") + - theme_void() -``` - -### 整理数据 {#sec-rongelap-pred} - -函数 `st_coordinates()` 抽取网格中心点的坐标并用函数 `as.data.frame()` 转化为数据框类型，新数据的列名需要和训练数据保持一致，最后补充漂移项 `time`，以便输入模型中。漂移项并不影响核辐射强度，指定为 300 或 400 都可以。 - -```{r} -rongelap_grid_df <- as.data.frame(st_coordinates(rongelap_grid_centroid)) -colnames(rongelap_grid_df) <- c("cX", "cY") -rongelap_grid_df$time <- 1 -``` - -将数据输入 **spaMM** 包拟合的模型对象 `fit_rongelap_spamm`，并将模型返回的结果整理成数据框，再与采样点数据合并。`predict()` 是一个泛型函数，**spaMM** 包为模型对象提供了相应的预测方法。 - -```{r} -# 预测值 -rongelap_grid_pred <- predict(fit_rongelap_spamm, - newdata = rongelap_grid_df, type = "response" -) -rongelap_grid_df$pred_sp <- as.vector(rongelap_grid_pred) -# 线性预测的方差 -rongelap_grid_var <- get_predVar(fit_rongelap_spamm, - newdata = rongelap_grid_df, variances = list(predVar = TRUE), which = "predVar" -) -rongelap_grid_df$var_sp <- as.vector(rongelap_grid_var) -``` - -在空间线性混合效应模型一节，截距 $\beta$ ，方差 $\sigma^2$ ，块金效应 $\tau^2$ 和范围参数 $\phi$ 都估计出来了。在此基础上，采用简单克里金插值方法预测，对于未采样观测的位置 $x_0$，它的辐射强度的预测值 $\hat{\lambda}(x_0)$ 及其预测方差 $\mathsf{Var}\{\hat{\lambda}(x_0)\}$ 的计算公式如下。 - -$$ -\begin{aligned} -\hat{\lambda}(x_0) &= \beta + \boldsymbol{u}^{\top}(V + \tau^2I)^{-1}(\boldsymbol{\lambda} - \boldsymbol{1}\beta) \\ -\mathsf{Var}\{\hat{\lambda}(x_0)\} &= \sigma^2 - \boldsymbol{u}^{\top}(V + \tau^2I)^{-1}\boldsymbol{u} -\end{aligned} -$$ - -其中，协方差矩阵 $V$ 中第 $i$ 行第 $j$ 列的元素为 $\mathsf{Cov}\{S(x_i),S(x_j)\}$ ，列向量 $\boldsymbol{u}$ 的第 $i$ 个元素为 $\mathsf{Cov}\{S(x_i),S(x_0)\}$ 。 - -```{r} -# 截距 -beta <- 1.812914 -# 范围参数 -phi <- 169.7472088 -# 方差 -sigma_sq <- 0.2934473 -# 块金效应 -tau_sq <- 0.035991 -# 自协方差函数 -cov_fun <- function(h) sigma_sq * exp(-h / phi) -# 观测距离矩阵 -m_obs <- cov_fun(st_distance(x = rongelap_sf)) + diag(tau_sq, 157) -# 预测距离矩阵 -m_pred <- cov_fun(st_distance(x = rongelap_sf, y = rongelap_grid_centroid)) -# 简单克里金插值 Simple Kriging -mean_sk <- beta + t(m_pred) %*% solve(m_obs, log(rongelap_sf$counts / rongelap_sf$time) - beta) -# 辐射强度预测值 -rongelap_grid_df$pred_sk <- exp(mean_sk) -# 辐射强度预测方差 -rongelap_grid_df$var_sk <- sigma_sq - diag(t(m_pred) %*% solve(m_obs, m_pred)) -``` - -### 展示结果 {#sec-rongelap-plot} - -将预测结果以散点图的形式呈现到图上，见下 @fig-rongelap-pred ，由于散点非常多，紧挨在一起就连成片了。上子图是 **nlme** 包预测的结果，下子图是 **spaMM** 包预测的结果，前者图像看起来会稍微平滑一些。 - -```{r} -#| label: fig-rongelap-pred -#| fig-cap: 朗格拉普岛核辐射强度的分布 -#| fig-width: 6 -#| fig-height: 6 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -# 数据框变形 -rongelap_grid_df2 <- reshape( - data = rongelap_grid_df, - varying = c("pred_sp", "var_sp", "pred_sk", "var_sk"), - times = c("spaMM", "nlme"), v.names = c("pred", "var"), - timevar = "method", idvar = c("cX", "cY"), - new.row.names = 1:(2 * 1612), direction = "long" -) -# 数据框类型转换 -rongelap_grid_sf2 <- st_as_sf(rongelap_grid_df2, coords = c("cX", "cY"), dim = "XY") -# 分面展示两种预测方法 -ggplot(data = rongelap_grid_sf2) + - geom_sf(aes(color = pred), size = 0.5) + - scale_color_viridis_c(option = "C", breaks = 0:12, - guide = guide_colourbar( - barwidth = 1, barheight = 15 - )) + - facet_wrap(~method, ncol = 1) + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", color = "预测值") -``` - -从空间线性混合效应模型到空间广义线性混合效应模型的效果提升不多，差异不太明显。下 @fig-rongelap-var 展示核辐射强度预测方差的分布。越简单的模型，预测值的分布越平滑，越复杂的模型，捕捉到更多局部细节，因而，预测值的分布越曲折。 - -```{r} -#| label: fig-rongelap-var -#| fig-cap: 核辐射强度预测方差的分布 -#| fig-width: 6 -#| fig-height: 6 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -# 分面展示两种预测方法 -ggplot(data = rongelap_grid_sf2) + - geom_sf(aes(color = var), size = 0.5) + - scale_color_viridis_c( - option = "C", breaks = 0.1 * 0:16 / 4, - guide = guide_colourbar( - barwidth = 1, barheight = 15 - ) - ) + - facet_wrap(~method, ncol = 1) + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", color = "预测方差") -``` - -考虑到核辐射在全岛的分布应当是连续性的，空间连续性也是这类模型的假设，接下来绘制热力图，先用 **stars** 包[@stars2022]将预测数据按原网格化的精度转化成栅格对象，裁减超出朗格拉普岛海岸线以外的内容。 - -```{r} -library(abind) -library(stars) -rongelap_grid_sf <- st_as_sf(rongelap_grid_df, coords = c("cX", "cY"), dim = "XY") -rongelap_grid_stars <- st_rasterize(rongelap_grid_sf, nx = 150, ny = 75) -rongelap_stars <- st_crop(x = rongelap_grid_stars, y = rongelap_coastline_sfp) -``` - -除了矢量栅格化函数 `st_rasterize()` 和栅格剪裁函数 `st_crop()` ，**stars** 包还提供栅格数据图层 `geom_stars()`，这可以和 **ggplot2** 内置的图层搭配使用。下 @fig-rongelap-pred-sp 是 **ggplot2** 包和 **grid** 包一起绘制的辐射强度的热力分布图，展示 **spaMM** 包的预测效果。图左侧一小一大两个虚线框是放大前后的部分区域，展示朗格拉普岛核辐射强度的局部变化。 - -```{r} -#| label: fig-rongelap-pred-sp -#| fig-cap: "朗格拉普岛核辐射强度的分布" -#| fig-width: 7.5 -#| fig-height: 4.5 -#| fig-showtext: true -#| echo: !expr knitr::is_html_output() -#| code-fold: true - -# 虚线框数据 -dash_sfp <- st_polygon(x = list(rbind( - c(-6000, -3600), - c(-6000, -2600), - c(-5000, -2600), - c(-5000, -3600), - c(-6000, -3600) -)), dim = "XY") -# 主体内容 -p3 <- ggplot() + - geom_stars( - data = rongelap_stars, na.action = na.omit, - aes(fill = pred_sp / time) - ) + - # 海岸线 - geom_sf( - data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.5 - ) + - # 图例 - scale_fill_viridis_c( - option = "C", breaks = 0:12, - guide = guide_colourbar( - barwidth = 15, barheight = 1.5, - title.position = "top" # 图例标题位于图例上方 - ) - ) + - # 虚线框 - geom_sf(data = dash_sfp, fill = NA, linewidth = 0.75, lty = 2) + - # 箭头 - geom_segment( - data = data.frame(x = -5500, xend = -5000, y = -2600, yend = -2250), - aes(x = x, y = y, xend = xend, yend = yend), - arrow = arrow(length = unit(0.03, "npc")) - ) + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", fill = "辐射强度") + - theme( - legend.position = "inside", - legend.position.inside = c(0.75, 0.1), - legend.direction = "horizontal", - legend.background = element_blank() - ) - -p4 <- ggplot() + - geom_stars( - data = rongelap_stars, na.action = na.omit, - aes(fill = pred_sp / time), show.legend = FALSE - ) + - geom_sf( - data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.75 - ) + - scale_fill_viridis_c(option = "C", breaks = 0:12) + - # 虚线框 - geom_sf(data = dash_sfp, fill = NA, linewidth = 0.75, lty = 2) + - theme_void() + - coord_sf(expand = FALSE, xlim = c(-6000, -5000), ylim = c(-3600, -2600)) -# 叠加图形 -p3 -print(p4, vp = grid::viewport(x = .3, y = .65, width = .45, height = .45)) -``` - -美国当年是在比基尼环礁做的氢弹核试验，试验地与朗格拉普岛相距 100 多英里。核辐射羽流受大气、海洋环流等影响，漂流到朗格拉普岛。又受朗格拉普岛周围水文、地理环境影响，核辐射强度在全岛的分布是不均匀的，图中越亮的地方表示受到的核辐射越严重。 diff --git a/classification-problems.qmd b/classification-problems.qmd deleted file mode 100644 index 8c805aee..00000000 --- a/classification-problems.qmd +++ /dev/null @@ -1,460 +0,0 @@ -# 分类问题 {#sec-classification-problems} - -```{r} -#| message: false - -library(nnet) # 多项回归/神经网络 multinom / nnet -library(MASS) # 线性/二次判别分析 lda / qda -library(glmnet) # 惩罚多项回归 glmnet -library(e1071) # 朴素贝叶斯 naiveBayes 和支持向量机 svm -library(kernlab) # 支持向量机分类 ksvm -library(class) # K 最近邻 knn -library(rpart) # 决策树分类 rpart -library(randomForest) # 随机森林 randomForest -# library(gbm) # 梯度提升机 -library(xgboost) # 集成学习 -library(lattice) -``` - -以 iris 数据集为例，简单，方便介绍模型和算法，定位入门。分类间隔最大化，也是一个优化问题，找一条分界线，一个分割面，一个超平面划分不同的种类。本章篇幅：每个算法 4 页，共计 40 页。10 个算法的介绍按照分类思路，模型，代码和参数说明，分类性能评估。应用案例是手写数字识别。要点不是数据如何复杂，而是怎样把理论写得通俗、准确，看了之后能够应用到复杂的真实数据分析场景中去。理论解释、绘图说明、经验总结。 - -1. 线性分类器 - 2. 多项回归模型 - 3. 线性判别分析 -2. 非线性分类器 - 1. 二次判别分析 - 2. 朴素贝叶斯 - 3. 支持向量机 - 4. K 最近邻 - 5. 神经网络 - 6. 决策树 - 7. 随机森林 - 8. 集成学习 - -iris 数据集也来自 Base R 自带的 **datasets** 包，由 Anderson Edgar 收集，最早见于 1935 年的文章，后被 Ronald Fisher 在研究分类问题时引用 [@Fisher1936]。到如今，在机器学习的社区里，提及 iris 数据集，一般只知 Fisher 不知 Anderson。 - -::: callout-tip -1. 鸢尾花数据集，逻辑回归拟合，绘制分类边界图，实现 R 版本。 -2. 参考文献《机器学习的概率视角导论》 [@pml2022] 书中图 2.13 的 Python [代码](https://github.com/probml/pyprobml/blob/master/scripts/iris_logreg.py#L115) -3. 将回归模型用 SQL 表达出来，放在数据库上高性能地执行分类预测。 -::: - -## 多项回归模型 {#sec-multinomial-regression-models} - -```{r} -library(nnet) # 多项逻辑回归 -iris_multinom <- multinom(Species ~ ., data = iris, trace = FALSE) -summary(iris_multinom) -``` - -```{r} -table(predict(iris_multinom, iris[, -5], type = "class"), iris[, 5]) -``` - -在有的数据中，观测变量之间存在共线性，采用变量选择方法，比如 Lasso 方法压缩掉一部分变量。 - -```{r} -library(glmnet) # 多项回归 -iris_glmnet <- glmnet(x = iris[, -5], y = iris[, 5], family = "multinomial") -``` - -```{r} -#| label: fig-multinom-glmnet -#| fig-cap: 迭代路径 -#| fig-subcap: -#| - 回归系数 setosa 的迭代路径 -#| - 回归系数 versicolor 的迭代路径 -#| - 回归系数 virginica 的迭代路径 -#| - 惩罚系数的迭代路径 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true -#| layout-ncol: 2 - -plot(iris_glmnet) -plot(iris_glmnet$lambda, - ylab = expression(lambda), xlab = "迭代次数", main = "惩罚系数的迭代路径" -) -``` - -选择一个迭代趋于稳定时的 lambda，比如 `iris_glmnet$lambda[80]` 。 - -```{r} -coef(iris_glmnet, s = 0.0002796185) -``` - -```{r} -iris_pred_glmnet <- predict( - object = iris_glmnet, newx = as.matrix(iris[, -5]), - s = 0.0002796185, type = "class" -) -``` - -```{r} -table(iris_pred_glmnet, iris[, 5]) -``` - -## 线性判别分析 {#sec-linear-discriminant-analysis} - -```{r} -library(MASS) -# lda -iris_lda <- lda(Species ~ ., data=iris) -iris_lda -# 预测 -iris_lda_pred <- predict(iris_lda, iris[, -5])$class -``` - -```{r} -# 预测结果 -table(iris_lda_pred, iris[, 5]) -``` - -## 二次判别分析 {#sec-quadratic-discriminant-analysis} - -```{r} -# Quadratic Discriminant Analysis 二次判别分析 -iris_qda <- qda(Species ~ ., data=iris) -iris_qda -# 预测 -iris_qda_pred <- predict(iris_qda, iris[, -5])$class -``` - -```{r} -# 预测结果 -table(iris_qda_pred, iris[, 5]) -``` - -```{r} -#| eval: false -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -library(mda) -# Mixture Discriminant Analysis 混合判别分析 -iris_mda <- mda(Species ~ ., data = iris) -# 预测 -iris_mda_pred <- predict(iris_mda, newdata = iris[, -5]) -# 预测结果 -table(iris_mda_pred, iris[, 5]) - -# Flexible Discriminant Analysis 灵活判别分析 -iris_fda <- fda(Species ~ ., data = iris) -# 预测 -iris_fda_pred <- predict(iris_fda, newdata = iris[, -5]) -# 预测结果 -table(iris_fda_pred, iris[, 5]) - -# Regularized Discriminant Analysis 正则判别分析 -library(klaR) -iris_rda <- rda(Species ~ ., data = iris, gamma = 0.05, lambda = 0.01) -# 输出结果 -summary(iris_rda) -# 预测 -iris_rda_pred <- predict(iris_rda, newdata = iris[, -5])$class -# 预测结果 -table(iris_rda_pred, iris[, 5]) -``` - -## 朴素贝叶斯 {#sec-naive-bayes} - -```{r} -library(e1071) # 朴素贝叶斯 -iris_nb <- naiveBayes(Species ~ ., data = iris) -iris_nb -# 预测 -iris_nb_pred <- predict(iris_nb, newdata = iris, type = "class") -# 预测结果 -table(iris_nb_pred, iris[, 5]) -``` - -## 支持向量机 {#sec-support-vector-machines} - -**e1071** 包也提供支持向量机 - -```{r} -# e1071 -iris_svm <- svm(Species ~ ., data = iris) -iris_svm -# 预测 -iris_svm_pred <- predict(iris_svm, newdata = iris, probability = FALSE) -# 预测结果 -table(iris_svm_pred, iris[, 5]) -``` - -**kernlab** 包提供核支持向量机。 - -```{r} -library(kernlab) -iris_ksvm <- ksvm(Species ~ ., data = iris) -iris_ksvm -``` - -**kernlab** 包 [@kernlab2004] 的绘图函数 `plot()` 仅支持二分类模型。 - -```{r} -iris_pred_svm <- predict(iris_ksvm, iris[, -5], type = "response") -table(iris_pred_svm, iris[, 5]) -``` - -## K 最近邻 {#sec-k-nearest-neighbour} - -```{r} -# 将 iris3 数据集拆分为训练集和测试集 -iris_train <- rbind(iris3[1:25, , 1], iris3[1:25, , 2], iris3[1:25, , 3]) -iris_test <- rbind(iris3[26:50, , 1], iris3[26:50, , 2], iris3[26:50, , 3]) -iris_species <- factor(rep(c("setosa", "versicolor", "virginica"), each = 25)) -``` - -```{r} -library(class) -# 分 3 类 -iris_knn <- knn( - train = iris_train, test = iris_test, - cl = iris_species, k = 3, prob = TRUE -) -# 分类结果汇总 -table(iris_knn, iris_species) -``` - -## 神经网络 {#sec-neural-networks} - -```{r} -library(nnet) -iris_nnet <- nnet(Species ~ ., data = iris, size = 4, trace = FALSE) -summary(iris_nnet) -``` - -size 隐藏层中的神经元数量 - -```{r} -iris_pred_nnet <- predict(iris_nnet, newdata = iris[,-5], type = "class") -table(iris_pred_nnet, iris[, 5]) -``` - -## 决策树 {#sec-recursive-partitioning} - -```{r} -library(rpart) -iris_rpart <- rpart(Species ~ ., data = iris) -iris_rpart -``` - -```{r} -#| label: fig-iris-rpart -#| fig-width: 5 -#| fig-height: 4 -#| fig-cap: 分类回归树 -#| fig-showtext: true - -library(rpart.plot) -rpart.plot(iris_rpart) -``` - -预测结果，训练误差 - -```{r} -# 预测 -iris_pred_rpart <- predict(iris_rpart, iris[, -5], type = "class") -# 预测结果 -table(iris_pred_rpart, iris[, 5]) -``` - -**party** 包和 **partykit** 包也提供类似的功能，前者是基于 C 语言实现，后者基于 R 语言实现。 - -```{r} -#| eval: false -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -# 与 rpart 包分类的结果一样 -library(partykit) -iris_party <- ctree(Species ~ ., data = iris) -plot(iris_party) -iris_pred_party <- predict(iris_party, iris[, -5], type = "response") -table(iris_pred_party, iris[, 5]) - -# PART 算法 -library(RWeka) -iris_weka <- PART(Species ~ ., data = iris) -# 输出拟合结果 -summary(iris_weka) -# 预测 -iris_pred_weka <- predict(iris_weka, newdata = iris[, -5], type = "class") -# 预测结果 -table(iris_pred_weka, iris[, 5]) - -# Bagging CART -library(ipred) -iris_ipred <- bagging(Species ~ ., data = iris) -# 输出拟合结果 -# summary(iris_ipred) -# 预测 -iris_pred_ipred <- predict(iris_ipred, newdata = iris[, -5], type = "class") -# 预测结果 -table(iris_pred_ipred, iris[, 5]) - -# Boosted C5.0 -library(C50) -iris_C50 <- C5.0(Species ~ ., data = iris) -# 预测 -iris_pred_C50 <- predict(iris_C50, newdata = iris[, -5]) -# 预测结果 -table(iris_pred_C50, iris[, 5]) - -# Gradient Boosted Machine -# Warning message: -# Setting `distribution = "multinomial"` is ill-advised -# as it is currently broken. -# It exists only for backwards compatibility. Use at your own risk. -library(gbm) -iris_gbm <- gbm(Species ~ ., data = iris, distribution = "multinomial") -# 预测 -iris_pred_gbm <- predict(iris_gbm, newdata = iris[, -5], n.trees = 1, type = "response") -# 转化为与响应变量一样的取值 -pred_gbm <- colnames(iris_pred_gbm)[apply(iris_pred_gbm, 1, which.max)] -# 预测结果 -table(pred_gbm, iris[, 5]) -``` - -## 随机森林 {#sec-random-forests} - -```{r} -library(randomForest) # 随机森林 -iris_rf <- randomForest( - Species ~ ., data = iris, - importance = TRUE, proximity = TRUE -) -# 分类结果 -print(iris_rf) -``` - -```{r} -#| label: fig-iris-rf -#| fig-cap: 随机森林 -#| fig-height: 4 -#| fig-width: 5 -#| fig-showtext: true -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -op <- par(mar = c(4, 4, 1.5, 0.1)) -plot(iris_rf, main = "") -on.exit(par(op), add = TRUE) -``` - -```{r} -#| label: fig-iris-vi -#| fig-cap: 变量重要性 -#| fig-height: 4 -#| fig-width: 7 -#| fig-showtext: true - -varImpPlot(iris_rf, main = "变量重要性") -``` - -```{r} -iris_pred_rf <- predict(iris_rf, iris[, -5], type = "response") -table(iris_pred_rf, iris[, 5]) -``` - -## 集成学习 - -在训练模型之前，需要先对数据集做预处理，包括分组采样、类别编码、数据拆分、类型转换等。 - -制作一个函数对数据集添加新列 `mark` 作为训练集 train 和测试集 test 的采样标记，返回数据。 - -```{r} -# 输入数据 x 和采样比例 prop -add_mark <- function(x = iris, prop = 0.7) { - idx <- sample(x = nrow(x), size = floor(nrow(x) * prop)) - rbind( - cbind(x[idx, ], mark = "train"), - cbind(x[-idx, ], mark = "test") - ) -} -``` - -为了使采样结果可重复，设置随机数种子，然后对 `iris` 数据集按列 `Species` 分组添加采样标记，分组随机抽取 70% 的样本作为训练数据，余下的作为测试数据。就 `iris` 数据集来说，训练集有 `35*3 = 105` 条记录，测试集有 `15*3 = 45` 条记录。 - -```{r} -set.seed(20232023) -iris_df <- do.call(rbind, lapply(split(iris, iris$Species), add_mark, prop = 0.7)) -``` - -为了使用函数 `fcase()` 对分类变量 `Species` 做重编码操作，加载 **data.table** 包，将数据集 `iris_df` 转为 `data.table` 类型。值得注意，**xgboost** 包要求分类变量的类别序号必须从 0 开始。 - -```{r} -# 数据准备 -library(data.table) -iris_dt <- as.data.table(iris_df) -iris_dt <- iris_dt[, Species := fcase( - Species == "setosa", 0, - Species == "versicolor", 1, - Species == "virginica", 2 -)] -``` - -将数据 `iris_dt` 拆分成训练集和测试集，并以列表结构存储数据，样本数据及标签以矩阵类型存储。 - -```{r} -# 训练数据 -iris_train <- list( - data = as.matrix(iris_dt[iris_dt$mark == "train", -c("mark", "Species")]), - label = as.matrix(iris_dt[iris_dt$mark == "train", "Species"]) -) -# 测试数据 -iris_test <- list( - data = as.matrix(iris_dt[iris_dt$mark == "test", -c("mark", "Species")]), - label = as.matrix(iris_dt[iris_dt$mark == "test", "Species"]) -) -``` - -数据准备好后，加载 **xgboost** 包，设置训练参数，开始训练分类模型。此分类任务中类别超过 2，是多分类任务，学习任务是分类，目标函数可以是 `objective = "multi:softprob"` 或者 `objective = "multi:softmax"`，相应的评估指标可以是 `eval_metric = "mlogloss"` 或者 `eval_metric = "merror"`。`iris` 数据集的分类变量 `Species` 共有 3 类，所以 `num_class = 3` 。 - -```{r} -library(xgboost) -iris_xgb <- xgboost( - data = iris_train$data, - label = iris_train$label, - objective = "multi:softmax", # 学习任务 - eval_metric = "mlogloss", # 评估指标 - nrounds = 2, # 提升迭代的最大次数 - num_class = 3 # 分类数 -) -``` - -将训练好的模型放在测试集数据上进行预测。 - -```{r} -# ?predict.xgb.Booster -iris_pred <- predict(object = iris_xgb, newdata = iris_test$data) -``` - -将预测结果与测试集中的样本标签对比，检查分类效果。 - -```{r} -table(iris_test$label, iris_pred) -``` - -## 总结 {#sec-classification-problems-summary} - -不同的分类算法分布在不同的 R 包中，在使用方式上既有相通之处，又有不同之处。下表对多个 R 包的使用做了归纳。R 包之间的不一致性，计算预测分类的概率的语法。 - -| 函数 | R 包 | 代码 | -|:---------------|:-------------|:-------------------------------------------| -| `lda()` | **MASS** | `predict(obj)` | -| `glm()` | **stats** | `predict(obj, type = "response")` | -| `gbm()` | **gbm** | `predict(obj, type = "response", n.trees)` | -| `naiveBayes()` | **e1071** | `predict(obj, type = "class")` | -| `svm()` | **e1071** | `predict(obj, probability = FALSE)` | -| `ksvm()` | **kernlab** | `predict(obj, type = "response")` | -| `mda()` | **mda** | `predict(obj, type = "posterior")` | -| `rpart()` | **rpart** | `predict(obj, type = "prob")` | -| `Weka()` | **RWeka** | `predict(obj, type = "probability")` | -| `ctree()` | **partykit** | `predict(obj, type = "response")` | -| `bagging()` | **ipred** | `predict(obj, type = "class")` | - -## 习题 {#sec-exercise-classification} - -1. [**titanic**](https://github.com/paulhendricks/titanic) 包整理了来自 kaggle 的 [Titanic](https://www.kaggle.com/c/titanic/data) 数据集，详细记录了 891 位乘客的信息，它比 Base R 内置的 Titanic 数据集更加原始，细节更多，信息更加丰富。原数据集拆分为训练集 `titanic_train` 和测试集 `titanic_test`。因为有每个乘客的原始信息，我们可以在个体水平上建模，采用更加复杂的模型分析泰坦尼克号乘客存活率及其影响因素。 diff --git a/clustering-problems.qmd b/clustering-problems.qmd deleted file mode 100644 index 07f7a117..00000000 --- a/clustering-problems.qmd +++ /dev/null @@ -1,21 +0,0 @@ -# 聚类问题 {#sec-clustering-problems} - -## 层次聚类 {#sec-hierarchical-clustering} - -来自 stats 包的函数 `hclust()` 和来自 [cluster](https://cran.r-project.org/web/packages/cluster/index.html) 包的函数 `agnes()` 和函数 `diana()` [@kaufman1990] - -## 快速聚类 {#sec-partitioning-clustering} - -来自 stats 包的函数 `kmeans()` 和来自 [cluster](https://cran.r-project.org/web/packages/cluster/index.html) 包的函数 `pam()` ，**kernlab** 包 [@kernlab2004] 的 K-means 聚类函数 `kkmeans()` 和谱聚类函数 `specc()` 。 - -## 模糊聚类 {#sec-fuzzy-clustering} - -来自 [e1071](https://cran.r-project.org/web/packages/e1071/index.html) 包 [@e10712023] 的 fuzzy clustering 模糊聚类 和 bagged clustering 装袋聚类两种聚类方法 - -## 基于模型的聚类 {#sec-model-based-clustering} - -来自 [mclust](https://mclust-org.github.io/mclust/) 包 [@Scrucca2016] 有限混合模型 - -## 基于密度的聚类 {#sec-density-based-clusting} - -来自 [dbscan](https://cran.r-project.org/web/packages/dbscan/index.html) 包 [@Hahsler2019] diff --git a/code/bernoulli_logit_glm_horseshoe.stan b/code/bernoulli_logit_glm_horseshoe.stan deleted file mode 100644 index e0ca4686..00000000 --- a/code/bernoulli_logit_glm_horseshoe.stan +++ /dev/null @@ -1,28 +0,0 @@ -data { - int k; - int n; - matrix[n, k] X; - array[n] int y; -} -parameters { - vector[k] beta_tilde; - real alpha; - real tau; - vector[k] lambda; -} -transformed parameters { - vector[k] beta = beta_tilde .* lambda * tau; -} -model { - target += normal_lpdf(beta_tilde | 0, lambda); - target += normal_lpdf(alpha | 0, lambda); - target += cauchy_lpdf(tau | 0, 1); - target += cauchy_lpdf(lambda | 0, 1); - target += bernoulli_logit_glm_lpmf(y | X, alpha, beta); -} -generated quantities { - vector[n] log_lik; - for (i in 1 : n) { - log_lik[i] = bernoulli_logit_lpmf(y[i] | alpha + X[i] * beta); - } -} diff --git a/code/bernoulli_logit_glm_lasso.stan b/code/bernoulli_logit_glm_lasso.stan deleted file mode 100644 index 0845ecd7..00000000 --- a/code/bernoulli_logit_glm_lasso.stan +++ /dev/null @@ -1,23 +0,0 @@ -data { - int k; - int n; - matrix[n, k] X; - array[n] int y; -} -parameters { - vector[k] beta; - real alpha; - real lambda; -} -model { - target += double_exponential_lpdf(beta | 0, lambda); - target += double_exponential_lpdf(alpha | 0, lambda); - target += cauchy_lpdf(lambda | 0, 0.01); - target += bernoulli_logit_glm_lpmf(y | X, alpha, beta); -} -generated quantities { - vector[n] log_lik; - for (i in 1 : n) { - log_lik[i] = bernoulli_logit_lpmf(y[i] | alpha + X[i] * beta); - } -} diff --git a/code/bernoulli_logit_glm_normal.stan b/code/bernoulli_logit_glm_normal.stan deleted file mode 100644 index bd7b4e8e..00000000 --- a/code/bernoulli_logit_glm_normal.stan +++ /dev/null @@ -1,21 +0,0 @@ -data { - int k; - int n; - matrix[n, k] X; - array[n] int y; -} -parameters { - vector[k] beta; - real alpha; -} -model { - target += normal_lpdf(beta | 0, 1000); - target += normal_lpdf(alpha | 0, 1000); - target += bernoulli_logit_glm_lpmf(y | X, alpha, beta); -} -generated quantities { - vector[n] log_lik; - for (i in 1 : n) { - log_lik[i] = bernoulli_logit_lpmf(y[i] | alpha + X[i] * beta); - } -} diff --git a/code/eight_schools.stan b/code/eight_schools.stan deleted file mode 100644 index 2cee3b97..00000000 --- a/code/eight_schools.stan +++ /dev/null @@ -1,20 +0,0 @@ -data { - int J; // 学校数目 - array[J] real y; // 测试效果的预测值 - array[J] real sigma; // 测试效果的标准差 -} -parameters { - real mu; - real tau; - vector[J] eta; -} -transformed parameters { - vector[J] theta; - theta = mu + tau * eta; -} -model { - target += normal_lpdf(mu | 0, 100); - target += normal_lpdf(tau | 0, 100); - target += normal_lpdf(eta | 0, 1); - target += normal_lpdf(y | theta, sigma); -} diff --git a/code/faithful_2d_finite_mixtures.stan b/code/faithful_2d_finite_mixtures.stan deleted file mode 100644 index 0a5eb0c8..00000000 --- a/code/faithful_2d_finite_mixtures.stan +++ /dev/null @@ -1,32 +0,0 @@ -data { - int K; // number of mixture components - int N; // number of observations - int D; // dimension of observations - array[N] vector[D] y; // observations: a list of N vectors (each has D elements) -} -transformed data { - vector[D] mu0 = rep_vector(0, D); - matrix[D, D] Sigma0 = diag_matrix(rep_vector(1, D)); -} -parameters { - simplex[K] theta; // mixing proportions - array[K] positive_ordered[D] mu; // locations of mixture components - // scales of mixture components - array[K] cholesky_factor_corr[D] Lcorr; // cholesky factor (L_u matrix for R) -} -model { - for(i in 1:K){ - mu[i] ~ multi_normal(mu0, Sigma0); // prior for mu - Lcorr[i] ~ lkj_corr_cholesky(2.0); // prior for cholesky factor of a correlation matrix - } - - vector[K] log_theta = log(theta); // cache log calculation - - for (n in 1:N) { - vector[K] lps = log_theta; - for (k in 1:K) { - lps[k] += multi_normal_cholesky_lpdf(y[n] | mu[k], Lcorr[k]); - } - target += log_sum_exp(lps); - } -} diff --git a/code/faithful_finite_mixtures.stan b/code/faithful_finite_mixtures.stan deleted file mode 100644 index 2e9f81f0..00000000 --- a/code/faithful_finite_mixtures.stan +++ /dev/null @@ -1,22 +0,0 @@ -data { - int K; // number of mixture components - int N; // number of data points - array[N] real y; // observations -} -parameters { - simplex[K] theta; // mixing proportions - ordered[K] mu; // locations of mixture components - vector[K] sigma; // scales of mixture components -} -model { - vector[K] log_theta = log(theta); // cache log calculation - sigma ~ lognormal(0, 2); - mu ~ normal(0, 10); - for (n in 1:N) { - vector[K] lps = log_theta; - for (k in 1:K) { - lps[k] += normal_lpdf(y[n] | mu[k], sigma[k]); - } - target += log_sum_exp(lps); - } -} diff --git a/code/gaussian_process_fitted.stan b/code/gaussian_process_fitted.stan deleted file mode 100644 index 08c20a59..00000000 --- a/code/gaussian_process_fitted.stan +++ /dev/null @@ -1,26 +0,0 @@ -data { - int N; - int D; - array[N] vector[D] x; - vector[N] y; -} -transformed data { - real delta = 1e-9; - vector[N] mu = rep_vector(0, N); -} -parameters { - real phi; - real sigma; -} -model { - matrix[N, N] L_K; - { - matrix[N, N] K = gp_exponential_cov(x, sigma, phi) + diag_matrix(rep_vector(delta, N)); - L_K = cholesky_decompose(K); - } - - phi ~ std_normal(); - sigma ~ std_normal(); - - y ~ multi_normal_cholesky(mu, L_K); -} diff --git a/code/gaussian_process_pred.stan b/code/gaussian_process_pred.stan deleted file mode 100644 index 29a14d3d..00000000 --- a/code/gaussian_process_pred.stan +++ /dev/null @@ -1,88 +0,0 @@ -functions { - vector gp_pred_rng(array[] vector x2, - vector y1, - array[] vector x1, - real sigma, - real phi, - real tau, - real delta) { - int N1 = rows(y1); - int N2 = size(x2); - vector[N2] f2; - { - matrix[N1, N1] L_K; - vector[N1] K_div_y1; - matrix[N1, N2] k_x1_x2; - matrix[N1, N2] v_pred; - vector[N2] f2_mu; - matrix[N2, N2] cov_f2; - matrix[N2, N2] diag_delta; - matrix[N1, N1] K; - K = gp_exponential_cov(x1, sigma, phi); - for (n in 1:N1) { - K[n, n] = K[n, n] + square(tau); - } - L_K = cholesky_decompose(K); - K_div_y1 = mdivide_left_tri_low(L_K, y1); - K_div_y1 = mdivide_right_tri_low(K_div_y1', L_K)'; - k_x1_x2 = gp_exponential_cov(x1, x2, sigma, phi); - f2_mu = (k_x1_x2' * K_div_y1); - v_pred = mdivide_left_tri_low(L_K, k_x1_x2); - cov_f2 = gp_exponential_cov(x2, sigma, phi) - v_pred' * v_pred; - diag_delta = diag_matrix(rep_vector(delta, N2)); - - f2 = multi_normal_rng(f2_mu, cov_f2 + diag_delta); - } - return f2; - } -} -data { - int D; - int N1; - array[N1] vector[D] x1; - vector[N1] y1; - int N2; - array[N2] vector[D] x2; -} -transformed data { - real delta = 1e-9; -} -parameters { - real beta; - real phi; - real sigma; - real tau; -} -transformed parameters { - vector[N1] mu = rep_vector(beta, N1); -} -model { - matrix[N1, N1] L_K; - { - matrix[N1, N1] K = gp_exponential_cov(x1, sigma, phi); - real sq_tau = square(tau); - - // diagonal elements - for (n1 in 1:N1) { - K[n1, n1] = K[n1, n1] + sq_tau; - } - - L_K = cholesky_decompose(K); - } - - beta ~ std_normal(); - phi ~ std_normal(); - sigma ~ inv_gamma(5, 5); - tau ~ std_normal(); - - y1 ~ multi_normal_cholesky(mu, L_K); -} -generated quantities { - vector[N2] f2; - vector[N2] ypred; - - f2 = gp_pred_rng(x2, y1, x1, sigma, phi, tau, delta); - for (n2 in 1:N2) { - ypred[n2] = normal_rng(f2[n2], tau); - } -} diff --git a/code/gaussian_process_simu.stan b/code/gaussian_process_simu.stan deleted file mode 100644 index f2fe96c6..00000000 --- a/code/gaussian_process_simu.stan +++ /dev/null @@ -1,24 +0,0 @@ -data { - int N; - int D; - array[N] vector[D] X; - vector[N] mu; - real sigma; - real phi; -} -transformed data { - real delta = 1e-9; - matrix[N, N] L; - matrix[N, N] K = gp_exponential_cov(X, sigma, phi) + diag_matrix(rep_vector(delta, N)); - L = cholesky_decompose(K); -} -parameters { - vector[N] eta; -} -model { - eta ~ std_normal(); -} -generated quantities { - vector[N] y; - y = mu + L * eta; -} diff --git a/code/hnm.bugs b/code/hnm.bugs deleted file mode 100644 index 35b7047a..00000000 --- a/code/hnm.bugs +++ /dev/null @@ -1,21 +0,0 @@ -model { - ## specify the distribution for observations - for(i in 1:n){ - y[i] ~ dnorm(theta[group[i]], 1/sigma2) - } - - ## specify the prior for theta - for(j in 1:J){ - theta[j] ~ dnorm(mu, 1/tau2) - } - - ## specify the prior for hyperparameters - mu ~ dunif(55, 75) - - log_sigma ~ dunif(-10, 3) - sigma2 <- exp(2*log_sigma) - sigma <- exp(log_sigma) - - tau ~ dunif(0, 8) - tau2 <- pow(tau, 2) -} diff --git a/code/multi_normal_fitted.stan b/code/multi_normal_fitted.stan deleted file mode 100644 index 2d7254a8..00000000 --- a/code/multi_normal_fitted.stan +++ /dev/null @@ -1,21 +0,0 @@ -data { - int N; // number of observations - int K; // dimension of observations - array[N] vector[K] y; // observations: a list of N vectors (each has K elements) -} -parameters { - vector[K] mu; - cholesky_factor_corr[K] Lcorr; // cholesky factor (L_u matrix for R) - vector[K] sigma; -} -transformed parameters { - corr_matrix[K] R; // correlation matrix - cov_matrix[K] Sigma; // VCV matrix - R = multiply_lower_tri_self_transpose(Lcorr); // R = Lcorr * Lcorr' - Sigma = quad_form_diag(R, sigma); // quad_form_diag: diag_matrix(sig) * R * diag_matrix(sig) -} -model { - sigma ~ cauchy(0, 5); // prior for sigma - Lcorr ~ lkj_corr_cholesky(2.0); // prior for cholesky factor of a correlation matrix - y ~ multi_normal(mu, Sigma); -} diff --git a/code/multi_normal_simu.stan b/code/multi_normal_simu.stan deleted file mode 100644 index 1c4f2573..00000000 --- a/code/multi_normal_simu.stan +++ /dev/null @@ -1,19 +0,0 @@ -data { - int N; - int D; - vector[D] mu; - matrix[D, D] Sigma; -} -transformed data { - matrix[D, D] L_K = cholesky_decompose(Sigma); -} -parameters { -} -model { -} -generated quantities { - array[N] vector[D] yhat; - for (n in 1:N){ - yhat[n] = multi_normal_cholesky_rng(mu, L_K); - } -} diff --git a/code/poisson_log_glm.stan b/code/poisson_log_glm.stan deleted file mode 100644 index e4faae41..00000000 --- a/code/poisson_log_glm.stan +++ /dev/null @@ -1,25 +0,0 @@ -data { - int k; - int n; - matrix[n, k] X; - array[n] int y; - vector[n] log_offset; -} -parameters { - vector[k] beta; - real alpha; -} -model { - target += std_normal_lpdf(beta); - target += std_normal_lpdf(alpha); - target += poisson_log_glm_lpmf(y | X, alpha + log_offset, beta); -} -generated quantities { - vector[n] log_lik; // pointwise log-likelihood for LOO - vector[n] y_rep; // replications from posterior predictive dist - for (i in 1 : n) { - real y_hat_i = alpha + X[i] * beta + log_offset[i]; - log_lik[i] = poisson_log_lpmf(y[i] | y_hat_i); - y_rep[i] = poisson_log_rng(y_hat_i); - } -} diff --git a/code/rats.bugs b/code/rats.bugs deleted file mode 100644 index 7a2048a7..00000000 --- a/code/rats.bugs +++ /dev/null @@ -1,20 +0,0 @@ -model { - alpha_c ~ dnorm(0, 1.0E-4); - beta_c ~ dnorm(0, 1.0E-4); - - tau_c ~ dgamma(0.001, 0.001); - tau_alpha ~ dgamma(0.001, 0.001); - tau_beta ~ dgamma(0.001, 0.001); - - sigma_c <- 1.0 / sqrt(tau_c); - sigma_alpha <- 1.0 / sqrt(tau_alpha); - sigma_beta <- 1.0 / sqrt(tau_beta); - - for (n in 1:N){ - alpha[n] ~ dnorm(alpha_c, tau_alpha); - beta[n] ~ dnorm(beta_c, tau_beta); - for (t in 1:T) { - y[n,t] ~ dnorm(alpha[n] + beta[n] * (x[t] - xbar), tau_c); - } - } -} diff --git a/code/rats.stan b/code/rats.stan deleted file mode 100644 index 33861a50..00000000 --- a/code/rats.stan +++ /dev/null @@ -1,43 +0,0 @@ -data { - int N; - int T; - vector[T] x; - matrix[N,T] y; - real xbar; -} -parameters { - vector[N] alpha; - vector[N] beta; - - real alpha_c; - real beta_c; // beta.c in original bugs model - - real tausq_c; - real tausq_alpha; - real tausq_beta; -} -transformed parameters { - real tau_c; // sigma in original bugs model - real tau_alpha; - real tau_beta; - - tau_c = sqrt(tausq_c); - tau_alpha = sqrt(tausq_alpha); - tau_beta = sqrt(tausq_beta); -} -model { - alpha_c ~ normal(0, 100); - beta_c ~ normal(0, 100); - tausq_c ~ inv_gamma(0.001, 0.001); - tausq_alpha ~ inv_gamma(0.001, 0.001); - tausq_beta ~ inv_gamma(0.001, 0.001); - alpha ~ normal(alpha_c, tau_alpha); // vectorized - beta ~ normal(beta_c, tau_beta); // vectorized - for (n in 1:N) - for (t in 1:T) - y[n,t] ~ normal(alpha[n] + beta[n] * (x[t] - xbar), tau_c); -} -generated quantities { - real alpha0; - alpha0 = alpha_c - xbar * beta_c; -} diff --git a/code/rcpp_eigen.cpp b/code/rcpp_eigen.cpp deleted file mode 100644 index 6f4e9cfd..00000000 --- a/code/rcpp_eigen.cpp +++ /dev/null @@ -1,19 +0,0 @@ -#include - -// [[Rcpp::depends(RcppEigen)]] - -using Eigen::Map; // 'maps' rather than copies -using Eigen::MatrixXd; // variable size matrix, double precision -using Eigen::VectorXd; // variable size vector, double precision -using Eigen::SelfAdjointEigenSolver; // one of the eigenvalue solvers - -// [[Rcpp::export]] -VectorXd getEigenValues(Map M) { - SelfAdjointEigenSolver es(M); - return es.eigenvalues(); -} -// [[Rcpp::export]] -MatrixXd getEigenVectors(Map M) { - SelfAdjointEigenSolver es(M); - return es.eigenvectors(); -} diff --git a/code/rongelap_poisson_pred.stan b/code/rongelap_poisson_pred.stan deleted file mode 100644 index 1bcd4be5..00000000 --- a/code/rongelap_poisson_pred.stan +++ /dev/null @@ -1,101 +0,0 @@ -functions { - vector gp_pred_rng(array[] vector x2, - vector lambda, - array[] vector x1, - real beta, - real sigma, - real phi, - real delta) { - int N1 = rows(lambda); - int N2 = size(x2); - vector[N2] f2; - { - matrix[N1, N1] L_K; - vector[N1] K_div_lambda; - matrix[N1, N2] k_x1_x2; - matrix[N1, N2] v_pred; - vector[N2] f2_mu; - matrix[N2, N2] cov_f2; - matrix[N2, N2] diag_delta; - matrix[N1, N1] K; - K = gp_exponential_cov(x1, sigma, phi); - L_K = cholesky_decompose(K); - K_div_lambda = mdivide_left_tri_low(L_K, lambda - beta); - K_div_lambda = mdivide_right_tri_low(K_div_lambda', L_K)'; - k_x1_x2 = gp_exponential_cov(x1, x2, sigma, phi); - f2_mu = beta + (k_x1_x2' * K_div_lambda); - v_pred = mdivide_left_tri_low(L_K, k_x1_x2); - cov_f2 = gp_exponential_cov(x2, sigma, phi) - v_pred' * v_pred; - diag_delta = diag_matrix(rep_vector(delta, N2)); - - f2 = multi_normal_rng(f2_mu, cov_f2 + diag_delta); - } - return f2; - } -} -data { - int D; - int N1; - array[N1] vector[D] x1; - array[N1] int y1; - vector[N1] offsets1; - int N2; - array[N2] vector[D] x2; - vector[N2] offsets2; -} -transformed data { - real delta = 1e-12; - vector[N1] log_offsets1 = log(offsets1); - vector[N2] log_offsets2 = log(offsets2); - - int N = N1 + N2; - array[N] vector[D] x; - - for (n1 in 1:N1) { - x[n1] = x1[n1]; - } - for (n2 in 1:N2) { - x[N1 + n2] = x2[n2]; - } -} -parameters { - real beta; - real sigma; - real phi; - vector[N1] lambda1; -} -transformed parameters { - vector[N1] mu = rep_vector(beta, N1); -} -model { - matrix[N1, N1] L_K; - { - matrix[N1, N1] K = gp_exponential_cov(x1, sigma, phi) + diag_matrix(rep_vector(delta, N1)); - L_K = cholesky_decompose(K); - } - - beta ~ std_normal(); - sigma ~ inv_gamma(5, 5); - phi ~ std_normal(); - - lambda1 ~ multi_normal_cholesky(mu, L_K); - y1 ~ poisson_log(log_offsets1 + lambda1); -} -generated quantities { - vector[N1] yhat; // Posterior predictions for each location - vector[N1] log_lik; // Log likelihood for each location - vector[N1] RR1 = log_offsets1 + lambda1; - - for(n in 1:N1) { - log_lik[n] = poisson_log_lpmf(y1[n] | RR1[n]); - yhat[n] = poisson_log_rng(RR1[n]); - } - - vector[N2] ypred; - vector[N2] lambda2 = gp_pred_rng(x2, lambda1, x1, beta, sigma, phi, delta); - vector[N2] RR2 = log_offsets2 + lambda2; - - for(n in 1:N2) { - ypred[n] = poisson_log_rng(RR2[n]); - } -} diff --git a/code/rongelap_poisson_processes.stan b/code/rongelap_poisson_processes.stan deleted file mode 100644 index 8996536f..00000000 --- a/code/rongelap_poisson_processes.stan +++ /dev/null @@ -1,34 +0,0 @@ -data { - int N; - int D; - array[N] vector[D] X; - array[N] int y; - vector[N] offsets; -} -transformed data { - real delta = 1e-12; - vector[N] log_offsets = log(offsets); -} -parameters { - real beta; - real sigma; - real phi; - vector[N] lambda; -} -transformed parameters { - vector[N] mu = rep_vector(beta, N); -} -model { - matrix[N, N] L_K; - { - matrix[N, N] K = gp_exponential_cov(X, sigma, phi) + diag_matrix(rep_vector(delta, N)); - L_K = cholesky_decompose(K); - } - - beta ~ std_normal(); - sigma ~ inv_gamma(5, 5); - phi ~ std_normal(); - - lambda ~ multi_normal_cholesky(mu, L_K); - y ~ poisson_log(log_offsets + lambda); -} diff --git a/code/stochastic_volatility_models.stan b/code/stochastic_volatility_models.stan deleted file mode 100644 index 15f8472a..00000000 --- a/code/stochastic_volatility_models.stan +++ /dev/null @@ -1,26 +0,0 @@ -data { - int T; // # time points (equally spaced) - vector[T] y; // mean corrected return at time t -} -parameters { - real mu; // mean log volatility - real phi; // persistence of volatility - real sigma; // white noise shock scale - vector[T] h_std; // std log volatility time t -} -transformed parameters { - vector[T] h = h_std * sigma; // now h ~ normal(0, sigma) - h[1] /= sqrt(1 - phi * phi); // rescale h[1] - h += mu; - for (t in 2:T) { - h[t] += phi * (h[t - 1] - mu); - } -} -model { - phi ~ uniform(-1, 1); - sigma ~ cauchy(0, 5); - mu ~ cauchy(0, 10); - - h_std ~ std_normal(); - y ~ normal(0, exp(h / 2)); -} diff --git a/data/cumcm2011A.rds b/data/cumcm2011A.rds deleted file mode 100644 index 5ddbfe14..00000000 Binary files a/data/cumcm2011A.rds and /dev/null differ diff --git a/data/gadm/gadm41_MHL_1_pk.rds b/data/gadm/gadm41_MHL_1_pk.rds deleted file mode 100644 index fd608cd6..00000000 Binary files a/data/gadm/gadm41_MHL_1_pk.rds and /dev/null differ diff --git a/data/german_credit_data.rds b/data/german_credit_data.rds deleted file mode 100644 index 69f08488..00000000 Binary files a/data/german_credit_data.rds and /dev/null differ diff --git a/data/orings.rds b/data/orings.rds deleted file mode 100644 index a87efaaa..00000000 Binary files a/data/orings.rds and /dev/null differ diff --git a/data/scotland/scotland.dbf b/data/scotland/scotland.dbf deleted file mode 100755 index 44ee8812..00000000 Binary files a/data/scotland/scotland.dbf and /dev/null differ diff --git a/data/scotland/scotland.shp b/data/scotland/scotland.shp deleted file mode 100755 index d826e4fb..00000000 Binary files a/data/scotland/scotland.shp and /dev/null differ diff --git a/data/scotland/scotland.shx b/data/scotland/scotland.shx deleted file mode 100755 index 7c787ada..00000000 Binary files a/data/scotland/scotland.shx and /dev/null differ diff --git a/gaussian-processes-regression.qmd b/gaussian-processes-regression.qmd deleted file mode 100644 index 0426c6fe..00000000 --- a/gaussian-processes-regression.qmd +++ /dev/null @@ -1,1092 +0,0 @@ -# 高斯过程回归 {#sec-bayesian-gaussian-processes} - -```{r} -#| echo: false - -Sys.setenv(CMDSTANR_NO_VER_CHECK = TRUE) -``` - -::: hidden -$$ - \def\bm#1{{\boldsymbol #1}} -$$ -::: - -本章主要内容分三大块，分别是多元正态分布、二维高斯过程和高斯过程回归。根据高斯过程的定义，我们知道多元正态分布和高斯过程有紧密的联系，首先介绍多元正态分布的定义、随机数模拟和分布拟合。二维高斯过程很有代表性，常用于空间统计中，而一维高斯过程常用于时间序列分析中，因而，介绍高斯过程的定义，二维高斯过程的模拟和参数拟合。在后续的高斯过程回归中，以朗格拉普岛的核辐射数据为例，建立泊松空间广义线性混合效应模型（响应变量非高斯的高斯过程回归模型），随机过程看作一组存在相关性的随机变量，这一组随机变量视为模型中的随机效应。 - -## 多元正态分布 {#sec-multi-normal} - -设随机向量 $\bm{X} = (X_1, X_2, \cdots, X_p)^{\top}$ 服从多元正态分布 $\mathrm{MVN}(\bm{\mu}, \Sigma)$ ，其联合密度函数如下 - -$$ -\begin{aligned} - p(\boldsymbol x) = (2\pi)^{-\frac{p}{2}} |\Sigma|^{-\frac12} - \exp\left\{ -\frac12 (\boldsymbol x - \boldsymbol \mu)^T \Sigma^{-1} (\boldsymbol x - \boldsymbol \mu) \right\}, - \ \boldsymbol x \in \mathbb{R}^p -\end{aligned} -$$ - -其中，协方差矩阵 $\Sigma$ 是正定的，其 Cholesky 分解为 $\Sigma = CC^{\top}$ ，这里 $C$ 为下三角矩阵。设 $\bm{Z} = (Z_1, Z_2, \cdots, Z_p)^{\top}$ 服从 $p$ 元标准正态分布 $\mathrm{MVN}(\bm{0}, I)$ ，则 $\bm{X} = \bm{\mu} + C\bm{Z}$ 服从多元正态分布 $\mathrm{MVN}(\bm{\mu}, \Sigma)$ 。 - -### 多元正态分布模拟 {#sec-multi-normal-simu} - -可以用 Stan 函数 `multi_normal_cholesky_rng` 生成随机数模拟多元正态分布。 - -```{verbatim, file="code/multi_normal_simu.stan", lang="stan"} -``` - -上述代码块可以同时模拟多组服从多元正态分布的随机数。其中，参数块 `parameters` 和模型块 `model` 是空白的，这是因为模拟随机数不涉及模型推断，只是采样。核心部分 `generated quantities` 代码块负责生成随机数。 - -```{r} -#| message: false - -# 给定二元正态分布的参数值 -multi_normal_d <- list( - N = 1, # 一组随机数 - D = 2, # 维度 - mu = c(3, 2), # 均值向量 - Sigma = rbind(c(4, 1), c(1, 1)) # 协方差矩阵 -) -library(cmdstanr) -# 编译多元正态分布模型 -mod_multi_normal <- cmdstan_model( - stan_file = "code/multi_normal_simu.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -``` - -抽样生成 1000 个服从二元正态分布的随机数。 - -```{r} -simu_multi_normal <- mod_multi_normal$sample( - data = multi_normal_d, - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 样本量 - chains = 1, # 马尔科夫链的数目 - parallel_chains = 1, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 1, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - fixed_param = TRUE, # 固定参数 - seed = 20232023 # 设置随机数种子，不要使用 set.seed() 函数 -) -``` - -值得注意，这里，不需要设置参数初始值，但要设置 `fixed_param = TRUE`，表示根据模型生成模拟数据。 - -```{r} -# 原始数据 -simu_multi_normal$draws(variables = "yhat", format = "array") -# 数据概览 -simu_multi_normal$summary(.num_args = list(sigfig = 4, notation = "dec")) -``` - -以生成第一个服从二元正态分布的随机数（样本点）为例，这个随机数是通过采样获得的，采样过程中产生一个采样序列，采样序列的轨迹和分布如下： - -```{r} -#| label: fig-trace-dens -#| fig-cap: 采样序列的轨迹和分布 -#| fig-width: 6 -#| fig-height: 4 -#| fig-showtext: true -#| message: false - -library(ggplot2) -library(bayesplot) -mcmc_trace(simu_multi_normal$draws(c("yhat[1,1]", "yhat[1,2]")), - facet_args = list( - labeller = ggplot2::label_parsed, strip.position = "top", ncol = 1 - ) -) + theme_bw(base_size = 12) - -mcmc_dens(simu_multi_normal$draws(c("yhat[1,1]", "yhat[1,2]")), - facet_args = list( - labeller = ggplot2::label_parsed, strip.position = "top", ncol = 1 - ) -) + theme_bw(base_size = 12) -``` - -这就是一组来自二元正态分布的随机数。 - -```{r} -#| label: fig-bivar-scatter -#| fig-cap: 生成二元正态分布的随机数 -#| fig-width: 6 -#| fig-height: 4 -#| fig-showtext: true - -mcmc_scatter(simu_multi_normal$draws(c("yhat[1,1]", "yhat[1,2]"))) + - theme_bw(base_size = 12) + - labs(x = expression(x[1]), y = expression(x[2])) -``` - -提取采样数据，整理成矩阵。 - -```{r} -# 抽取原始采样数据 -yhat <- simu_multi_normal$draws(c("yhat[1,1]", "yhat[1,2]")) -# 合并多条链 -yhat_mean <- apply(yhat, c(1, 3), mean) -# 整理成二维矩阵 -x <- as.matrix(yhat_mean) -# 样本均值 -colMeans(x) -# 样本方差-协方差矩阵 -var(x) -``` - -### 多元正态分布拟合 {#sec-multi-normal-fitted} - -一般地，协方差矩阵的 Cholesky 分解的矩阵表示如下： - -$$ -\begin{aligned} - \Sigma &= \begin{bmatrix} -\sigma^2_1 & \rho_{12}\sigma_1\sigma_2 & \rho_{13}\sigma_1\sigma_3 \\ -\rho_{12}\sigma_1\sigma_2 & \sigma_2^2 & \rho_{23}\sigma_2\sigma_3 \\ -\rho_{13}\sigma_1\sigma_3 & \rho_{23}\sigma_2\sigma_3 & \sigma_3^2 -\end{bmatrix} \\ -& = \begin{bmatrix} -\sigma_1 & 0 & 0 \\ -0 & \sigma_2 & 0 \\ -0 & 0 & \sigma_3 -\end{bmatrix} -\underbrace{ -\begin{bmatrix} -1 & \rho_{12} & \rho_{13} \\ -\rho_{12} & 1 & \rho_{23} \\ -\rho_{13} & \rho_{23} & 1 -\end{bmatrix} -}_{R} -\begin{bmatrix} -\sigma_1 & 0 & 0 \\ -0 & \sigma_2 & 0 \\ -0 & 0 & \sigma_3 -\end{bmatrix} \\ -& = \begin{bmatrix} -\sigma_1 & 0 & 0 \\ -0 & \sigma_2 & 0 \\ -0 & 0 & \sigma_3 -\end{bmatrix} -\underbrace{L_u L_u^{\top}}_{R} -\begin{bmatrix} -\sigma_1 & 0 & 0 \\ -0 & \sigma_2 & 0 \\ -0 & 0 & \sigma_3 -\end{bmatrix} -\end{aligned} -$$ - -```{verbatim, file="code/multi_normal_fitted.stan", lang="stan"} -``` - -代码中， 核心部分是关于多元正态分布的协方差矩阵的参数化，先将协方差矩阵中的方差和相关矩阵剥离，然后利用 Cholesky 分解将相关矩阵分解。在 Stan 里，这是一套高效的组合。 - -- 类型 `cholesky_factor_corr` 表示相关矩阵的 Cholesky 分解后的矩阵 $L_u$ - -- 类型 `corr_matrix` 表示相关矩阵 $R$ 。 - -- 类型 `cov_matrix` 表示协方差矩阵 $\Sigma$ 。 - -- 函数 `lkj_corr_cholesky` 为相关矩阵 Cholesky 分解后的矩阵 $L_u$ 服从的分布，详见 [Cholesky LKJ correlation distribution](https://mc-stan.org/docs/functions-reference/cholesky-lkj-correlation-distribution.html)。函数名中的 `lkj` 是以三个人的人名的首字母命名的 [Lewandowski, Kurowicka, and Joe 2009](https://mc-stan.org/docs/functions-reference/lkj-correlation.html#ref-LewandowskiKurowickaJoe:2009)。 - -- 函数 `multiply_lower_tri_self_transpose` 为下三角矩阵与它的转置的乘积，详见 [Correlation Matrix Distributions](https://mc-stan.org/docs/functions-reference/correlation-matrix-distributions.html)。 - -- 函数 `multi_normal` 为多元正态分布的抽样语句，详见 [Multivariate normal distribution](https://mc-stan.org/docs/functions-reference/multivariate-normal-distribution.html)。 - -矩阵 $L_u$ 是相关矩阵 $R$ 的 Cholesky 分解的结果，在贝叶斯框架内，参数都是随机的，相关矩阵是一个随机矩阵，矩阵 $L_u$ 是一个随机矩阵，它的分布用 Stan 代码表示为如下： - -``` stan -L ~ lkj_corr_cholesky(2.0); # implies L * L' ~ lkj_corr(2.0); -``` - -LKJ 分布有一个参数 $\eta$ ，此处 $\eta = 2$ ，意味着变量之间的相关性较弱，LKJ 分布的概率密度函数正比于相关矩阵的行列式的 $\eta-1$ 次幂 $(\det{R})^{\eta-1}$，LKJ 分布的详细说明见[Lewandowski-Kurowicka-Joe (LKJ) distribution](https://distribution-explorer.github.io/multivariate_continuous/lkj.html)。 - -有了上面的背景知识，下面先在 R 环境中模拟一组来自多元正态分布的样本。 - -```{r} -set.seed(20232023) -# 均值 -mu <- c(1, 2, -5) -# 相关矩阵 (R) -R <- matrix(c( - 1, 0.7, 0.2, - 0.7, 1, -0.5, - 0.2, -0.5, 1 -), 3) -# sd1 = 0.5, sd2 = 1.2, sd3 = 2.3 -sigmas <- c(0.5, 1.2, 2.3) -# 方差-协方差矩阵 -Sigma <- diag(sigmas) %*% R %*% diag(sigmas) -# 模拟 1000 个样本数据 -dat <- MASS::mvrnorm(1000, mu = mu, Sigma = Sigma) -``` - -根据 1000 个样本点，估计多元正态分布的均值参数和方差协方差参数。 - -```{r} -#| message: false - -# 来自多元正态分布的一组观测数据 -multi_normal_chol_d <- list( - N = 1000, # 样本量 - K = 3, # 三维 - y = dat -) -# 编译多元正态分布模型 -mod_multi_normal_chol <- cmdstan_model( - stan_file = "code/multi_normal_fitted.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -# 拟合多元正态分布模型 -fit_multi_normal <- mod_multi_normal_chol$sample( - data = multi_normal_chol_d, - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 每条链采样次数 - chains = 2, # 马尔科夫链的数目 - parallel_chains = 1, # 指定 CPU 核心数 - threads_per_chain = 1, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 # 设置随机数种子 -) -``` - -均值向量 $\bm{\mu}$ 和协方差矩阵 $\Sigma$ 估计结果如下： - -```{r} -fit_multi_normal$summary(c("mu", "Sigma"), .num_args = list(sigfig = 3, notation = "dec")) -``` - -均值向量 $\bm{\mu} = (\mu_1,\mu_2,\mu_3)^{\top}$ 各个分量及其两两相关性，如下图所示。 - -```{r} -#| label: fig-trivar-bayes -#| fig-cap: 三元正态分布 -#| fig-width: 6 -#| fig-height: 6 -#| fig-showtext: true - -mcmc_pairs( - fit_multi_normal$draws(c("mu[1]", "mu[2]", "mu[3]")), - diag_fun = "dens", off_diag_fun = "hex" -) -``` - -## 二维高斯过程 {#sec-gaussian-processes} - -高斯过程定义 - -### 二维高斯过程模拟 {#sec-gaussian-processes-simulation} - -二维高斯过程 $\mathcal{S}$ 的均值向量为 0 向量，自协方差函数为指数型，如下 - -$$ -\mathsf{Cov}\{S(x_i), S(x_j)\} = \sigma^2 \exp\big( -\frac{\|x_i -x_j\|_{2}}{\phi} \big) -$$ - -其中，不妨设参数 $\sigma = 10, \phi = 1$ 。模拟高斯过程的 Stan 代码如下 - -```{verbatim, file="code/gaussian_process_simu.stan", lang="stan"} -``` - -在二维规则网格上采样，采样点数量为 225。 - -```{r} -#| message: false - -n <- 15 -gaussian_process_d <- list( - N = n^2, - D = 2, - mu = rep(0, n^2), - sigma = 10, - phi = 1, - X = expand.grid(x1 = 1:n / n, x2 = 1:n / n) -) -# 编译二维高斯过程模型 -mod_gaussian_process_simu <- cmdstan_model( - stan_file = "code/gaussian_process_simu.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -``` - -模拟 1 个样本，因为是模拟数据，不需要设置多条链。 - -```{r} -#| message: false - -fit_multi_normal_gp <- mod_gaussian_process_simu$sample( - data = gaussian_process_d, - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 样本量 - chains = 1, # 马尔科夫链的数目 - parallel_chains = 1, # 指定 CPU 核心数 - threads_per_chain = 1, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 # 设置随机数种子 -) -``` - -位置 1 和 2 处的随机变量的迭代轨迹，均值为 0 ，标准差 10 左右。 - -```{r} -#| label: fig-location-bayes -#| fig-cap: 位置 1 和 2 处的迭代轨迹 -#| fig-showtext: true - -mcmc_trace(fit_multi_normal_gp$draws(c("y[1]", "y[2]")), - facet_args = list( - labeller = ggplot2::label_parsed, - strip.position = "top", ncol = 1 - ) -) + theme_bw(base_size = 12) -``` - -位置 1 处的随机变量及其分布 - -```{r} -y1 <- fit_multi_normal_gp$draws(c("y[1]"), format = "draws_array") -# 合并链条结果 -y1_mean <- apply(y1, c(1, 3), mean) -# y[1] 的方差 -var(y1_mean) -# y[1] 的标准差 -sd(y1_mean) -``` - -100 次迭代获得 100 个样本点，每次迭代采集一个样本点，每个样本点是一个 225 维的向量。 - -```{r} -# 抽取原始的采样数据 -y_array <- fit_multi_normal_gp$draws(variables = "y", format = "array") -# 合并链条 -y_mean <- apply(y_array, c(1, 3), mean) -``` - -从 100 次迭代中任意提取某一个样本点，比如预采样之后的第一次下迭代的结果，接着整理数据。 - -```{r} -# 整理数据 -sim_gp_data <- cbind.data.frame(gaussian_process_d$X, ysim = y_mean[1, ]) -``` - -绘制二维高斯过程图形。 - -```{r} -#| label: fig-2d-gp -#| fig-cap: 二维高斯过程 -#| fig-width: 6.5 -#| fig-height: 4 -#| fig-showtext: true - -ggplot(data = sim_gp_data, aes(x = x1, y = x2)) + - geom_point(aes(color = ysim)) + - scale_color_distiller(palette = "Spectral") + - theme_bw() + - labs(x = expression(x[1]), y = expression(x[2])) -``` - -### 二维高斯过程拟合 {#sec-gaussian-processes-fitted} - -二维高斯过程拟合代码如下 - -```{verbatim, file="code/gaussian_process_fitted.stan", lang="stan"} -``` - -```{r} -#| message: false - -# 二维高斯过程模型 -gaussian_process_d <- list( - D = 2, - N = nrow(sim_gp_data), # 观测记录的条数 - x = sim_gp_data[, c("x1", "x2")], - y = sim_gp_data[, "ysim"] -) - -nchains <- 2 -set.seed(20232023) -# 给每条链设置不同的参数初始值 -inits_gaussian_process <- lapply(1:nchains, function(i) { - list( - sigma = runif(1), phi = runif(1) - ) -}) - -# 编译模型 -mod_gaussian_process <- cmdstan_model( - stan_file = "code/gaussian_process_fitted.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) - -# 拟合二维高斯过程 -fit_gaussian_process <- mod_gaussian_process$sample( - data = gaussian_process_d, # 观测数据 - init = inits_gaussian_process, # 迭代初值 - iter_warmup = 1000, # 每条链预处理迭代次数 - iter_sampling = 2000, # 每条链总迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = 2, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 2, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 # 设置随机数种子，不要使用 set.seed() 函数 -) -# 诊断 -fit_gaussian_process$diagnostic_summary() -``` - -输出结果 - -```{r} -fit_gaussian_process$summary() -``` - -## 高斯过程回归 {#sec-gaussian-processes-regression} - -### 模型介绍 - -朗格拉普岛是位于太平洋上的一个小岛，因美国在比基尼群岛的氢弹核试验受到严重的核辐射影响，数十年之后，科学家登岛采集核辐射强度数据以评估当地居民重返该岛的可能性。朗格拉普岛是一个十分狭长且占地面积只有几平方公里的小岛。 - -根据 ${}^{137}\mathrm{Cs}$ 放出伽马射线，在 $n=157$ 个采样点，分别以时间间隔 $t_i$ 测量辐射量 $y(x_i)$，建立泊松型空间广义线性混合效应模型[@Diggle1998]。 - -$$ -\begin{aligned} -\log\{\lambda(x_i)\} & = \beta + S(x_{i})\\ -y(x_{i}) &\sim \mathrm{Poisson}\big(t_i\lambda(x_i)\big) -\end{aligned} -$$ - -其中，$\beta$ 表示截距，相当于平均水平，$\lambda(x_i)$ 表示位置 $x_i$ 处的辐射强度，$S(x_{i})$ 表示位置 $x_i$ 处的空间效应，$S(x),x \in \mathcal{D} \subset{\mathbb{R}^2}$ 是二维平稳空间高斯过程 $\mathcal{S}$ 的具体实现。 $\mathcal{D}$ 表示研究区域，可以理解为朗格拉普岛，它是二维实平面 $\mathbb{R}^2$ 的子集。 - -随机过程 $S(x)$ 的自协方差函数常用的有指数型、幂二次指数型（高斯型）和梅隆型，形式如下： - -$$ -\begin{aligned} -\mathsf{Cov}\{S(x_i), S(x_j)\} &= \sigma^2 \exp\big( -\frac{\|x_i -x_j\|_{2}}{\phi} \big) \\ -\mathsf{Cov}\{ S(x_i), S(x_j) \} &= \sigma^2 \exp\big( -\frac{\|x_i -x_j\|_{2}^{2}}{2\phi^2} \big) \\ -\mathsf{Cov}\{ S(x_i), S(x_j) \} &= \sigma^2 \frac{2^{1 - \nu}}{\Gamma(\nu)} -\left(\sqrt{2\nu}\frac{\|x_i -x_j\|_{2}}{\phi}\right)^{\nu} -K_{\nu}\left(\sqrt{2\nu}\frac{\|x_i -x_j\|_{2}}{\phi}\right) \\ -K_{\nu}(x) &= \int_{0}^{\infty}\exp(-x \cosh t) \cosh (\nu t) \mathrm{dt} -\end{aligned} -$$ - -待估参数：代表方差的 $\sigma^2$ 和代表范围的 $\phi$ 。当 $\nu = 1/2$ 时，梅隆型退化为指数型。 - -### 观测数据 - -```{r} -# 加载数据 -rongelap <- readRDS(file = "data/rongelap.rds") -rongelap_coastline <- readRDS(file = "data/rongelap_coastline.rds") -# 准备输入数据 -rongelap_poisson_d <- list( - N = nrow(rongelap), # 观测记录的条数 - D = 2, # 2 维坐标 - X = rongelap[, c("cX", "cY")] / 6000, # N x 2 矩阵 - y = rongelap$counts, # 响应变量 - offsets = rongelap$time # 漂移项 -) -# 准备参数初始化数据 -set.seed(20232023) -nchains <- 2 # 2 条迭代链 -inits_data_poisson <- lapply(1:nchains, function(i) { - list( - beta = rnorm(1), sigma = runif(1), - phi = runif(1), lambda = rnorm(157) - ) -}) -``` - -### 预测数据 - -预测未采样的位置的核辐射强度，根据海岸线数据网格化全岛，以格点代表未采样的位置 - -```{r} -#| message: false - -library(sf) -library(abind) -library(stars) -# 类型转化 -rongelap_sf <- st_as_sf(rongelap, coords = c("cX", "cY"), dim = "XY") -rongelap_coastline_sf <- st_as_sf(rongelap_coastline, coords = c("cX", "cY"), dim = "XY") -rongelap_coastline_sfp <- st_cast(st_combine(st_geometry(rongelap_coastline_sf)), "POLYGON") -# 添加缓冲区 -rongelap_coastline_buffer <- st_buffer(rongelap_coastline_sfp, dist = 50) -# 构造带边界约束的网格 -rongelap_coastline_grid <- st_make_grid(rongelap_coastline_buffer, n = c(150, 75)) -# 将 sfc 类型转化为 sf 类型 -rongelap_coastline_grid <- st_as_sf(rongelap_coastline_grid) -rongelap_coastline_buffer <- st_as_sf(rongelap_coastline_buffer) -rongelap_grid <- rongelap_coastline_grid[rongelap_coastline_buffer, op = st_intersects] -# 计算网格中心点坐标 -rongelap_grid_centroid <- st_centroid(rongelap_grid) -# 共计 1612 个预测点 -rongelap_grid_df <- as.data.frame(st_coordinates(rongelap_grid_centroid)) -colnames(rongelap_grid_df) <- c("cX", "cY") -``` - -未采样的位置 `rongelap_grid_df` - -```{r} -head(rongelap_grid_df) -``` - -朗格拉普岛网格化生成格点 - -```{r} -#| label: fig-rongelap-grid -#| fig-cap: 朗格拉普岛 -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true - -ggplot() + - geom_point(data = rongelap_grid_df, aes(x = cX, y = cY), cex = 0.3) + - geom_path(data = rongelap_coastline, aes(x = cX, y = cY)) + - coord_fixed() + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）") -``` - -### 模型编码 - -指定各个参数 $\beta,\sigma,\phi$ 的先验分布 - -$$ -\begin{aligned} -\beta &\sim \mathrm{std\_normal}(0,1) \\ -\sigma &\sim \mathrm{inv\_gamma}(5,5) \\ -\phi &\sim \mathrm{half\_std\_normal}(0,1) \\ -\bm{\lambda} | \beta,\sigma &\sim \mathrm{multivariate\_normal}(\bm{\beta}, \sigma^2 \Sigma) \\ -\bm{y} | \bm{\lambda} &\sim \mathrm{poisson\_log}\big(\log(\text{offsets})+\bm{\lambda}\big) -\end{aligned} -$$ - -其中，$\beta,\sigma,\phi,\Sigma$ 的含义同前，$\lambda$ 代表辐射强度，$\mathrm{offsets}$ 代表漂移项，这里是时间段，$\bm{y}$ 表示观测的辐射粒子数，$\mathrm{poisson\_log}$ 表示泊松分布的对数参数化，将频率参数 rate 的对数 $\lambda$ 作为参数，详见 Stan 函数手册中泊松分布的[对数函数表示](https://mc-stan.org/docs/functions-reference/poisson-distribution-log-parameterization.html)。 - -```{verbatim, file="code/rongelap_poisson_processes.stan", lang="stan"} -``` - -```{r} -#| message: false - -# 编译模型 -mod_rongelap_poisson <- cmdstan_model( - stan_file = "code/rongelap_poisson_processes.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -# 泊松对数模型 -fit_rongelap_poisson <- mod_rongelap_poisson$sample( - data = rongelap_poisson_d, # 观测数据 - init = inits_data_poisson, # 迭代初值 - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 每条链总迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = 2, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 2, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 -) -# 诊断 -fit_rongelap_poisson$diagnostic_summary() -``` - -```{r} -# 泊松对数模型 -fit_rongelap_poisson$summary( - variables = c("lp__", "beta", "sigma", "phi"), - .num_args = list(sigfig = 3, notation = "dec") -) -``` - -```{r} -#| label: fig-rongelap-poisson-trace -#| fig-cap: $\sigma$ 和 $\phi$ 的迭代轨迹 -#| fig-showtext: true - -# 参数的迭代轨迹 -mcmc_trace( - fit_rongelap_poisson$draws(c("sigma", "phi")), - facet_args = list( - labeller = ggplot2::label_parsed, strip.position = "top", ncol = 1 - ) -) + theme_bw(base_size = 12) -``` - -```{r} -#| label: fig-rongelap-poisson-dens -#| fig-cap: $\sigma$ 和 $\phi$ 的后验分布 -#| fig-showtext: true - -# 参数的后验分布 -mcmc_dens( - fit_rongelap_poisson$draws(c("sigma", "phi")), - facet_args = list( - labeller = ggplot2::label_parsed, strip.position = "top", ncol = 1 - ) -) + theme_bw(base_size = 12) -``` - -### 预测分布 - -核辐射预测模型的 Stan 代码 - -```{verbatim, file="code/rongelap_poisson_pred.stan", lang="stan"} -``` - -准备数据、拟合模型 - -```{r} -#| message: false - -# 固定漂移项 -rongelap_grid_df$time <- 100 -# 对数高斯模型 -rongelap_poisson_pred_d <- list( - D = 2, - N1 = nrow(rongelap), # 观测记录的条数 - x1 = rongelap[, c("cX", "cY")] / 6000, - y1 = rongelap[, "counts"], - offsets1 = rongelap[, "time"], - N2 = nrow(rongelap_grid_df), # 2 维坐标 - x2 = rongelap_grid_df[, c("cX", "cY")] / 6000, - offsets2 = rongelap_grid_df[, "time"] -) -# 迭代链数目 -nchains <- 2 -# 给每条链设置不同的参数初始值 -inits_data_poisson_pred <- lapply(1:nchains, function(i) { - list( - beta = rnorm(1), sigma = runif(1), - phi = runif(1), lambda = rnorm(157) - ) -}) -# 编译模型 -mod_rongelap_poisson_pred <- cmdstan_model( - stan_file = "code/rongelap_poisson_pred.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -# 泊松模型 -fit_rongelap_poisson_pred <- mod_rongelap_poisson_pred$sample( - data = rongelap_poisson_pred_d, # 观测数据 - init = inits_data_poisson_pred, # 迭代初值 - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 每条链总迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = 2, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 2, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 # 设置随机数种子，不要使用 set.seed() 函数 -) -# 诊断信息 -fit_rongelap_poisson_pred$diagnostic_summary() -``` - -参数的后验估计 - -```{r} -fit_rongelap_poisson_pred$summary(variables = c("beta", "sigma", "phi")) -``` - -模型评估 LOO-CV - -```{r} -fit_rongelap_poisson_pred$loo(variables = "log_lik", cores = 2) -``` - -检查辐射强度分布的拟合效果 - -```{r} -#| label: fig-rongelap-poisson-ppcheck -#| fig-cap: 后验预测诊断图（密度图） -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 3.5 - -# 抽取 yrep 数据 -yrep <- fit_rongelap_poisson_pred$draws(variables = "yhat", format = "draws_matrix") -# Posterior predictive checks -pp_check(rongelap$counts / rongelap$time, - yrep = sweep(yrep[1:50, ], MARGIN = 2, STATS = rongelap$time, FUN = `/`), - fun = ppc_dens_overlay -) + - theme_classic() -``` - -后 1000 次迭代是平稳的，可取任意一个链条的任意一次迭代，获得采样点处的预测值 - -```{r} -yhat_array <- fit_rongelap_poisson_pred$draws(variables = "yhat", format = "array") -lambda1_array <- fit_rongelap_poisson_pred$draws(variables = "lambda1", format = "array") -rongelap_sf$lambda <- as.vector(lambda1_array[1,1,]) -rongelap_sf$yhat <- as.vector(yhat_array[1,1,]) -``` - -数据集 `rongelap_sf` 的概况 - -```{r} -rongelap_sf -``` - -观测值和预测值的情况 - -```{r} -summary(rongelap_sf$counts / rongelap_sf$time) -summary(rongelap_sf$yhat / rongelap_sf$time) -``` - -展示采样点处的预测值 - -```{r} -#| label: fig-rongelap-poisson-fitted -#| fig-cap: 朗格拉普岛核辐射强度的分布 -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true -#| echo: !expr knitr::is_html_output() -#| code-fold: true - -ggplot(data = rongelap_sf)+ - geom_sf(aes(color = yhat / time), cex = 0.5) + - scale_colour_viridis_c(option = "C", breaks = 3*0:5, - guide = guide_colourbar( - barwidth = 15, barheight = 1.5, - title.position = "top" # 图例标题位于图例上方 - )) + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", colour = "辐射强度") + - theme( - legend.position = "inside", - legend.position.inside = c(0.75, 0.1), - legend.direction = "horizontal", - legend.background = element_blank() - ) -``` - -未采样点的预测 - -```{r} -# 后验估计 -ypred_tbl <- fit_rongelap_poisson_pred$summary(variables = "ypred", "mean") -rongelap_grid_df$ypred <- ypred_tbl$mean -# 查看预测结果 -head(rongelap_grid_df) -# 预测值的分布范围 -summary(rongelap_grid_df$ypred / rongelap_grid_df$time) -``` - -转化数据类型，去掉缓冲区内的预测位置，准备绘制辐射强度预测值的分布 - -```{r} -rongelap_grid_sf <- st_as_sf(rongelap_grid_df, coords = c("cX", "cY"), dim = "XY") -rongelap_grid_stars <- st_rasterize(rongelap_grid_sf, nx = 150, ny = 75) -rongelap_stars <- st_crop(x = rongelap_grid_stars, y = rongelap_coastline_sfp) -``` - -```{r} -#| label: fig-rongelap-poisson-pred -#| fig-cap: 朗格拉普岛核辐射强度的分布 -#| fig-width: 7.5 -#| fig-height: 4.5 -#| fig-showtext: true -#| echo: !expr knitr::is_html_output() -#| code-fold: true - -# 虚线框数据 -dash_sfp <- st_polygon(x = list(rbind( - c(-6000, -3600), - c(-6000, -2600), - c(-5000, -2600), - c(-5000, -3600), - c(-6000, -3600) -)), dim = "XY") -# 主体内容 -p3 <- ggplot() + - geom_stars( - data = rongelap_stars, na.action = na.omit, - aes(fill = ypred / time) - ) + - # 海岸线 - geom_sf( - data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.5 - ) + - # 图例 - scale_fill_viridis_c( - option = "C", breaks = 0:13, - guide = guide_colourbar( - barwidth = 15, barheight = 1.5, - title.position = "top" # 图例标题位于图例上方 - ) - ) + - # 虚线框 - geom_sf(data = dash_sfp, fill = NA, linewidth = 0.75, lty = 2) + - # 箭头 - geom_segment( - data = data.frame(x = -5500, xend = -5000, y = -2600, yend = -2250), - aes(x = x, y = y, xend = xend, yend = yend), - arrow = arrow(length = unit(0.03, "npc")) - ) + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", fill = "辐射强度") + - theme( - legend.position = "inside", - legend.position.inside = c(0.75, 0.1), - legend.direction = "horizontal", - legend.background = element_blank() - ) - -p4 <- ggplot() + - geom_stars( - data = rongelap_stars, na.action = na.omit, - aes(fill = ypred / time), show.legend = FALSE - ) + - geom_sf( - data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.75 - ) + - scale_fill_viridis_c(option = "C", breaks = 0:13) + - # 虚线框 - geom_sf(data = dash_sfp, fill = NA, linewidth = 0.75, lty = 2) + - theme_void() + - coord_sf(expand = FALSE, xlim = c(-6000, -5000), ylim = c(-3600, -2600)) -# 叠加图形 -p3 -print(p4, vp = grid::viewport(x = .3, y = .65, width = .45, height = .45)) -``` - -## 总结 {#sec-gaussian-processes-summary} - -从模型是否含有块金效应、不同的自相关函数和参数估计方法等方面比较。 - -```{r} -library(nlme) -# 高斯分布、指数型自相关结构 -fit_exp_reml <- gls(log(counts / time) ~ 1, - correlation = corExp(value = 200, form = ~ cX + cY, nugget = FALSE), - data = rongelap, method = "REML" -) -fit_exp_ml <- gls(log(counts / time) ~ 1, - correlation = corExp(value = 200, form = ~ cX + cY, nugget = FALSE), - data = rongelap, method = "ML" -) -fit_exp_reml_nugget <- gls(log(counts / time) ~ 1, - correlation = corExp(value = c(200, 0.1), form = ~ cX + cY, nugget = TRUE), - data = rongelap, method = "REML" -) -fit_exp_ml_nugget <- gls(log(counts / time) ~ 1, - correlation = corExp(value = c(200, 0.1), form = ~ cX + cY, nugget = TRUE), - data = rongelap, method = "ML" -) - -# 高斯分布、高斯型自相关结构 -fit_gaus_reml <- gls(log(counts / time) ~ 1, - correlation = corGaus(value = 200, form = ~ cX + cY, nugget = FALSE), - data = rongelap, method = "REML" -) -fit_gaus_ml <- gls(log(counts / time) ~ 1, - correlation = corGaus(value = 200, form = ~ cX + cY, nugget = FALSE), - data = rongelap, method = "ML" -) -fit_gaus_reml_nugget <- gls(log(counts / time) ~ 1, - correlation = corGaus(value = c(200, 0.1), form = ~ cX + cY, nugget = TRUE), - data = rongelap, method = "REML" -) -fit_gaus_ml_nugget <- gls(log(counts / time) ~ 1, - correlation = corGaus(value = c(200, 0.1), form = ~ cX + cY, nugget = TRUE), - data = rongelap, method = "ML" -) -``` - -汇总结果见下表。 - -```{r} -#| label: tbl-gls-summary -#| tbl-cap: 不同模型与参数估计方法的比较 -#| echo: false - -dat <- tibble::tribble( - ~response, ~corr, ~nugget, ~method, ~beta, ~sigmasq, ~phi, ~loglik, - "高斯分布", "指数型", "无", "REML", "1.826", "0.3172", "110.8", "-89.07", - "高斯分布", "指数型", "无", "ML", "1.828", "0.3064", "105.4", "-87.56", - "高斯分布", "指数型", "0.03598", "REML", "1.813", "0.2935", "169.7472", "-88.22", - "高斯分布", "指数型", "0.03312", "ML", "1.828", "0.2779", "150.1324", "-86.88", - "高斯分布", "高斯型", "无", "REML", "1.878", "0.2523", "41.96", "-100.7", - "高斯分布", "高斯型", "无", "ML", "1.879", "0.25", "41.81", "-98.62", - "高斯分布", "高斯型", "0.07055", "REML", "1.831", "0.2532", "139.1431", "-84.91", - "高斯分布", "高斯型", "0.07053", "ML", "1.832", "0.2459", "137.0980", "-83.32" -) - -knitr::kable(dat, col.names = c( - "响应变量分布", "空间自相关结构", "块金效应", "估计方法", - "$\\beta$", "$\\sigma^2$", "$\\phi$", "对数似然值" - ), escape = FALSE) -``` - -相比于其他参数，REML 和 ML 估计方法对参数 $\phi$ 影响很大，ML 估计的 $\phi$ 和对数似然函数值更大。高斯型自相关结构中，REML 和 ML 估计方法对参数 $\phi$ 的估计结果差不多。函数 `gls()` 对初值要求不高，以上初值选取比较随意，只是符合要求函数定义。 - -对普通用户来说，想要流畅地使用 Stan 框架，需要面对很多挑战。 - -1. 软件安装和配置过程复杂。**rstan** 包内置的 Stan 版本常低于最新发布的 Stan 版本。 -2. 编译和运行模型的参数控制选项很多。编译模型，OpenCL 和多线程支持，HMC（NUTS）、L-BFGS 和 VI 三大推理算法的参数设置 -3. 模型参数先验分布设置技巧高。模型参数的先验对数据的依赖非常高，仅对线性和广义线性模型依赖较小。即使是面对模拟的简单广义线性混合效应模型，抽样过程也发散严重。 -4. 面对大规模数据扩展困难。以朗格拉普岛的核污染预测任务为例，处理 157 维的积分显得吃力，对 1600 个参数的后验分布模拟和推断低效。 - -2020 年 Stan 大会 Wade Brorsen 介绍采用 Stan 实现的贝叶斯克里金（Kriging）平滑算法估计和预测各郡县的作物产量。Stan 实现的贝叶斯空间分层正态模型，回归参数随空间区域位置变化，参数的先验分布与空间区域相关，引入大量带超参数的先验分布，运行效率不高，跑模型花费很多时间。假定所有的参数随空间位置变化，模型参数个数瞬间爆炸，跑模型花费 31 天 [@Niyizibi2018]。 - -Stan 总有些优势吧！ - -- Stan 非常灵活。Stan 同时是一门概率编程语言，只要统计模型可以被 Stan 编码，理论上就可以编译、运行、获得结果。 -- Stan 功能很多。Stan 还可以解刚性的常微分方程、积分方程等。 非常灵活，非常适合学术研究工作者，计算层面，可以方便地在前人的工作上扩展。 -- Stan 文档很全。[函数手册](https://mc-stan.org/docs/functions-reference) 提供 Stan 内建的各类函数说明。[编程手册](https://mc-stan.org/docs/reference-manual/) 提供 Stan 编程语法、程序块的说明，教用户如何使用 Stan 写代码。[用户手册](https://mc-stan.org/docs/stan-users-guide) 提供 Stan 支持的各类统计模型、代数和微分方程的使用示例。 - -## 习题 {#sec-gaussian-processes-exercise} - -1. 对核辐射污染数据，建立对数高斯过程模型，用 Stan 编码模型，预测全岛的核辐射强度分布。 - - $$ - \begin{aligned} - \beta &\sim \mathrm{std\_normal}(0,1) \\ - \sigma &\sim \mathrm{inv\_gamma}(5,5) \\ - \phi &\sim \mathrm{half\_std\_normal}(0,1) \\ - \tau &\sim \mathrm{half\_std\_normal}(0,1) \\ - \bm{y} &\sim \mathrm{multivariate\_normal}(\bm{\beta}, \sigma^2 \Sigma+ \tau^2 I) - \end{aligned} - $$ - - 其中，$\beta$ 代表截距，先验分布为标准正态分布，$\sigma$ 代表高斯过程的方差参数（信号），先验分布为逆伽马分布，$\phi$ 代表高斯过程的范围参数，先验分布为半标准正态分布，$y$ 代表辐射强度的对数，给定参数和数据的条件分布为多元正态分布，$\Sigma$ 代表协方差矩阵，$I$ 代表与采样点数量相同的单位矩阵， $\tau^2$ 是块金效应。 - - ```{verbatim, file="code/gaussian_process_pred.stan", lang="stan"} - ``` - - 代码中，`gp_exponential_cov` 表示空间相关性结构选择了指数型，详见 Stan 函数手册中的[指数型核函数表示](https://mc-stan.org/docs/functions-reference/gaussian-process-covariance-functions.html#exponential-kernel)。`cholesky_decompose` 表示对协方差矩阵做 Cholesky 分解，分解出来的下三角矩阵作为多元正态分布的参数，详见 Stan 函数手册中的 [Cholesky 分解](https://mc-stan.org/docs/functions-reference/linear-algebra-functions-and-solvers.html#cholesky-decomposition)。 `multi_normal_cholesky` 表示基于 Cholesky 分解的多元正态分布。详见 Stan 函数手册中的多元正态分布的 [Cholesky](https://mc-stan.org/docs/functions-reference/multi-normal-cholesky-fun.html) 参数化表示。 - - ```{r} - #| eval: false - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - set.seed(20232023) - nchains <- 2 # 2 条迭代链 - # 给每条链设置不同的参数初始值 - inits_data_gaussian <- lapply(1:nchains, function(i) { - list( - beta = rnorm(1), sigma = runif(1), - phi = runif(1), tau = runif(1) - ) - }) - - # 对数高斯模型 - rongelap_gaussian_d <- list( - N1 = nrow(rongelap), # 观测记录的条数 - N2 = nrow(rongelap_grid_df), - D = 2, # 2 维坐标 - x1 = rongelap[, c("cX", "cY")] / 6000, # N x 2 坐标矩阵 - x2 = rongelap_grid_df[, c("cX", "cY")] / 6000, - y1 = log(rongelap$counts / rongelap$time) # N 向量 - ) - # 编码 - mod_rongelap_gaussian <- cmdstan_model( - stan_file = "code/gaussian_process_pred.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) - ) - - # 对数高斯模型 - fit_rongelap_gaussian <- mod_rongelap_gaussian$sample( - data = rongelap_gaussian_d, # 观测数据 - init = inits_data_gaussian, # 迭代初值 - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 每条链总迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = 2, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 1, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 # 设置随机数种子，不要使用 set.seed() 函数 - ) - - # 诊断 - fit_rongelap_gaussian$diagnostic_summary() - # 对数高斯模型 - fit_rongelap_gaussian$summary( - variables = c("lp__", "beta", "sigma", "phi", "tau"), - .num_args = list(sigfig = 4, notation = "dec") - ) - - # 未采样的位置的核辐射强度预测值 - ypred <- fit_rongelap_gaussian$summary(variables = "ypred", "mean") - # 预测值 - rongelap_grid_df$ypred <- exp(ypred$mean) - # 整理数据 - rongelap_grid_sf <- st_as_sf(rongelap_grid_df, coords = c("cX", "cY"), dim = "XY") - rongelap_grid_stars <- st_rasterize(rongelap_grid_sf, nx = 150, ny = 75) - rongelap_stars <- st_crop(x = rongelap_grid_stars, y = rongelap_coastline_sfp) - - # 虚线框数据 - dash_sfp <- st_polygon(x = list(rbind( - c(-6000, -3600), - c(-6000, -2600), - c(-5000, -2600), - c(-5000, -3600), - c(-6000, -3600) - )), dim = "XY") - # 主体内容 - p3 <- ggplot() + - geom_stars( - data = rongelap_stars, aes(fill = ypred), na.action = na.omit - ) + - # 海岸线 - geom_sf( - data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.5 - ) + - # 图例 - scale_fill_viridis_c( - option = "C", breaks = 0:12, - guide = guide_colourbar( - barwidth = 15, barheight = 1.5, - title.position = "top" # 图例标题位于图例上方 - ) - ) + - # 虚线框 - geom_sf(data = dash_sfp, fill = NA, linewidth = 0.75, lty = 2) + - # 箭头 - geom_segment( - data = data.frame(x = -5500, xend = -5000, y = -2600, yend = -2250), - aes(x = x, y = y, xend = xend, yend = yend), - arrow = arrow(length = unit(0.03, "npc")) - ) + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", fill = "辐射强度") + - theme( - legend.position = "inside", - legend.position.inside = c(0.75, 0.1), - legend.direction = "horizontal", - legend.background = element_blank() - ) - - p4 <- ggplot() + - geom_stars( - data = rongelap_stars, na.action = na.omit, - aes(fill = ypred), show.legend = FALSE - ) + - geom_sf( - data = rongelap_coastline_sfp, - fill = NA, color = "gray30", linewidth = 0.75 - ) + - scale_fill_viridis_c(option = "C", breaks = 0:12) + - # 虚线框 - geom_sf(data = dash_sfp, fill = NA, linewidth = 0.75, lty = 2) + - theme_void() + - coord_sf(expand = FALSE, xlim = c(-6000, -5000), ylim = c(-3600, -2600)) - # 叠加图形 - p3 - print(p4, vp = grid::viewport(x = .3, y = .65, width = .45, height = .45)) - ``` diff --git a/generalized-additive-models.qmd b/generalized-additive-models.qmd deleted file mode 100644 index fba32cd3..00000000 --- a/generalized-additive-models.qmd +++ /dev/null @@ -1,798 +0,0 @@ -# 广义可加模型 {#sec-generalized-additive-models} - -```{r} -#| echo: false - -source("_common.R") -``` - -```{r} -#| message: false - -library(mgcv) # 广义可加模型 -library(splines) # 样条 -library(cmdstanr) # 编译采样 -library(ggplot2) # 作图 -library(bayesplot) # 后验分布 -library(loo) # LOO-CV -library(INLA) # 近似贝叶斯推断 -options(mc.cores = 2) # 全局设置双核 -``` - -相比于广义线性模型，广义可加模型可以看作是一种非线性模型，模型中含有非线性的成分。 - -::: callout-note -- 多元适应性（自适应）回归样条 multivariate adaptive regression splines -- Friedman, Jerome H. 1991. Multivariate Adaptive Regression Splines. The Annals of Statistics. 19(1):1--67. -- earth: Multivariate Adaptive Regression Splines -- Friedman, Jerome H. 2001. Greedy function approximation: A gradient boosting machine. The Annals of Statistics. 29(5):1189--1232. -- Friedman, Jerome H., Trevor Hastie and Robert Tibshirani. Additive Logistic Regression: A Statistical View of Boosting. The Annals of Statistics. 28(2): 337--374. -- [Flexible Modeling of Alzheimer's Disease Progression with I-Splines](https://github.com/pourzanj/Stancon2018_Alzheimers) [PDF 文档](https://cse.cs.ucsb.edu/sites/default/files/publications/stancon_alzheimers.pdf) -- [Implementation of B-Splines in Stan](https://github.com/milkha/Splines_in_Stan) [网页文档](https://mc-stan.org/users/documentation/case-studies/splines_in_stan.html) -::: - -## 案例：模拟摩托车事故 {#sec-mcycle-gam} - -### mgcv - -**MASS** 包的 mcycle 数据集 - -```{r} -data(mcycle, package = "MASS") -str(mcycle) -``` - -```{r} -#| label: fig-mcycle -#| fig-width: 5 -#| fig-height: 4 -#| fig-cap: mcycle 数据集 -#| fig-showtext: true - -library(ggplot2) -ggplot(data = mcycle, aes(x = times, y = accel)) + - geom_point() + - theme_classic() + - labs(x = "时间（ms）", y = "加速度（g）") -``` - -样条回归 - -```{r} -#| message: false - -library(mgcv) -mcycle_mgcv <- gam(accel ~ s(times), data = mcycle, method = "REML") -summary(mcycle_mgcv) -``` - -方差成分 - -```{r} -gam.vcomp(mcycle_mgcv, rescale = FALSE) -``` - -```{r} -#| label: fig-mcycle-viz -#| fig-width: 5 -#| fig-height: 4 -#| fig-cap: mcycle 数据集 -#| fig-showtext: true -#| par: true - -plot(mcycle_mgcv) -``` - -**ggplot2** 包的平滑图层函数 `geom_smooth()` 集成了 **mgcv** 包的函数 `gam()` 的功能。 - -```{r} -#| label: fig-mcycle-ggplot2 -#| fig-cap: ggplot2 平滑 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 - -library(ggplot2) -ggplot(data = mcycle, aes(x = times, y = accel)) + - geom_point() + - geom_smooth(method = "gam", formula = y ~ s(x, bs = "tp"), method.args = list(method = "REML")) -``` - -### cmdstanr - -```{r} -#| message: false - -library(cmdstanr) -``` - -### rstanarm - -rstanarm 可以拟合一般的广义可加（混合）模型。 - -```{r} -#| eval: false -#| echo: true - -library(rstanarm) -mcycle_rstanarm <- stan_gamm4(accel ~ s(times), - data = mcycle, family = gaussian(), cores = 2, seed = 20232023, - iter = 4000, warmup = 1000, thin = 10, refresh = 0, - adapt_delta = 0.99 -) -summary(mcycle_rstanarm) -``` - -``` -Model Info: - function: stan_gamm4 - family: gaussian [identity] - formula: accel ~ s(times) - algorithm: sampling - sample: 1200 (posterior sample size) - priors: see help('prior_summary') - observations: 133 - -Estimates: - mean sd 10% 50% 90% -(Intercept) -25.6 2.1 -28.4 -25.5 -23.0 -s(times).1 340.4 232.9 61.1 340.8 634.7 -s(times).2 -1218.9 243.3 -1529.2 -1218.8 -913.5 -s(times).3 -567.8 147.0 -765.2 -567.1 -385.3 -s(times).4 -619.8 133.8 -791.1 -617.0 -458.9 -s(times).5 -1056.2 85.8 -1162.8 -1055.7 -945.1 -s(times).6 -89.2 49.8 -154.4 -89.4 -27.6 -s(times).7 -232.2 33.8 -274.7 -232.2 -189.5 -s(times).8 17.3 105.8 -121.0 15.5 150.1 -s(times).9 4.1 33.1 -25.8 1.0 39.1 -sigma 24.7 1.6 22.6 24.6 26.8 -smooth_sd[s(times)1] 399.9 59.2 327.6 395.4 479.1 -smooth_sd[s(times)2] 25.2 25.4 2.9 17.5 56.6 - -Fit Diagnostics: - mean sd 10% 50% 90% -mean_PPD -25.5 3.0 -29.3 -25.5 -21.8 - -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.1 1.0 1052 -s(times).1 7.0 1.0 1103 -s(times).2 6.7 1.0 1329 -s(times).3 4.4 1.0 1101 -s(times).4 3.8 1.0 1230 -s(times).5 2.5 1.0 1137 -s(times).6 1.5 1.0 1128 -s(times).7 1.0 1.0 1062 -s(times).8 3.1 1.0 1147 -s(times).9 1.0 1.0 1052 -sigma 0.0 1.0 1154 -smooth_sd[s(times)1] 1.8 1.0 1136 -smooth_sd[s(times)2] 0.7 1.0 1157 -mean_PPD 0.1 1.0 997 -log-posterior 0.1 1.0 1122 - -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). -``` - -计算 LOO 值 - -```{r} -#| eval: false -#| echo: true - -loo(mcycle_rstanarm) -``` - -``` -Computed from 1200 by 133 log-likelihood matrix - - Estimate SE -elpd_loo -611.0 8.8 -p_loo 7.3 1.2 -looic 1222.0 17.5 ------- -Monte Carlo SE of elpd_loo is 0.1. - -All Pareto k estimates are good (k < 0.5). -See help('pareto-k-diagnostic') for details. -``` - -```{r} -#| eval: false -#| echo: true - -plot_nonlinear(mcycle_rstanarm) -pp_check(mcycle_rstanarm) -``` - -### brms - -另一个综合型的贝叶斯分析扩展包是 brms 包 - -```{r} -# 拟合模型 -mcycle_brms <- brms::brm(accel ~ s(times), - data = mcycle, family = gaussian(), cores = 2, seed = 20232023, - iter = 4000, warmup = 1000, thin = 10, refresh = 0, silent = 2, - control = list(adapt_delta = 0.99) -) -# 模型输出 -summary(mcycle_brms) -``` - -固定效应 - -```{r} -brms::fixef(mcycle_brms) -``` - -LOO 值与 rstanarm 包计算的值很接近。 - -```{r} -brms::loo(mcycle_brms) -``` - -模型中样条平滑的效应 - -```{r} -#| label: fig-mcycle-smooths -#| fig-cap: 后验预测分布检查 -#| fig-subcap: -#| - 样条平滑效应 -#| - 后验预测分布 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| layout-ncol: 2 - -plot(brms::conditional_smooths(mcycle_brms)) -brms::pp_check(mcycle_brms, ndraws = 50) -``` - -### GINLA - -mgcv 包的简化版 INLA 算法用于贝叶斯计算 - -```{r} -library(mgcv) -mcycle_mgcv <- gam(accel ~ s(times), data = mcycle, fit = FALSE) -# 简化版 INLA -mcycle_ginla <- ginla(G = mcycle_mgcv) -str(mcycle_ginla) -``` - -提取最大后验估计 - -```{r} -idx <- apply(mcycle_ginla$density, 1, function(x) x == max(x)) -mcycle_ginla$beta[t(idx)] -``` - -### INLA - -```{r} -#| eval: false - -library(INLA) -library(splines) -``` - -## 案例：朗格拉普岛核污染 {#sec-rongelap-gamm} - -从线性到可加，意味着从线性到非线性，可加模型容纳非线性的成分，比如高斯过程、样条。 - -### mgcv {#sec-rongelap-mgcv} - -本节复用 @sec-nuclear-pollution-concentration 朗格拉普岛核污染数据，相关背景不再赘述，下面首先加载数据到 R 环境。 - -```{r} -# 加载数据 -rongelap <- readRDS(file = "data/rongelap.rds") -rongelap_coastline <- readRDS(file = "data/rongelap_coastline.rds") -``` - -接着，将岛上各采样点的辐射强度展示出来，算是简单回顾一下数据概况。 - -```{r} -#| label: fig-rongelap-scatter3d -#| fig-cap: "岛上各采样点的辐射强度" -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 5 -#| code-fold: true -#| echo: !expr knitr::is_html_output() -#| warning: false - -library(plot3D) -with(rongelap, { - opar <- par(mar = c(.1, 2.5, .1, .1), no.readonly = TRUE) - rongelap_coastline$cZ <- 0 - scatter3D( - x = cX, y = cY, z = counts / time, - xlim = c(-6500, 50), ylim = c(-3800, 110), - xlab = "\n横坐标（米）", ylab = "\n纵坐标（米）", - zlab = "\n辐射强度", lwd = 0.5, cex = 0.8, - pch = 16, type = "h", ticktype = "detailed", - phi = 40, theta = -30, r = 50, d = 1, - expand = 0.5, box = TRUE, bty = "b", - colkey = F, col = "black", - panel.first = function(trans) { - XY <- trans3D( - x = rongelap_coastline$cX, - y = rongelap_coastline$cY, - z = rongelap_coastline$cZ, - pmat = trans - ) - lines(XY, col = "gray50", lwd = 2) - } - ) - rongelap_coastline$cZ <- NULL - on.exit(par(opar), add = TRUE) -}) -``` - -在这里，从广义可加混合效应模型的角度来对核污染数据建模，空间效应仍然是用高斯过程来表示，响应变量服从带漂移项的泊松分布。采用 mgcv 包 [@Wood2004] 的函数 `gam()` 拟合模型，其中，含 49 个参数的样条近似高斯过程，高斯过程的核函数为默认的梅隆型。更多详情见 **mgcv** 包的函数 `s()` 帮助文档参数的说明，默认值是梅隆型相关函数及默认的范围参数，作者自己定义了一套符号约定。 - -```{r} -library(nlme) -library(mgcv) -fit_rongelap_gam <- gam( - counts ~ s(cX, cY, bs = "gp", k = 50), offset = log(time), - data = rongelap, family = poisson(link = "log") -) -# 模型输出 -summary(fit_rongelap_gam) -# 随机效应 -gam.vcomp(fit_rongelap_gam) -``` - -值得一提的是核函数的类型和默认参数的选择，参数 m 接受一个向量， `m[1]` 取值为 1 至 5，分别代表球型 spherical, 幂指数 power exponential 和梅隆型 Matern with $\kappa$ = 1.5, 2.5 or 3.5 等 5 种相关/核函数。 - -```{r} -#| eval: false - -# 球型相关函数及范围参数为 0.5 -fit_rongelap_gam <- gam( - counts ~ s(cX, cY, bs = "gp", k = 50, m = c(1, .5)), - offset = log(time), data = rongelap, family = poisson(link = "log") -) -``` - -接下来，基于岛屿的海岸线数据划分出网格，将格点作为新的预测位置。 - -```{r} -library(sf) -library(abind) -library(stars) -# 类型转化 -rongelap_sf <- st_as_sf(rongelap, coords = c("cX", "cY"), dim = "XY") -rongelap_coastline_sf <- st_as_sf(rongelap_coastline, coords = c("cX", "cY"), dim = "XY") -rongelap_coastline_sfp <- st_cast(st_combine(st_geometry(rongelap_coastline_sf)), "POLYGON") -# 添加缓冲区 -rongelap_coastline_buffer <- st_buffer(rongelap_coastline_sfp, dist = 50) -# 构造带边界约束的网格 -rongelap_coastline_grid <- st_make_grid(rongelap_coastline_buffer, n = c(150, 75)) -# 将 sfc 类型转化为 sf 类型 -rongelap_coastline_grid <- st_as_sf(rongelap_coastline_grid) -rongelap_coastline_buffer <- st_as_sf(rongelap_coastline_buffer) -rongelap_grid <- rongelap_coastline_grid[rongelap_coastline_buffer, op = st_intersects] -# 计算网格中心点坐标 -rongelap_grid_centroid <- st_centroid(rongelap_grid) -# 共计 1612 个预测点 -rongelap_grid_df <- as.data.frame(st_coordinates(rongelap_grid_centroid)) -colnames(rongelap_grid_df) <- c("cX", "cY") -``` - -模型对象 `fit_rongelap_gam` 在新的格点上预测核辐射强度，接着整理预测结果数据。 - -```{r} -# 预测 -rongelap_grid_df$ypred <- as.vector(predict(fit_rongelap_gam, newdata = rongelap_grid_df, type = "response")) -# 整理预测数据 -rongelap_grid_sf <- st_as_sf(rongelap_grid_df, coords = c("cX", "cY"), dim = "XY") -rongelap_grid_stars <- st_rasterize(rongelap_grid_sf, nx = 150, ny = 75) -rongelap_stars <- st_crop(x = rongelap_grid_stars, y = rongelap_coastline_sfp) -``` - -最后，将岛上各个格点的核辐射强度绘制出来，给出全岛核辐射强度的空间分布。 - -```{r} -#| label: fig-rongelap-mgcv-gam -#| fig-cap: 核辐射强度的预测分布 -#| fig-showtext: true -#| fig-width: 7 -#| fig-height: 4 -#| echo: !expr knitr::is_html_output() -#| code-fold: true - -library(ggplot2) -ggplot() + - geom_stars(data = rongelap_stars, aes(fill = ypred), na.action = na.omit) + - geom_sf(data = rongelap_coastline_sfp, fill = NA, color = "gray50", linewidth = 0.5) + - scale_fill_viridis_c(option = "C") + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", fill = "预测值") -``` - -### cmdstanr - -[**FRK**](https://github.com/andrewzm/FRK) 包 [@Matthew2023]（Fixed Rank Kriging，固定秩克里金） 可对有一定规模的（时空）空间区域数据和点参考数据集建模，响应变量的分布从高斯分布扩展到指数族，放在（时空）空间广义线性混合效应模型的框架下统一建模。然而，不支持带漂移项的泊松分布。 - -**brms** 包支持一大类贝叶斯统计模型，但是对高斯过程建模十分低效，当遇到有一定规模的数据，建模是不可行的，因为经过对 brms 包生成的模型代码的分析，发现它采用潜变量高斯过程（latent variable GP）模型，这也是采样效率低下的一个关键因素。 - -```{r} -#| eval: false -#| echo: true - -# 预计运行 1 个小时以上 -rongelap_brm <- brms::brm(counts ~ gp(cX, cY) + offset(log(time)), - data = rongelap, family = poisson(link = "log") -) -# 基样条近似拟合也很慢 -rongelap_brm <- brms::brm( - counts ~ gp(cX, cY, c = 5/4, k = 5) + offset(log(time)), - data = rongelap, family = poisson(link = "log") -) -``` - -当设置 $k = 5$ 时，用 5 个基函数来近似高斯过程，编译完成后，采样速度很快，但是结果不可靠，采样过程中的问题很多。当将横、纵坐标值同时缩小 6000 倍，采样效率并未得到改善。当设置 $k = 15$ 时，运行时间明显增加，采样过程的诊断结果类似 $k = 5$ 的情况，还是不可靠。截止写作时间，函数 `gp()` 的参数 `cov` 只能取指数二次核函数（exponentiated-quadratic kernel） 。说明 brms 包不适合处理含高斯过程的模型。 - -实际上，Stan 没有现成的有效算法或扩展包做有规模的高斯过程建模，详见 Bob Carpenter 在 2023 年 Stan 大会的[报告](https://github.com/stan-dev/stancon2023/tree/main/Bob-Carpenter)，因此，必须采用一些近似方法，通过 Stan 编码实现。接下来，分别手动实现低秩和基样条两种方法近似边际高斯过程（marginal likelihood GP）[@Rasmussen2006]，用 Stan 编码模型。代码文件分别是 `rongelap_poisson_lr.stan` 和 `rongelap_poisson_splines.stan` 。 - -```{r} -library(cmdstanr) -``` - -### GINLA {#sec-rongelap-inla} - -**mgcv** 包的函数 `ginla()` 实现简化版的 Integrated Nested Laplace Approximation, INLA [@wood2019]。 - -```{r} -rongelap_gam <- gam( - counts ~ s(cX, cY, bs = "gp", k = 50), offset = log(time), - data = rongelap, family = poisson(link = "log"), fit = FALSE -) -# 简化版 INLA -rongelap_ginla <- ginla(G = rongelap_gam) -str(rongelap_ginla) -``` - -其中， $k = 50$ 表示 49 个样条参数，每个参数的分布对应有 100 个采样点，另外，截距项的边际后验概率密度分布如下： - -```{r} -#| label: fig-rongelap-mgcv-ginla -#| fig-cap: 截距项的边际后验概率密度分布 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -plot( - rongelap_ginla$beta[1, ], rongelap_ginla$density[1, ], - type = "l", xlab = "截距项", ylab = "概率密度" -) -``` - -不难看出，截距项在 1.976 至 1.978 之间，50个参数的最大后验估计分别如下： - -```{r} -idx <- apply(rongelap_ginla$density, 1, function(x) x == max(x)) -rongelap_ginla$beta[t(idx)] -``` - -### INLA - -接下来，介绍完整版的近似贝叶斯推断方法 INLA --- 集成嵌套拉普拉斯近似 (Integrated Nested Laplace Approximations，简称 INLA) [@Rue2009]。根据研究区域的边界构造非凸的内外边界，处理边界效应。 - -```{r} -#| message: false - -library(INLA) -library(splancs) -# 构造非凸的边界 -boundary <- list( - inla.nonconvex.hull( - points = as.matrix(rongelap_coastline[,c("cX", "cY")]), - convex = 100, concave = 150, resolution = 100), - inla.nonconvex.hull( - points = as.matrix(rongelap_coastline[,c("cX", "cY")]), - convex = 200, concave = 200, resolution = 200) -) - -``` - -根据研究区域的情况构造网格，边界内部三角网格最大边长为 300，边界外部最大边长为 600，边界外凸出距离为 100 米。 - -```{r} -# 构造非凸的网格 -mesh <- inla.mesh.2d( - loc = as.matrix(rongelap[, c("cX", "cY")]), offset = 100, - max.edge = c(300, 600), boundary = boundary -) -``` - -构建 SPDE，指定自协方差函数为指数型，则 $\nu = 1/2$ ，因是二维平面，则 $d = 2$ ，根据 $\alpha = \nu + d/2$ ，从而 `alpha = 3/2` 。 - -```{r} -spde <- inla.spde2.matern(mesh = mesh, alpha = 3/2, constr = TRUE) -``` - -生成 SPDE 模型的指标集，也是随机效应部分。 - -```{r} -indexs <- inla.spde.make.index(name = "s", n.spde = spde$n.spde) -lengths(indexs) -``` - -投影矩阵，三角网格和采样点坐标之间的投影。观测数据 `rongelap` 和未采样待预测的位置数据 `rongelap_grid_df` - -```{r} -# 观测位置投影到三角网格上 -A <- inla.spde.make.A(mesh = mesh, loc = as.matrix(rongelap[, c("cX", "cY")]) ) -# 预测位置投影到三角网格上 -coop <- as.matrix(rongelap_grid_df[, c("cX", "cY")]) -Ap <- inla.spde.make.A(mesh = mesh, loc = coop) -# 1612 个预测位置 -dim(Ap) -``` - -准备观测数据和预测位置，构造一个 INLA 可以使用的数据栈 Data Stack。 - -```{r} -# 在采样点的位置上估计 estimation stk.e -stk.e <- inla.stack( - tag = "est", - data = list(y = rongelap$counts, E = rongelap$time), - A = list(rep(1, 157), A), - effects = list(data.frame(b0 = 1), s = indexs) -) - -# 在新生成的位置上预测 prediction stk.p -stk.p <- inla.stack( - tag = "pred", - data = list(y = NA, E = NA), - A = list(rep(1, 1612), Ap), - effects = list(data.frame(b0 = 1), s = indexs) -) - -# 合并数据 stk.full has stk.e and stk.p -stk.full <- inla.stack(stk.e, stk.p) -``` - -指定响应变量与漂移项、联系函数、模型公式。 - -```{r} -# 精简输出 -inla.setOption(short.summary = TRUE) -# 模型拟合 -res <- inla(formula = y ~ 0 + b0 + f(s, model = spde), - data = inla.stack.data(stk.full), - E = E, # E 已知漂移项 - control.family = list(link = "log"), - control.predictor = list( - compute = TRUE, - link = 1, # 与 control.family 联系函数相同 - A = inla.stack.A(stk.full) - ), - control.compute = list( - cpo = TRUE, - waic = TRUE, # WAIC 统计量 通用信息准则 - dic = TRUE # DIC 统计量 偏差信息准则 - ), - family = "poisson" -) -# 模型输出 -summary(res) -``` - -- `kld` 表示 Kullback-Leibler divergence (KLD) 它的值描述标准高斯分布与 Simplified Laplace Approximation 之间的差别，值越小越表示拉普拉斯的近似效果好。 - -- DIC 和 WAIC 指标都是评估模型预测表现的。另外，还有两个量计算出来了，但是没有显示，分别是 CPO 和 PIT 。CPO 表示 Conditional Predictive Ordinate (CPO)，PIT 表示 Probability Integral Transforms (PIT) 。 - -固定效应（截距）和超参数部分 - -```{r} -# 截距 -res$summary.fixed -# 超参数 -res$summary.hyperpar -``` - -提取预测数据，并整理数据。 - -```{r} -# 预测值对应的指标集合 -index <- inla.stack.index(stk.full, tag = "pred")$data -# 提取预测结果，后验均值 -# pred_mean <- res$summary.fitted.values[index, "mean"] -# 95% 预测下限 -# pred_ll <- res$summary.fitted.values[index, "0.025quant"] -# 95% 预测上限 -# pred_ul <- res$summary.fitted.values[index, "0.975quant"] -# 整理数据 -rongelap_grid_df$ypred <- res$summary.fitted.values[index, "mean"] -# 预测值数据 -rongelap_grid_sf <- st_as_sf(rongelap_grid_df, coords = c("cX", "cY"), dim = "XY") -rongelap_grid_stars <- st_rasterize(rongelap_grid_sf, nx = 150, ny = 75) -rongelap_stars <- st_crop(x = rongelap_grid_stars, y = rongelap_coastline_sfp) -``` - -最后，类似之前 mgcv 建模的最后一步，将 INLA 的预测结果绘制出来。 - -```{r} -#| label: fig-rongelap-inla -#| fig-cap: 核辐射强度的预测分布 -#| fig-showtext: true -#| fig-width: 7 -#| fig-height: 4 - -ggplot() + - geom_stars(data = rongelap_stars, aes(fill = ypred), na.action = na.omit) + - geom_sf(data = rongelap_coastline_sfp, fill = NA, color = "gray50", linewidth = 0.5) + - scale_fill_viridis_c(option = "C") + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", fill = "预测值") -``` - -## 案例：城市土壤重金属污染 {#sec-topsoil-mgamm} - -介绍多元地统计（Multivariate geostatistics）建模分析与 INLA 实现。分析某城市地表土壤重金属污染情况，找到污染最严重的地方，即寻找重金属污染的源头。 - -```{r} -city_df <- readRDS(file = "data/cumcm2011A.rds") -library(sf) -city_sf <- st_as_sf(city_df, coords = c("x(m)", "y(m)"), dim = "XY") -city_sf -``` - -```{r} -#| label: fig-city-data -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true -#| fig-cap: 某城市的地形 - -ggplot(data = city_sf) + - geom_sf(aes(color = `功能区名称`, size = `海拔(m)`)) + - theme_classic() -``` - -类似 @sec-rongelap-mgcv ，下面根据数据构造城市边界以及对城市区域划分，以便预测城市中其它地方的重金属浓度。 - -```{r} -# 由点构造多边形 -city_sfp <- st_cast(st_combine(st_geometry(city_sf)), "POLYGON") -# 由点构造凸包 -city_hull <- st_convex_hull(st_geometry(city_sfp)) -# 添加缓冲区作为城市边界 -city_buffer <- st_buffer(city_hull, dist = 1000) -# 构造带边界约束的网格 -city_grid <- st_make_grid(city_buffer, n = c(150, 75)) -# 将 sfc 类型转化为 sf 类型 -city_grid <- st_as_sf(city_grid) -city_buffer <- st_as_sf(city_buffer) -city_grid <- city_grid[city_buffer, op = st_intersects] -# 计算网格中心点坐标 -city_grid_centroid <- st_centroid(city_grid) -# 共计 8494 个预测点 -city_grid_df <- as.data.frame(st_coordinates(city_grid_centroid)) -``` - -城市边界线 - -```{r} -#| label: fig-city-border -#| fig-cap: 某城市边界线 -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true - -ggplot() + - geom_sf(data = city_sf, aes(color = `功能区名称`, size = `海拔(m)`)) + - geom_sf(data = city_hull, fill = NA) + - geom_sf(data = city_buffer, fill = NA) + - theme_classic() -``` - -根据横、纵坐标和海拔数据，通过高斯过程回归（当然可以用其他办法，这里仅做示意）拟合获得城市其他位置的海拔，绘制等高线图，一目了然地获得城市地形信息。 - -```{r} -#| message: false - -library(mgcv) -# 提取部分数据 -city_topo <- subset(city_df, select = c("x(m)", "y(m)", "海拔(m)")) -colnames(city_topo) <- c("x", "y", "z") -# 高斯过程拟合 -fit_city_mgcv <- gam(z ~ s(x, y, bs = "gp", k = 50), - data = city_topo, family = gaussian(link = "identity") -) -# 绘制等高线图 -# vis.gam(fit_city_mgcv, color = "cm", plot.type = "contour", n.grid = 50) -colnames(city_grid_df) <- c("x", "y") -# 预测 -city_grid_df$zpred <- as.vector(predict(fit_city_mgcv, newdata = city_grid_df, type = "response")) -# 转化数据 -city_grid_sf <- st_as_sf(city_grid_df, coords = c("x", "y"), dim = "XY") -library(stars) -city_stars <- st_rasterize(city_grid_sf, nx = 150, ny = 75) -``` - -```{r} -#| label: fig-city-topo -#| fig-cap: 某城市地形图 -#| fig-showtext: true -#| fig-width: 7 -#| fig-height: 4 - -ggplot() + - geom_stars(data = city_stars, aes(fill = zpred), na.action = na.omit) + - geom_sf(data = city_buffer, fill = NA, color = "gray50", linewidth = .5) + - scale_fill_viridis_c(option = "C") + - theme_bw() + - labs(x = "横坐标（米）", y = "纵坐标（米）", fill = "海拔（米）") -``` - -```{r} -#| label: fig-city-as -#| fig-width: 7 -#| fig-height: 4 -#| fig-cap: 重金属砷 As 和镉 Cd 的浓度分布 -#| fig-subcap: -#| - 重金属砷 As -#| - 重金属镉 Cd -#| fig-showtext: true -#| layout-ncol: 1 - -library(ggplot2) -ggplot(data = city_sf) + - geom_sf(aes(color = `功能区名称`, size = `As (μg/g)`)) + - theme_classic() -ggplot(data = city_sf) + - geom_sf(aes(color = `功能区名称`, size = `Cd (ng/g)`)) + - theme_classic() -``` - -为了便于建模，对数据做标准化处理。 - -```{r} -# 根据背景值将各个重金属浓度列进行转化 -city_sf <- within(city_sf, { - `As (μg/g)` <- (`As (μg/g)` - 3.6) / 0.9 - `Cd (ng/g)` <- (`Cd (ng/g)` - 130) / 30 - `Cr (μg/g)` <- (`Cr (μg/g)` - 31) / 9 - `Cu (μg/g)` <- (`Cu (μg/g)` - 13.2) / 3.6 - `Hg (ng/g)` <- (`Hg (ng/g)` - 35) / 8 - `Ni (μg/g)` <- (`Ni (μg/g)` - 12.3) / 3.8 - `Pb (μg/g)` <- (`Pb (μg/g)` - 31) / 6 - `Zn (μg/g)` <- (`Zn (μg/g)` - 69) / 14 -}) -``` - -当我们逐一检查各个重金属的浓度分布时，发现重金属汞 Hg 在四个地方的浓度极高，暗示着如果数据采集没有问题，那么这几个地方很可能是污染源。 - -```{r} -#| label: fig-city-hg -#| fig-width: 7 -#| fig-height: 4 -#| fig-showtext: true -#| fig-cap: 重金属汞 Hg 的浓度分布 - -ggplot(data = city_sf) + - geom_sf(aes(color = `功能区名称`, size = `Hg (ng/g)`)) + - theme_classic() -``` - -### mgcv - -mgcv 包用于多元空间模型中样条参数估计和选择 [@wood2016]。 - -```{r} -# ?mvn -``` - -### INLA - -INLA 包用于多元空间模型的贝叶斯推断 [@Francisco2022] 。 diff --git a/generalized-linear-models.qmd b/generalized-linear-models.qmd deleted file mode 100644 index d4d8f3f9..00000000 --- a/generalized-linear-models.qmd +++ /dev/null @@ -1,558 +0,0 @@ -# 广义线性模型 {#sec-generalized-linear-models} - -```{r} -#| echo: false - -Sys.setenv(CMDSTANR_NO_VER_CHECK = TRUE) -source("_common.R") -``` - -## 生成模拟数据 {#sec-simulate-poisson-data} - -先介绍泊松广义线性模型，包括模拟和计算，并和 Stan 实现的结果比较。 - -泊松广义线性模型如下： - -$$ -\begin{aligned} -\log(\lambda) &= \beta_0 + \beta_1 x_1 + \beta_2 x_2 \\ -Y &\sim \mathrm{Poisson}(u\lambda) -\end{aligned} -$$ - -设定参数向量 $\beta = (\beta_0, \beta_1, \beta_2) = (0.5, 0.3, 0.2)$，观测变量 $X_1$ 和 $X_2$ 的均值都为 0，协方差矩阵 $\Sigma$ 为 - -$$ -\left[ - \begin{matrix} - 1.0 & 0.8 \\ - 0.8 & 1.0 - \end{matrix} -\right] -$$ - -模拟观测到的响应变量值和协变量值，添加漂移项 - -```{r} -set.seed(2023) -n <- 2500 # 样本量 -beta <- c(0.5, 0.3, 0.2) -X <- MASS::mvrnorm(n, mu = rep(0, 2), Sigma = matrix(c(1, 0.8, 0.8, 1), 2)) -u <- rep(c(2, 4), each = n / 2) -lambda <- u * exp(cbind(1, X) %*% beta) -y <- rpois(n, lambda = lambda) -``` - -## 拟合泊松模型 {#sec-poisson-model} - -拟合泊松回归模型 - -```{r} -fit_poisson_glm <- glm(y ~ X, family = poisson(link = "log"), offset = log(u)) -summary(fit_poisson_glm) -``` - -```{r} -# 对数似然函数值 -log_poisson_lik <- logLik(fit_poisson_glm) -# 计算 AIC AIC(fit_poisson_glm) --2 * c(log_poisson_lik) + 2 * attr(log_poisson_lik, "df") -``` - -下面用 Stan 编码泊松回归模型，模型代码如下： - -```{verbatim, file="code/poisson_log_glm.stan", lang="stan"} -``` - -Stan 代码主要分三部分： - -1. 数据部分 `data`：声明模型的输入数据，数据类型、大小、约束。 - -2. 参数部分 `parameters`：类似数据部分，声明模型的参数，参数类型、大小。 - -3. 模型部分 `model`：指定模型参数的先验分布。 - -4. 生成量 `generated quantities`：拟合模型获得参数估计值后，计算一些统计量。 - -下面准备数据 - -```{r} -nchains <- 4 # 4 条迭代链 -# 给每条链设置不同的参数初始值 -inits_data <- lapply(1:nchains, function(i) { - list( - alpha = runif(1, 0, 1), - beta = runif(2, 1, 10) - ) -}) - -# 准备数据 -poisson_d <- list( - n = 2500, # 观测记录的条数 - k = 2, # 协变量个数 - X = X, # N x 2 矩阵 - y = y, # N 向量 - log_offset = log(u) -) -``` - -编译模型，抽样获取参数的后验分布 - -```{r} -#| message: false - -# 加载 cmdstanr 包 -library(cmdstanr) -# 编译模型 -mod_poisson <- cmdstan_model( - stan_file = "code/poisson_log_glm.stan", - compile = TRUE, - cpp_options = list(stan_threads = TRUE) -) -# 采样拟合模型 -fit_poisson_stan <- mod_poisson$sample( - data = poisson_d, # 观测数据 - init = inits_data, # 迭代初值 - iter_warmup = 1000, # 每条链预处理迭代次数 - iter_sampling = 2000, # 每条链总迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = 1, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 1, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20222022 # 设置随机数种子，不要使用 set.seed() 函数 -) -# 迭代诊断 -fit_poisson_stan$diagnostic_summary() -# 输出结果 -fit_poisson_stan$summary(c("alpha", "beta", "lp__")) -``` - -## 参数后验分布 {#sec-posterior-distribution} - -加载 **bayesplot** 包，bayesplot 包提供一系列描述数据分布的绘图函数，比如绘制散点图 `mcmc_scatter()` 。$\beta_1$ 和 $\beta_2$ 的联合分布 - -```{r} -#| label: fig-stan-scatter -#| fig-cap: $\beta_1$ 和 $\beta_2$ 的联合分布 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| message: false - -library(ggplot2) -library(bayesplot) -mcmc_scatter(fit_poisson_stan$draws(c("beta[1]", "beta[2]")), size = 1) + - theme_classic() + - labs(x = expression(beta[1]), y = expression(beta[2])) -``` - -如果提取采样的数据，也可使用 ggplot2 包绘图，不局限于 bayesplot 设定的风格。 - -```{r} -#| label: fig-density-filled -#| fig-cap: $\beta_1$ 和 $\beta_2$ 的联合分布 -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 5 - -beta_df <- fit_poisson_stan$draws(c("beta[1]", "beta[2]"), format = "draws_df") -ggplot(data = beta_df, aes(x = `beta[1]`, y = `beta[2]`)) + - geom_density_2d_filled() + - facet_wrap(~.chain, ncol = 2) + - theme_classic() + - labs(x = expression(beta[1]), y = expression(beta[2])) -``` - -$\beta_1$ 和 $\beta_2$ 的热力图 - -```{r} -#| label: fig-stan-hex -#| fig-cap: $\beta_1$ 和 $\beta_2$ 的热力图 -#| fig-showtext: true -#| fig-width: 5.5 -#| fig-height: 4 - -mcmc_hex(fit_poisson_stan$draws(c("beta[1]", "beta[2]"))) + - theme_classic() + - labs(x = expression(beta[1]), y = expression(beta[2])) -``` - -各个参数的轨迹图 - -```{r} -#| label: fig-stan-trace -#| fig-cap: 各个参数的轨迹图 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 5 - -mcmc_trace(fit_poisson_stan$draws(c("beta[1]", "beta[2]")), - facet_args = list( - labeller = ggplot2::label_parsed, strip.position = "top", ncol = 1 - ) -) + - theme_classic() -``` - -可以将模型参数的后验分布图展示出来 - -```{r} -#| label: fig-stan-dens -#| fig-cap: 各个参数的分布图（密度图） -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 5 - -mcmc_dens(fit_poisson_stan$draws(c("beta[1]", "beta[2]")), - facet_args = list( - labeller = ggplot2::label_parsed, strip.position = "top", ncol = 1 - ) -) + - theme_classic() -``` - -后验分布的中位数、80% 区间 - -```{r} -#| label: fig-stan-areas -#| fig-cap: 各个参数的分布图（岭线图） -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| message: false - -mcmc_areas(fit_poisson_stan$draws(c("beta[1]", "beta[2]")), prob = 0.8) + - scale_y_discrete(labels = scales::parse_format()) + - theme_classic() -``` - -岭线图就是将各个参数的后验分布图放在一起。 - -```{r} -#| label: fig-stan-ridges -#| fig-cap: 各个参数的分布图（岭线图） -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| message: false - -mcmc_areas_ridges(x = fit_poisson_stan$draws(), pars = c("beta[1]", "beta[2]")) + - scale_y_discrete(labels = scales::parse_format()) + - theme_classic() -``` - -参数的 $\hat{R}$ 潜在尺度收缩因子 - -```{r} -bayesplot::rhat(fit_poisson_stan, pars = "alpha") -``` - -后验预测诊断的想法是检查根据拟合模型生成的随机数 $y^{rep}$ 与真实观测数据 $y$ 的接近程度。为直观起见，可以用一系列描述数据分布的图来可视化检验。 - -```{r} -#| label: fig-stan-nuts -#| fig-cap: NUTS 能量诊断图 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| message: false - -# mcmc_scatter(fit_poisson_stan$draws(), -# pars = c("beta[1]", "beta[2]"), -# np = nuts_params(fit_poisson_stan) -# ) - -mcmc_nuts_energy(x = nuts_params(fit_poisson_stan), binwidth = 1) + - ggtitle(label = "NUTS Energy Diagnostic") -``` - -y 是真实数据，yrep 是根据贝叶斯拟合模型生成的数据。下图是真实数据的密度图和50组生成数据的密度图。 - -```{r} -#| label: fig-stan-ppcheck-dens -#| fig-cap: 后验预测诊断图（密度图） -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 - -# 抽取 yrep 数据 -yrep <- fit_poisson_stan$draws(variables = "y_rep", format = "draws_matrix") -pp_check(y, yrep = yrep[1:50, ], fun = ppc_dens_overlay) + - theme_classic() -``` - -观察后验预测区间与真实数据的覆盖情况，不妨取前 50 次观测的数据，即 `y[1:50]` 与第 2 个自变量 `X[1:50, 2]` ，基于后验分布的 500 次采样数据绘制 50% 后验置信区间。 - -```{r} -#| label: fig-stan-ppcheck-intervals -#| fig-cap: 后验预测诊断图（区间图） -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 - -ppc_intervals(y[1:50], yrep = yrep[1:1000, 1:50], x = X[1:50, 2], prob = 0.5) -``` - -## 模型评估指标 {#sec-model-evaluation} - -**loo** 包可以计算 WAIC - -```{r} -fit_poisson_waic <- loo::waic(fit_poisson_stan$draws(variables = "log_lik")) -print(fit_poisson_waic) -``` - -**loo** 包推荐使用 LOO-CV ，它还提供诊断信息、有效样本量和蒙特卡罗估计。 - -```{r} -fit_poisson_loo <- fit_poisson_stan$loo(variables = "log_lik", cores = 2) -print(fit_poisson_loo) -``` - -## 可选替代实现 {#sec-bayesian-brms} - -对于常见的统计模型，rstanarm 和 **brms** 包都内置了预编译的 Stan 程序，下面用 **brms** 包的函数 `brm()` 拟合带上述漂移项的泊松广义线性模型，参数估计结果和 Base R 函数 `glm()` 的几乎一致，因编译和抽样的过程比较花费时间，速度不及 Base R。 - -``` r -# brms -dat <- data.frame(y = y, X = X, u = u) -colnames(dat) <- c("y", "x1", "x2", "u") -fit_poisson_brm <- brms::brm(y ~ x1 + x2 + offset(log(u)), - data = dat, family = poisson(link = "log") -) -fit_poisson_brm -``` - -``` - Family: poisson - Links: mu = log -Formula: y ~ x1 + x2 + offset(log(u)) - Data: dat (Number of observations: 2500) - Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup draws = 4000 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -Intercept 0.49 0.01 0.47 0.51 1.00 2509 2171 -x1 0.29 0.01 0.26 0.32 1.00 1771 1645 -x2 0.21 0.01 0.19 0.24 1.00 1727 1847 - -Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS -and Tail_ESS are effective sample size measures, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -调用函数 `brm()` 拟合模型后返回一个 brmsfit 对象 `fit_poisson_brm`，**brms** 包提供很多函数处理该数据对象，比如 `brms::loo()` 计算 LOO-CV - -``` r -brms::loo(fit_poisson_brm) -``` - -``` -Computed from 4000 by 2500 log-likelihood matrix - - Estimate SE -elpd_loo -5386.3 37.8 -p_loo 2.9 0.1 -looic 10772.6 75.5 ------- -Monte Carlo SE of elpd_loo is 0.0. - -All Pareto k estimates are good (k < 0.5). -See help('pareto-k-diagnostic') for details. -``` - -输出结果中， LOO IC 信息准则 Loo information criterion，looic 指标的作用类似频率派模型中的 AIC 指标，所以也几乎相同的。 - -``` r -# 后验预测检查 -brms::pp_check(fit_poisson_brm) -``` - -## 案例：吸烟喝酒和食道癌的关系 {#sec-esoph} - - - -本例数据集 esoph 来自 Base R 内置的 datasets 包，是法国伊勒-维莱讷食道癌研究数据，研究吸烟、喝酒与食道癌的关系，量化酒精、烟草、酒精和烟草的交互作用。部分数据集见 @tbl-esoph ，年龄组 agegp、酒精量 alcgp 和烟草量 tobgp 为有序的分类变量，正常来说，年龄越大，吸烟、喝酒对食道癌影响越大。 - -```{r} -#| label: tbl-esoph -#| tbl-cap: "食道癌研究数据（部分）" -#| echo: false - -knitr::kable(head(esoph), col.names = c("年龄组", "酒精量", "烟草量", "实验组", "控制组")) -``` - -### 描述分析 - -先来简单统计一下各年龄组、酒精量组的食道癌发病人数 - -```{r} -xtabs(data = esoph, cbind(ncases, ncontrols) ~ agegp + alcgp) -``` - -@fig-esoph 描述食道癌发病率与年龄组、酒精量的关系 - -```{r} -#| label: fig-esoph -#| fig-cap: "食道癌发病率与年龄组、酒精量的关系" -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 3.5 - -library(ggplot2) -aggregate(cbind(ncases, ncontrols) ~ agegp + alcgp, data = esoph, sum) |> - ggplot(aes(x = agegp, y = alcgp, fill = ncases / (ncases + ncontrols))) + - scale_fill_viridis_c(labels = scales::percent_format()) + - geom_tile() + - labs(x = "年龄组", y = "酒精量", fill = "发病率") -``` - -### 拟合模型 - -响应变量服从二项分布，自变量包含年龄分组 agegp、酒精量 alcgp、烟草量 tobgp 和 酒精量与烟草量的交互作用，建立广义线性模型。 - -```{r} -fit_glm_esoph <- glm(cbind(ncases, ncontrols) ~ agegp + tobgp * alcgp, - data = esoph, family = binomial(link = "logit") -) -``` - -模型输出 - -```{r} -summary(fit_glm_esoph) -``` - -整理模型输出后，见 @tbl-glm-esoph - -```{r} -#| label: tbl-glm-esoph -#| tbl-cap: "广义线性模型各个参数的估计结果" -#| echo: false - -knitr::kable(broom::tidy(fit_glm_esoph), align = "lrrrr") -``` - -### 与 brms 比较 - -下面从贝叶斯的视角分析和建模，使用 **brms** 包对该数据拟合，同样是广义线性模型。 - -``` r -fit_brm_esoph <- brm(ncases | trials(ncases + ncontrols) ~ agegp + tobgp * alcgp, - data = esoph, family = binomial(link = "logit")) -``` - -``` - Family: binomial - Links: mu = logit -Formula: ncases | trials(ncases + ncontrols) ~ agegp + tobgp * alcgp - Data: esoph (Number of observations: 88) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept -1.91 0.25 -2.49 -1.51 735 1.01 -agegp.L 3.39 0.86 2.13 5.45 674 1.01 -agegp.Q -1.68 0.78 -3.58 -0.50 658 1.01 -agegp.C 0.31 0.57 -0.59 1.63 709 1.00 -agegpE4 -0.01 0.36 -0.80 0.65 907 1.01 -agegpE5 -0.20 0.21 -0.59 0.22 1970 1.00 -tobgp.L 0.63 0.20 0.24 1.03 4654 1.00 -tobgp.Q 0.03 0.20 -0.38 0.42 3469 1.00 -tobgp.C 0.17 0.20 -0.21 0.57 3892 1.00 -alcgp.L 1.41 0.22 0.99 1.84 4067 1.00 -alcgp.Q -0.16 0.20 -0.56 0.24 3335 1.00 -alcgp.C 0.25 0.19 -0.12 0.62 3870 1.00 -tobgp.L:alcgp.L -0.69 0.42 -1.51 0.16 3878 1.00 -tobgp.Q:alcgp.L 0.13 0.43 -0.75 0.97 4249 1.00 -tobgp.C:alcgp.L -0.30 0.44 -1.15 0.58 5149 1.00 -tobgp.L:alcgp.Q 0.13 0.41 -0.67 0.94 3127 1.00 -tobgp.Q:alcgp.Q -0.46 0.41 -1.24 0.34 4037 1.00 -tobgp.C:alcgp.Q -0.05 0.40 -0.82 0.74 4490 1.00 -tobgp.L:alcgp.C -0.15 0.38 -0.89 0.58 3507 1.00 -tobgp.Q:alcgp.C 0.04 0.37 -0.69 0.75 3274 1.00 -tobgp.C:alcgp.C -0.17 0.36 -0.88 0.54 3773 1.00 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -输出结果和 `glm()` 有不少差别的。 - -## 案例：哥本哈根住房状况调查 - - - -数据集 housing 哥本哈根住房状况调查中的次数分布表，`Sat` 住户对目前居住环境的满意程度，是一个有序的因子变量，`Infl` 住户对物业管理的感知影响程度，`Type` 租赁住宿类型，如塔楼、中庭、公寓、露台，`Cont` 联系居民可与其他居民联系(低、高)，`Freq` 每个类中的居民人数，调查的人数。 - -```{r} -data("housing", package = "MASS") -str(housing) -``` - -响应变量是居民对居住环境满意度 Sat ，分三个等级，且存在强弱，等级，大小之分。 - -```{r} -# 因子变量的处理 -options(contrasts = c("contr.treatment", "contr.poly")) -# 有序逻辑回归 -housing_mass <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, Hess = TRUE) -summary(housing_mass) -``` - -计算置信区间 - -```{r} -# 剖面 -confint(profile(housing_mass), level = 0.95) -``` - -## 习题 {#sec-bayesian-exercises} - -1. 分析挑战者号航天飞机 O 型环数据。**DAAG** 包的 orings 数据集记录美国挑战者号航天飞机 O 型环在不同温度下发生 Erosion 腐蚀和 Blowby 串气的失效数量。 @fig-cdplot-orings 展示航天飞机 O 型环在不同温度下失效的分布图（条件密度图）：随着温度升高，O 型环越来越不容易失效。请分别用 Base R 函数 `glm()` 和 **cmdstanr** 包建模分析 O 型环数据。 - - ```{r} - #| label: fig-cdplot-orings - #| fig-cap: 航天飞机 O 型环在不同温度下失效的条件密度图 - #| fig-showtext: true - #| fig-width: 6 - #| fig-height: 4 - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - # data(orings, package = "DAAG") - orings <- readRDS(file = "data/orings.rds") - ggplot(orings, aes(x = Temperature, y = after_stat(count))) + - geom_density(aes(fill = Total > 0), position = "fill", bw = 2) + - scale_y_continuous(labels = scales::label_percent()) + - scale_fill_grey(labels = c("TRUE" = "是", "FALSE" = "否")) + - theme_classic() + - labs(x = "温度", y = "比例", fill = "失效") - ``` - -2. 基于数据集 infert 分析自然流产和人工流产后的不育情况， - - ```{r} - #| eval: false - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - infert_glm <- glm( - case ~ age + parity + education + spontaneous + induced, - data = infert, family = binomial() - ) - summary(infert_glm) - - # conditional logistic regression - library(survival) - infert_survival <- clogit( - case ~ age + parity + education + spontaneous + induced + strata(stratum), data = infert - ) - summary(infert_survival) - ``` - -3. 根据 @sec-nuclear-pollution-concentration 的数据，建立贝叶斯空间广义线性混合模型，用 Stan 预测核辐射强度的分布。 diff --git a/hierarchical-normal-models.qmd b/hierarchical-normal-models.qmd deleted file mode 100644 index 9b16cf7d..00000000 --- a/hierarchical-normal-models.qmd +++ /dev/null @@ -1,1341 +0,0 @@ -# 分层正态模型 {#sec-hierarchical-normal-models} - -```{r} -#| echo: false - -Sys.setenv(CMDSTANR_NO_VER_CHECK = TRUE) -# https://github.com/r-lib/processx/issues/236 -Sys.setenv(PROCESSX_NOTIFY_OLD_SIGCHLD = TRUE) -source("_common.R") -``` - -> This is a bit like asking how should I tweak my sailboat so I can explore the ocean floor. -> -> --- Roger Koenker [^hierarchical-normal-models-1] - -[^hierarchical-normal-models-1]: - -乔治·博克斯说，所有的模型都是错的，但有些是有用的。在真实的数据面前，尽我们所能，结果发现没有最好的模型，只有更好的模型。总是需要自己去构造符合自己需求的模型及其实现，只有自己能够实现，才能在模型的海洋中畅快地遨游。 - -介绍分层正态模型的定义、结构、估计，分层正态模型与曲线生长模型的关系，分层正态模型与潜变量模型的关系，分层正态模型与线性混合效应的关系。以 **rstan** 包和 **nlme** 包拟合分层正态模型，说明 **rstan** 包的一些用法，比较贝叶斯和频率派方法拟合的结果，给出结果的解释。再对比 16 个不同的 R包实现，总结一般地使用经验，也体会不同 R 包的独特性。 - -```{r} -#| message: false - -library(StanHeaders) -library(ggplot2) -library(rstan) -# 将编译的 Stan 模型与代码文件放在一起 -rstan_options(auto_write = TRUE) -# 如果CPU和内存足够，设置成与马尔科夫链一样多 -options(mc.cores = 2) -# 调色板 -custom_colors <- c( - "#4285f4", # GoogleBlue - "#34A853", # GoogleGreen - "#FBBC05", # GoogleYellow - "#EA4335" # GoogleRed -) -rstan_ggtheme_options( - panel.background = element_rect(fill = "white"), - legend.position = "top" -) -rstan_gg_options( - fill = "#4285f4", color = "white", - pt_color = "#EA4335", chain_colors = custom_colors -) -library(bayesplot) -``` - -## rstan 包 {#sec-8schools-rstan} - -本节以 8schools 数据为例介绍分层正态模型及 **rstan** 包实现，8schools 数据最早来自 @Rubin1981 ，分层正态模型如下： - -$$ -\begin{aligned} -y_j &\sim \mathcal{N}(\theta_j,\sigma_j^2) \quad -\theta_j = \mu + \tau \times \eta_j \\ -\theta_j &\sim \mathcal{N}(\mu, \tau^2) \quad -\eta_j \sim \mathcal{N}(0,1) \\ -\mu &\sim \mathcal{N}(0, 100^2) \quad \tau \sim \mathrm{half\_normal}(0,100^2) -\end{aligned} -$$ - -其中，$y_j,\sigma_j$ 是已知的观测数据，$\theta_j$ 是模型参数， $\eta_j$ 是服从标准正态分布的潜变量，$\mu,\tau$ 是超参数，分别服从正态分布（将方差设置为很大的数，则变成弱信息先验或无信息均匀先验）和半正态分布（随机变量限制为正值）。 - -### 拟合模型 - -用 **rstan** 包来拟合模型，下面采用非中心的参数化表示，降低参数的相关性，减少发散的迭代次数，提高采样效率。 - -```{r} -# 编译模型 -eight_schools_fit <- stan( - model_name = "eight_schools", - # file = "code/eight_schools.stan", - model_code = " - // saved as eight_schools.stan - data { - int J; // number of schools - array[J] real y; // estimated treatment effects - array[J] real sigma; // standard error of effect estimates - } - parameters { - real mu; // population treatment effect - real tau; // standard deviation in treatment effects - vector[J] eta; // unscaled deviation from mu by school - } - transformed parameters { - vector[J] theta = mu + tau * eta; // school treatment effects - } - model { - target += normal_lpdf(mu | 0, 100); - target += normal_lpdf(tau | 0, 100); - target += normal_lpdf(eta | 0, 1); // prior log-density - target += normal_lpdf(y | theta, sigma); // log-likelihood - } - ", - data = list( # 观测数据 - J = 8, - y = c(28, 8, -3, 7, -1, 1, 18, 12), - sigma = c(15, 10, 16, 11, 9, 11, 10, 18) - ), - warmup = 1000, # 每条链预处理迭代次数 - iter = 2000, # 每条链总迭代次数 - chains = 2, # 马尔科夫链的数目 - cores = 2, # 指定 CPU 核心数，可以给每条链分配一个 - verbose = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - seed = 20232023 # 设置随机数种子，不要使用 set.seed() 函数 -) -``` - -### 模型输出 - -用函数 `print()` 打印输出结果，保留 2 位小数。 - -```{r} -print(eight_schools_fit, digits = 2) -``` - -值得一提，数据有限而且规律不明确，数据隐含的信息不是很多，则先验分布的情况将会对参数估计结果产生很大影响。Stan 默认采用无信息的先验分布，当使用非常弱的信息先验时，结果就非常不同了。提取任意一个参数的结果，如查看参数 $\tau$ 的 95% 置信区间。 - -```{r} -print(eight_schools_fit, pars = "tau", probs = c(0.025, 0.975)) -``` - -从迭代抽样数据获得与 `print(fit)` 一样的结果。以便后续对原始采样数据做任意的进一步分析。**rstan** 包扩展泛型函数 `summary()` 以支持对 stanfit 数据对象汇总，输出各个参数分链条和合并链条的后验分布结果。 - -### 操作数据 - -抽取数据对象 `eight_schools_fit` 中的采样数据，合并几条马氏链的结果，返回的结果是一个列表。 - -```{r} -eight_schools_sim <- extract(eight_schools_fit, permuted = TRUE) -``` - -返回列表中的每个元素是一个数组，标量参数对应一维数组，向量参数对应二维数组。 - -```{r} -str(eight_schools_sim) -``` - -对于列表，适合用函数 `lapply()` 配合算术函数计算 $\mu,\tau$ 等参数的均值。 - -```{r} -fun_mean <- function(x) { - if (length(dim(x)) > 1) { - apply(x, 2, mean) - } else { - mean(x) - } -} -lapply(eight_schools_sim, FUN = fun_mean) -``` - -类似地，计算 $\mu,\tau$ 等参数的分位点。 - -```{r} -fun_quantile <- function(x, probs) { - if (length(dim(x)) > 1) { - t(apply(x, 2, quantile, probs = probs)) - } else { - quantile(x, probs = probs) - } -} -lapply(eight_schools_sim, fun_quantile, probs = c(2.5, 25, 50, 75, 97.5) / 100) -``` - -同理，可以计算最大值 `max()`、最小值 `min()` 和中位数 `median()` 等。 - -### 采样诊断 - -获取马尔科夫链迭代点列数据 - -```{r} -eight_schools_sim <- extract(eight_schools_fit, permuted = FALSE) -``` - -`eight_schools_sim` 是一个三维数组，1000（次迭代）\* 2 （条链）\* 19（个参数）。如果 `permuted = TRUE` 则会合并马氏链的迭代结果，变成一个列表。 - -```{r} -# 数据类型 -class(eight_schools_sim) -# 1000（次迭代）* 2 （条链）* 19（个参数） -str(eight_schools_sim) -``` - -提取参数 $\mu$ 的迭代点列，绘制迭代轨迹。 - -```{r} -#| label: fig-8schools-mu-base -#| fig-cap: Base R 绘制参数 $\mu$ 的迭代轨迹 -#| fig-showtext: true -#| par: true - -eight_schools_mu_sim <- eight_schools_sim[, , "mu"] -matplot( - eight_schools_mu_sim, xlab = "迭代次数", ylab = expression(mu), - type = "l", lty = "solid", col = custom_colors -) -abline(h = apply(eight_schools_mu_sim, 2, mean), col = custom_colors) -legend( - "topleft", legend = paste("chain", 1:2), box.col = "white", - inset = 0.01, lty = "solid", horiz = TRUE, col = custom_colors -) -``` - -也可以使用 **rstan** 包提供的函数 `traceplot()` 或者 `stan_trace()` 绘制参数的迭代轨迹图。 - -```{r} -#| label: fig-8schools-mu-ggplot2 -#| fig-cap: rstan 绘制参数 $\mu$ 的迭代轨迹 -#| fig-showtext: true - -stan_trace(eight_schools_fit, pars = "mu") + - labs(x = "迭代次数", y = expression(mu)) -``` - -### 后验分布 - -可以用函数 `stan_hist()` 或 `stan_dens()` 绘制后验分布图。下图分别展示参数 $\mu$、$\tau$ 的直方图，以及二者的散点图，参数 $\mu$ 的后验概率密度分布图。 - -```{r} -#| label: fig-8schools-rstan-posterior -#| fig-cap: rstan 包绘制后验分布图 -#| fig-showtext: true -#| fig-height: 6 - -p1 <- stan_hist(eight_schools_fit, pars = c("mu","tau"), bins = 30) -p2 <- stan_scat(eight_schools_fit, pars = c("mu","tau"), size = 1) + - labs(x = expression(mu), y = expression(tau)) -p3 <- stan_dens(eight_schools_fit, pars = "mu") + labs(x = expression(mu)) -library(patchwork) -p1 / (p2 + p3) -``` - -相比于 **rstan** 包，**bayesplot** 包可视化能力更强，支持对特定的参数做变换。**bayesplot** 包的函数 `mcmc_pairs()` 以矩阵图展示多个参数的分布，下图展示参数 $\mu$，$\log(\tau)$ 后验分布图。但是，这些函数都固定了一些标题，不能修改。 - -```{r} -#| label: fig-8schools-bayesplot-posterior -#| fig-cap: bayesplot 包绘制后验分布图 -#| fig-showtext: true -#| fig-height: 6 - -bayesplot::mcmc_pairs( - eight_schools_fit, pars = c("mu", "tau"), transform = list(tau = "log") -) -``` - -## 其它 R 包 {#sec-8schools-others} - -### nlme - -接下来，用 **nlme** 包拟合模型。 - -```{r} -# 成绩 -y <- c(28, 8, -3, 7, -1, 1, 18, 12) -# 标准差 -sigma <- c(15, 10, 16, 11, 9, 11, 10, 18) -# 学校编号 -g <- 1:8 -``` - -首先，调用 **nlme** 包的函数 `lme()` 拟合模型。 - -```{r} -library(nlme) -fit_lme <- lme(y ~ 1, random = ~ 1 | g, weights = varFixed(~ sigma^2), method = "REML") -summary(fit_lme) -``` - -随机效应的标准差 2.917988 ，随机效应部分的估计 - -```{r} -ranef(fit_lme) -``` - -类比 Stan 输出结果中的 $\theta$ 向量，每个学校的成绩估计 - -```{r} -7.785729 + 2.917988 * ranef(fit_lme) -``` - -### lme4 - -接着，采用 **lme4** 包拟合模型，发现 **lme4** 包获得与 **nlme** 包一样的结果。 - -```{r} -control <- lme4::lmerControl( - check.conv.singular = "ignore", - check.nobs.vs.nRE = "ignore", - check.nobs.vs.nlev = "ignore" -) -fit_lme4 <- lme4::lmer(y ~ 1 + (1 | g), weights = 1 / sigma^2, control = control, REML = TRUE) -summary(fit_lme4) -``` - -### blme - -下面使用 **blme** 包 [@Chung2013] ，**blme** 包基于 **lme4** 包，参数估计结果完全一致。 - -```{r} -# the mode should be at the boundary of the space. - -fit_blme <- blme::blmer( - y ~ 1 + (1 | g), control = control, REML = TRUE, - cov.prior = NULL, weights = 1 / sigma^2 -) -summary(fit_blme) -``` - -### MCMCglmm - -**MCMCglmm** 包 [@Hadfield2010] 采用 MCMC 算法拟合数据。 - -```{r} -schools <- data.frame(y = y, sigma = sigma, g = g) -schools$g <- as.factor(schools$g) -# inverse-gamma prior with scale and shape equal to 0.001 -prior1 <- list( - R = list(V = diag(schools$sigma^2), fix = 1), - G = list(G1 = list(V = 1, nu = 0.002)) -) -# 为可重复 -set.seed(20232023) -# 拟合模型 -fit_mcmc <- MCMCglmm::MCMCglmm( - y ~ 1, random = ~g, rcov = ~ idh(g):units, - data = schools, prior = prior1, verbose = FALSE -) -# 输出结果 -summary(fit_mcmc) -``` - -R-structure 表示残差方差，这是已知的参数。G-structure 表示随机截距的方差，Location effects 表示固定效应的截距。截距和 **nlme** 包的结果很接近。 - -### cmdstanr - -一般地，**rstan** 包使用的 stan 框架版本低于 **cmdstanr** 包，从 **rstan** 包切换到 **cmdstanr** 包，需要注意语法、函数的变化。**rstan** 和 **cmdstanr** 使用的 Stan 版本不同导致参数估计结果不同，结果可重复的条件非常苛刻，详见 [Stan 参考手册](https://mc-stan.org/docs/reference-manual/reproducibility.html)。在都是较新的版本时，Stan 代码不需要做改动，如下： - -```{verbatim, file="code/eight_schools.stan", lang="stan"} -``` - -此处，给参数 $\mu,\tau$ 添加了非常弱（模糊）的先验，结果将出现较大不同。 - -```{r} -#| message: false - -eight_schools_dat <- list( - J = 8, - y = c(28, 8, -3, 7, -1, 1, 18, 12), - sigma = c(15, 10, 16, 11, 9, 11, 10, 18) -) -library(cmdstanr) -mod_eight_schools <- cmdstan_model( - stan_file = "code/eight_schools.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -fit_eight_schools <- mod_eight_schools$sample( - data = eight_schools_dat, # 数据 - chains = 2, # 总链条数 - parallel_chains = 2, # 并行数目 - iter_warmup = 1000, # 每条链预处理的迭代次数 - iter_sampling = 1000, # 每条链采样的迭代次数 - threads_per_chain = 2, # 每条链设置 2 个线程 - seed = 20232023, # 随机数种子 - show_messages = FALSE, # 不显示消息 - refresh = 0 # 不显示采样迭代的进度 -) -``` - -结果保留 3 位有效数字，模型输出如下： - -```{r} -fit_eight_schools$summary(.num_args = list(sigfig = 3, notation = "dec")) -``` - -模型采样过程的诊断结果如下： - -```{r} -fit_eight_schools$diagnostic_summary() -``` - -分层模型的参数 $\mu,\log(\tau)$ 的后验联合分布呈现经典的漏斗状。 - -```{r} -#| label: fig-8schools-funnels -#| fig-cap: 参数 $\mu,\log(\tau)$ 的联合分布 -#| fig-width: 5 -#| fig-height: 4 -#| dev: 'tikz' -#| fig-process: !expr to_png - -bayesplot::mcmc_scatter( - fit_eight_schools$draws(), pars = c("mu", "tau"), - transform = list(tau = "log"), size = 2 -) + labs(x = "$\\mu$", y = "$\\log(\\tau)$") -``` - -```{r} -#| eval: false -#| echo: false - -bayesplot::mcmc_pairs( - fit_eight_schools$draws(), pars = c("mu", "tau"), - transform = list(tau = "log") -) - -eight_schools_df <- fit_eight_schools$draws(c("mu", "tau"), format = "draws_df") -ggplot(data = eight_schools_df, aes(x = mu, y = log(tau))) + - geom_point(color = "#4285f4") + - geom_density_2d(color = "#FBBC05", linewidth = 1) + - theme_bw() + - labs(x = expression(mu), y = expression(log(tau))) -``` - -对于调用 **cmdstanr** 包拟合的模型，适合用 **bayesplot** 包来可视化后验分布和诊断采样。 - -## 案例：rats 数据 {#sec-thirty-rats} - -rats 数据最早来自 @gelfand1990 ，记录 30 只小鼠每隔一周的重量，一共进行了 5 周。第一次记录是小鼠第 8 天的时候，第二次测量记录是第 15 天的时候，一直持续到第 36 天。下面在 R 环境中准备数据。 - -```{r} -# 总共 30 只老鼠 -N <- 30 -# 总共进行 5 周 -T <- 5 -# 小鼠重量 -y <- structure(c( - 151, 145, 147, 155, 135, 159, 141, 159, 177, 134, - 160, 143, 154, 171, 163, 160, 142, 156, 157, 152, 154, 139, 146, - 157, 132, 160, 169, 157, 137, 153, 199, 199, 214, 200, 188, 210, - 189, 201, 236, 182, 208, 188, 200, 221, 216, 207, 187, 203, 212, - 203, 205, 190, 191, 211, 185, 207, 216, 205, 180, 200, 246, 249, - 263, 237, 230, 252, 231, 248, 285, 220, 261, 220, 244, 270, 242, - 248, 234, 243, 259, 246, 253, 225, 229, 250, 237, 257, 261, 248, - 219, 244, 283, 293, 312, 272, 280, 298, 275, 297, 350, 260, 313, - 273, 289, 326, 281, 288, 280, 283, 307, 286, 298, 267, 272, 285, - 286, 303, 295, 289, 258, 286, 320, 354, 328, 297, 323, 331, 305, - 338, 376, 296, 352, 314, 325, 358, 312, 324, 316, 317, 336, 321, - 334, 302, 302, 323, 331, 345, 333, 316, 291, 324 -), .Dim = c(30, 5)) -# 第几天 -x <- c(8.0, 15.0, 22.0, 29.0, 36.0) -xbar <- 22.0 -``` - -重复测量的小鼠重量数据 rats 如下 @tbl-rats 所示。 - -```{r} -#| label: tbl-rats -#| tbl-cap: 小鼠重量数据（部分） -#| echo: false - -rownames(y) <- 1:30 -knitr::kable(head(y), col.names = paste("第", c(8, 15, 22, 29, 36), "天"), row.names = TRUE) -``` - -小鼠重量数据的分布和变化情况见下图，由图可以假定 30 只小鼠的重量服从正态分布，而30 只小鼠的重量呈现一种线性增长趋势。 - -```{r} -#| label: fig-rats -#| fig-cap: 30 只小鼠 5 次测量的数据 -#| fig-subcap: -#| - 小鼠重量的分布 -#| - 小鼠重量的变化 -#| fig-showtext: true -#| par: true -#| echo: false -#| fig-width: 5 -#| fig-height: 4.5 -#| layout-ncol: 2 - -matplot(y, xlab = "小鼠编号", ylab = "小鼠重量") -matplot(t(y), xlab = "测量次数", ylab = "小鼠重量", pch = 1) -``` - -## 频率派方法 {#sec-rats-frequentist} - -### nlme {#sec-rats-nlme} - -**nlme** 包适合长格式的数据，因此，先将小鼠数据整理成长格式。 - -```{r} -rats_data <- data.frame( - weight = as.vector(y), - rats = rep(1:30, times = 5), - days = rep(c(8, 15, 22, 29, 36), each = 30) -) -``` - -将 30 只小鼠的重量变化及回归曲线画出来，发现各只小鼠的回归线的斜率几乎一样，截距略有不同。不同小鼠的出生重量是不同，前面 Stan 采用变截距变斜率的混合效应模型拟合数据。 - -```{r} -#| label: fig-rats-lm -#| fig-cap: 小鼠重量变化曲线 -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 7 - -ggplot(data = rats_data, aes(x = days, y = weight)) + - geom_point() + - geom_smooth(formula = "y ~ x", method = "lm", se = FALSE) + - theme_bw() + - facet_wrap(facets = ~rats, labeller = "label_both", ncol = 6) + - labs(x = "第几天", y = "重量") -``` - -小鼠的重量随时间增长，不同小鼠的情况又会有所不同。作为一个参照，首先考虑变截距的随机效应模型。 - -$$ -y_{ij} = \beta_0 + \beta_1 * x_j + \alpha_i + \epsilon_{ij}, \quad i = 1,2,\ldots,30. \quad j = 1,2,3,4,5 -$$ - -其中，$y_{ij}$ 表示第 $i$ 只小鼠在第 $j$ 次测量的重量，一共 30 只小鼠，共测量了 5 次。固定效应部分是 $\beta_0$ 和 $\beta_1$ ，分别表示截距和斜率。随机效应部分是 $\alpha_i$ 和 $\epsilon_{ij}$ ，分别服从正态分布$\alpha_i \sim \mathcal{N}(0, \sigma^2_{\alpha})$ 和 $\epsilon_{ij} \sim \mathcal{N}(0, \sigma^2_{\epsilon})$ 。$\sigma^2_{\alpha}$ 和 $\sigma^2_{\epsilon}$ 分别表示组间方差（group level）和组内方差（individual level）。 - -```{r} -library(nlme) -rats_lme0 <- lme(data = rats_data, fixed = weight ~ days, random = ~ 1 | rats) -summary(rats_lme0) -``` - -当然，若考虑不同小鼠的生长速度不同（变化不是很大），可用变截距和变斜率的随机效应模型表示生长曲线模型，下面加载 **nlme** 包调用函数 `lme()` 拟合该模型。 - -```{r} -library(nlme) -rats_lme <- lme(data = rats_data, fixed = weight ~ days, random = ~ days | rats) -summary(rats_lme) -``` - -模型输出结果中，固定效应中的截距项 `(Intercept)` 对应 106.56762，斜率 `days` 对应 6.18571。Stan 模型中截距参数 `alpha0` 的后验估计是 106.332，斜率参数 `beta_c` 的后验估计是 6.188。对比 Stan 和 **nlme** 包的拟合结果，可以发现贝叶斯和频率方法的结果是非常接近的。截距参数 `alpha0` 可以看作小鼠的初始（出生）重量，斜率参数 `beta_c` 可以看作小鼠的生长率 growth rate。 - -函数 `lme()` 的输出结果中，随机效应的随机截距标准差 10.7425835，对应 `tau_alpha`，表示每个小鼠的截距偏移量的波动。而随机斜率的标准差为 0.5105447，对应 `tau_beta`，相对随机截距标准差来说很小。残差标准差为 6.0146608，对应 `tau_c`，表示与小鼠无关的剩余量的波动，比如测量误差。总之，和 Stan 的结果有所不同，但相去不远。主要是前面的 Stan 模型没有考虑随机截距和随机斜率之间的相关性，这可以进一步调整 [@sorensen2016] 。 - -```{r} -# 参数的置信区间 -intervals(rats_lme, level = 0.95) -``` - -Stan 输出中，截距项 alpha、斜率项 beta 参数的标准差分别是 `tau_alpha` 和 `tau_beta` ，残差标准差参数 `tau_c` 的估计为 6.1。简单起见，没有考虑截距项和斜率项的相关性，即不考虑小鼠出生时的重量和生长率的相关性，一般来说，应该是有关系的。函数 `lme()` 的输出结果中给出了截距项和斜率项的相关性为 -0.343，随机截距和随机斜率的相关性为 -0.159。 - -计算与 Stan 输出中的截距项 `alpha_c` 对应的量，结合函数 `lme()` 的输出，截距、斜率加和之后，如下 - -```{r} -106.56762 + 6.18571 * 22 -``` - -值得注意，Stan 代码中对时间 days 做了中心化处理，即 $x_t - \bar{x}$，目的是降低采样时参数 $\alpha_i$ 和 $\beta_i$ 之间的相关性，而在拟合函数 `lme()` 中没有做处理，因此，结果无需转化，而且更容易解释。 - -```{r} -fit_lm <- lm(weight ~ days, data = rats_data) -summary(fit_lm) -``` - -采用简单线性模型即可获得与 **nlme** 包非常接近的估计结果，主要是小鼠重量的分布比较正态，且随时间的变化非常线性。 - -### lavaan - -**lavaan** 包 [@Rosseel2012] 主要是用来拟合结构方程模型，而生长曲线模型可以放在该框架下。所以，也可以用 **lavaan** 包来拟合，并且，它提供的函数 `growth()` 可以直接拟合生长曲线模型。 - -```{r} -#| message: false - -library(lavaan) -# 设置矩阵 y 的列名 -colnames(y) <- c("t1","t2","t3","t4","t5") -rats_growt_model <- " - # intercept and slope with fixed coefficients - intercept =~ 1*t1 + 1*t2 + 1*t3 + 1*t4 + 1*t5 - days =~ 0*t1 + 1*t2 + 2*t3 + 3*t4 + 4*t5 - - # if we fix the variances to be equal, the models are now identical. - t1 ~~ resvar*t1 - t2 ~~ resvar*t2 - t3 ~~ resvar*t3 - t4 ~~ resvar*t4 - t5 ~~ resvar*t5 -" -``` - -其中，算子符号 `=~` 定义潜变量，`~~` 定义残差协方差，intercept 表示截距， days 表示斜率。假定 5 次测量的测量误差（组内方差）是相同的。拟合模型的代码如下： - -```{r} -rats_growth_fit <- growth(rats_growt_model, data = y) -``` - -提供函数 `summary()` 获得模型输出，结果如下： - -```{r} -summary(rats_growth_fit, fit.measures = TRUE) -``` - -输出结果显示 **lavaan** 包的函数 `growth()` 采用极大似然估计方法。协方差部分 `Covariances:` 随机效应中斜率和截距的协方差。截距部分 `Intercepts:` 对应于混合效应模型的固定效应部分。方差部分 `Variances:` 对应于混合效应模型的随机效应部分，包括残差方差、斜率和截距的方差。不难看出，这和前面 **nlme** 包的输出结果差别很大。原因是 **lavaan** 包将测量的次序从 0 开始计，0 代表小鼠出生后的第 8 天。也就是说，**lavaan** 采用的是次序标记，而不是实际数据。将测量发生的时间（第几天）换算成次序（第几次），并从 0 开始计，则函数 `lme()` 的输出和函数 `growth()` 就一致了。 - -```{r} -# 重新组织数据 -rats_data2 <- data.frame( - weight = as.vector(y), - rats = rep(1:30, times = 5), - days = rep(c(0, 1, 2, 3, 4), each = 30) -) -# ML 方法估计模型参数 -rats_lme2 <- lme(data = rats_data2, fixed = weight ~ days, random = ~ days | rats, method = "ML") -summary(rats_lme2) -``` - -可以看到函数 `growth()` 给出的截距和斜率的协方差估计为 8.444，函数 `lme()` 给出对应截距和斜率的标准差分别是 10.652390 和 3.496588，它们的相关系数为 0.227，则函数 `lme()` 给出的协方差估计为 `10.652390*3.496588*0.227` ，即 8.455，协方差估计比较一致。同理，比较两个输出结果中的其它成分，函数 `growth()` 给出的残差方差估计为 36.176，则残差标准差估计为 6.0146，结合函数 `lme()` 给出的 `Random effects:` 中 `Residual`，结果完全一样。函数 `growth()` 给出的 `Intercepts:` 对应于函数 `lme()` 给出的固定效应部分，结果也是完全一样。 - -针对模型拟合对象 `rats_growth_fit` ，除了函数 `summary()` 可以汇总结果，**lavaan** 包还提供 `AIC()` 、 `BIC()` 和 `logLik()` 等函数，分别可以提取 AIC、BIC 和对数似然值， `AIC()` 和 `logLik()` 结果与前面的函数 `lme()` 的输出是一样的，而 `BIC()` 不同。 - -### lme4 - -当采用 **lme4** 包拟合数据的时候，发现输出结果与 **nlme** 包几乎相同。 - -```{r} -rats_lme4 <- lme4::lmer(weight ~ days + (days | rats), data = rats_data) -summary(rats_lme4) -``` - -### glmmTMB - -glmmTMB 包基于 Template Model Builder (TMB) ，拟合广义线性混合效应模型，公式语法与 **lme4** 包一致。 - -```{r} -#| message: false - -rats_glmmtmb <- glmmTMB::glmmTMB(weight ~ days + (days | rats), REML = TRUE, data = rats_data) -summary(rats_glmmtmb) -``` - -结果与 **nlme** 包完全一样。 - -### MASS - -**MASS** 包的结果与前面完全一致。 - -```{r} -rats_mass <- MASS::glmmPQL( - fixed = weight ~ days, random = ~ days | rats, - data = rats_data, family = gaussian(), verbose = FALSE -) -summary(rats_mass) -``` - -### spaMM - -**spaMM** 包的结果与前面完全一致。 - -```{r} -#| message: false - -rats_spamm <- spaMM::fitme(weight ~ days + (days | rats), data = rats_data) -summary(rats_spamm) -``` - -``` markdown - --------------- Random effects --------------- -Family: gaussian( link = identity ) - --- Random-coefficients Cov matrices: - Group Term Var. Corr. - rats (Intercept) 110.1 - rats days 0.2495 -0.1507 -# of obs: 150; # of groups: rats, 30 -``` - -随机效应的截距方差 110.1，斜率方差 0.2495，则标准差分别是 10.49 和 0.499，相关性为 -0.1507。 - -``` markdown - -------------- Residual variance ------------ -phi estimate was 36.1755 -``` - -残差方差为 36.1755，则标准差为 6.0146。 - -### hglm - -**hglm** 包 [@rönnegård2010] 可以拟合分层广义线性模型，线性混合效应模型和广义线性混合效应模型，随机效应和响应变量服从的分布可以很广泛，使用语法与 **lme4** 包一样。 - -```{r} -rats_hglm <- hglm::hglm2(weight ~ days + (days | rats), data = rats_data) -summary(rats_hglm) -``` - -固定效应的截距和斜率都是和 **nlme** 包的输出结果一致。值得注意，随机效应和模型残差都是以发散参数（Dispersion parameter）来表示的，模型残差方差为 37.09572，则标准差为 6.0906，随机效应的随机截距和随机斜率的方差分别为 103.4501 和 0.2407，则标准差分别为 10.1710 和 0.4906，这与 **nlme** 包的结果也是一致的。 - -### mgcv - -先考虑一个变截距的混合效应模型 - -$$ -y_{ij} = \beta_0 + \beta_1 * x_j + \alpha_i + \epsilon_{ij}, \quad i = 1,2,\ldots,30. \quad j = 1,2,3,4,5 -$$ - -假设随机效应服从独立同正态分布，等价于在似然函数中添加一个岭惩罚。广义可加模型在一定形式下和上述混合效应模型存在等价关系，在广义可加模型中，可以样条表示随机效应。**mgcv** 包拟合代码如下。 - -```{r} -#| message: false - -library(mgcv) -rats_data$rats <- as.factor(rats_data$rats) -rats_gam <- gam(weight ~ days + s(rats, bs = "re"), data = rats_data) -``` - -其中，参数取值 `bs = "re"` 指定样条类型，re 是 Random effects 的简写。 - -```{r} -summary(rats_gam) -``` - -其中，残差的方差 Scale est. = 67.303 ，则标准差为 $\sigma_{\epsilon} = 8.2038$ 。随机效应的标准差如下 - -```{r} -gam.vcomp(rats_gam, rescale = TRUE) -``` - -`rescale = TRUE` 表示恢复至原数据的尺度，标准差 $\sigma_{\alpha} = 14.033$。可以看到，固定效应和随机效应的估计结果与 **nlme** 包等完全一致。若考虑变截距和变斜率的混合效应模型，拟合代码如下： - -```{r} -rats_gam1 <- gam( - weight ~ days + s(rats, bs = "re") + s(rats, by = days, bs = "re"), - data = rats_data, method = "REML" -) -summary(rats_gam1) -``` - -输出结果中，固定效应部分的结果和 **nlme** 包完全一样。 - -```{r} -gam.vcomp(rats_gam1, rescale = TRUE) -``` - -输出结果中，依次是随机效应的截距、斜率和残差的标准差（标准偏差），和 **nlme** 包给出的结果非常接近。 - -**mgcv** 包还提供函数 `gamm()`，它将混合效应和固定效应分开，在拟合 LMM 模型时，它类似 **nlme** 包的函数 `lme()`。返回一个含有 lme 和 gam 两个元素的列表，前者包含随机效应的估计，后者是固定效应的估计，固定效应中可以添加样条（或样条表示的简单随机效益，比如本节前面提及的模型）。实际上，函数 `gamm()` 分别调用 **nlme** 包和 **MASS** 包来拟合 LMM 模型和 GLMM 模型。 - -```{r} -rats_gamm <- gamm(weight ~ days, random = list(rats = ~days), method = "REML", data = rats_data) -# LME -summary(rats_gamm$lme) -# GAM -summary(rats_gamm$gam) -``` - -## 贝叶斯方法 {#sec-rats-bayesianism} - -### rstan {#sec-rats-rstan} - -初始化模型参数，设置采样算法的参数。 - -```{r} -# 迭代链 -chains <- 4 -# 迭代次数 -iter <- 1000 -# 初始值 -init <- rep(list(list( - alpha = rep(250, 30), beta = rep(6, 30), - alpha_c = 150, beta_c = 10, - tausq_c = 1, tausq_alpha = 1, - tausq_beta = 1 -)), chains) -``` - -接下来，基于重复测量数据，建立线性生长曲线模型： - -$$ -\begin{aligned} -\alpha_c &\sim \mathcal{N}(0,100) \quad \beta_c \sim \mathcal{N}(0,100) \\ -\tau^2_{\alpha} &\sim \mathrm{inv\_gamma}(0.001, 0.001) \\ -\tau^2_{\beta} &\sim \mathrm{inv\_gamma}(0.001, 0.001) \\ -\tau^2_c &\sim \mathrm{inv\_gamma}(0.001, 0.001) \\ -\alpha_n &\sim \mathcal{N}(\alpha_c, \tau_{\alpha}) \quad -\beta_n \sim \mathcal{N}(\beta_c, \tau_{\beta}) \\ -y_{nt} &\sim \mathcal{N}(\alpha_n + \beta_n * (x_t - \bar{x}), \tau_c) \\ -& n = 1,2,\ldots,N \quad t = 1,2,\ldots,T -\end{aligned} -$$ - -其中， $\alpha_c,\beta_c,\tau_c,\tau_{\alpha},\tau_{\beta}$ 为无信息先验，$\bar{x} = 22$ 表示第 22 天，$N = 30$ 和 $T = 5$ 分别表示实验中的小鼠数量和测量次数，下面采用 Stan 编码、编译、采样和拟合模型。 - -```{r} -rats_fit <- stan( - model_name = "rats", - model_code = " - data { - int N; - int T; - vector[T] x; - matrix[N,T] y; - real xbar; - } - parameters { - vector[N] alpha; - vector[N] beta; - - real alpha_c; - real beta_c; // beta.c in original bugs model - - real tausq_c; - real tausq_alpha; - real tausq_beta; - } - transformed parameters { - real tau_c; // sigma in original bugs model - real tau_alpha; - real tau_beta; - - tau_c = sqrt(tausq_c); - tau_alpha = sqrt(tausq_alpha); - tau_beta = sqrt(tausq_beta); - } - model { - alpha_c ~ normal(0, 100); - beta_c ~ normal(0, 100); - tausq_c ~ inv_gamma(0.001, 0.001); - tausq_alpha ~ inv_gamma(0.001, 0.001); - tausq_beta ~ inv_gamma(0.001, 0.001); - alpha ~ normal(alpha_c, tau_alpha); // vectorized - beta ~ normal(beta_c, tau_beta); // vectorized - for (n in 1:N) - for (t in 1:T) - y[n,t] ~ normal(alpha[n] + beta[n] * (x[t] - xbar), tau_c); - } - generated quantities { - real alpha0; - alpha0 = alpha_c - xbar * beta_c; - } - ", - data = list(N = N, T = T, y = y, x = x, xbar = xbar), - chains = chains, init = init, iter = iter, - verbose = FALSE, refresh = 0, seed = 20190425 -) -``` - -模型输出结果如下： - -```{r} -print(rats_fit, pars = c("alpha", "beta"), include = FALSE, digits = 1) -``` - -`alpha_c` 表示小鼠 5 次测量的平均重量，`beta_c` 表示小鼠体重的增长率，$\alpha_i,\beta_i$ 分别表示第 $i$ 只小鼠在第 22 天（第 3 次测量或 $x_t = \bar{x}$ ）的重量和增长率（每日增加的重量）。 - -对于分量众多的参数向量，比较适合用岭线图展示后验分布，下面调用 **bayesplot** 包绘制参数向量 $\boldsymbol{\alpha},\boldsymbol{\beta}$ 的后验分布。 - -```{r} -#| label: fig-rats-alpha -#| fig-cap: 参数 $\boldsymbol{\alpha}$ 的后验分布 -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 8 -#| message: false - -# plot(rats_fit, pars = "alpha", show_density = TRUE, ci_level = 0.8, outer_level = 0.95) -bayesplot::mcmc_areas_ridges(rats_fit, pars = paste0("alpha", "[", 1:30, "]")) + - scale_y_discrete(labels = scales::parse_format()) -``` - -参数向量 $\boldsymbol{\alpha}$ 的后验估计可以看作 $x_t = \bar{x}$ 时小鼠的重量，上图即为各个小鼠重量的后验分布。 - -```{r} -#| label: fig-rats-beta -#| fig-cap: 参数 $\boldsymbol{\beta}$ 的后验分布 -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 8 -#| message: false - -# plot(rats_fit, pars = "beta", ci_level = 0.8, outer_level = 0.95) -bayesplot::mcmc_areas_ridges(rats_fit, pars = paste0("beta", "[", 1:30, "]")) + - scale_y_discrete(labels = scales::parse_format()) -``` - -参数向量 $\boldsymbol{\beta}$ 的后验估计可以看作是小鼠的重量的增长率，上图即为各个小鼠重量的增长率的后验分布。 - -### cmdstanr - -从 rstan 包转 cmdstanr 包是非常容易的，只要语法兼容，模型代码可以原封不动。 - -```{r} -#| message: false - -library(cmdstanr) -mod_rats <- cmdstan_model( - stan_file = "code/rats.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -fit_rats <- mod_rats$sample( - data = list(N = N, T = T, y = y, x = x, xbar = xbar), # 数据 - chains = 2, # 总链条数 - parallel_chains = 2, # 并行数目 - iter_warmup = 1000, # 每条链预处理的迭代次数 - iter_sampling = 1000, # 每条链采样的迭代次数 - threads_per_chain = 2, # 每条链设置 2 个线程 - seed = 20232023, # 随机数种子 - show_messages = FALSE, # 不显示消息 - adapt_delta = 0.9, # 接受率 - refresh = 0 # 不显示采样迭代的进度 -) -``` - -模型输出 - -```{r} -# 显示除了参数 alpha 和 beta 以外的结果 -vars <- setdiff(fit_rats$metadata()$stan_variables, c("alpha", "beta")) -fit_rats$summary(variables = vars) -``` - -诊断信息 - -```{r} -fit_rats$diagnostic_summary() -``` - -### brms - -**brms** 包是基于 **rstan** 包的，基于 Stan 语言做贝叶斯推断，提供与 lme4 包一致的公式语法，且扩展了模型种类。 - -```{r} -#| eval: false - -rats_brms <- brms::brm(weight ~ days + (days | rats), data = rats_data) -summary(rats_brms) -``` - -``` markdown - Family: gaussian - Links: mu = identity; sigma = identity -Formula: weight ~ days + (days | rats) - Data: rats_data (Number of observations: 150) - Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup draws = 4000 - -Group-Level Effects: -~rats (Number of levels: 30) - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sd(Intercept) 11.27 2.23 7.36 16.08 1.00 2172 2939 -sd(days) 0.54 0.09 0.37 0.74 1.00 1380 2356 -cor(Intercept,days) -0.11 0.24 -0.53 0.39 1.00 920 1541 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -Intercept 106.47 2.47 101.61 111.23 1.00 2173 2768 -days 6.18 0.11 5.96 6.41 1.00 1617 2177 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sigma 6.15 0.47 5.30 7.14 1.00 1832 3151 - -Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS -and Tail_ESS are effective sample size measures, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -### rstanarm - -**rstanarm** 包与 **brms** 包类似，区别是前者预编译了 Stan 模型，后者根据输入数据和模型编译即时编译，此外，后者支持的模型范围更加广泛。 - -```{r} -#| eval: false - -library(rstanarm) -rats_rstanarm <- stan_lmer(formula = weight ~ days + (days | rats), data = rats_data) -summary(rats_rstanarm) -``` - -``` markdown -Model Info: - function: stan_lmer - family: gaussian [identity] - formula: weight ~ days + (days | rats) - algorithm: sampling - sample: 4000 (posterior sample size) - priors: see help('prior_summary') - observations: 150 - groups: rats (30) - -Estimates: - mean sd 10% 50% 90% -(Intercept) 106.575 2.236 103.789 106.559 109.415 -days 6.187 0.111 6.048 6.185 6.329 -sigma 6.219 0.497 5.626 6.183 6.862 -Sigma[rats:(Intercept),(Intercept)] 103.927 42.705 57.329 98.128 159.086 -Sigma[rats:days,(Intercept)] -0.545 1.492 -2.361 -0.402 1.162 -Sigma[rats:days,days] 0.304 0.112 0.181 0.285 0.445 - -MCMC diagnostics - mcse Rhat n_eff -(Intercept) 0.043 1.000 2753 -days 0.003 1.005 1694 -sigma 0.015 1.001 1172 -Sigma[rats:(Intercept),(Intercept)] 1.140 1.000 1403 -Sigma[rats:days,(Intercept)] 0.054 1.006 772 -Sigma[rats:days,days] 0.003 1.000 1456 - -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). -``` - -固定效应的部分，截距和斜率如下： - -``` markdown -Estimates: - mean sd 10% 50% 90% -(Intercept) 106.575 2.236 103.789 106.559 109.415 -days 6.187 0.111 6.048 6.185 6.329 -``` - -模型残差的标准差 sigma、随机效应 Sigma 的随机截距的方差 103.927 、随机斜率的方差 0.304 及其协方差 -0.545。 - -``` markdown -sigma 6.219 0.497 5.626 6.183 6.862 -Sigma[rats:(Intercept),(Intercept)] 103.927 42.705 57.329 98.128 159.086 -Sigma[rats:days,(Intercept)] -0.545 1.492 -2.361 -0.402 1.162 -Sigma[rats:days,days] 0.304 0.112 0.181 0.285 0.445 -``` - -**rstanarm** 和 **brms** 包的结果基本一致的。 - -### blme - -**blme** 包 [@Chung2013] 基于 **lme4** 包 [@Bates2015] 拟合贝叶斯线性混合效应模型。参考前面 **rstan** 小节中关于模型参数的先验设置，下面将残差方差的先验设置为逆伽马分布，随机效应的协方差设置为扁平分布。发现拟合结果和 **nlme** 和 **lme4** 包的几乎一样。 - -```{r} -rats_blme <- blme::blmer( - weight ~ days + (days | rats), data = rats_data, - resid.prior = invgamma, cov.prior = NULL -) -summary(rats_blme) -``` - -与 **lme4** 包的函数 `lmer()` 所不同的是参数 `resid.prior` 、`fixef.prior` 和 `cov.prior` ，它们设置参数的先验分布，其它参数的含义同 `lme4` 包。`resid.prior = invgamma` 表示残差方差参数使用逆伽马分布，`cov.prior = NULL` 表示随机效应的协方差参数使用扁平先验 flat priors。 - -### rjags - -**rjags** [@rjags] 是 JAGS 软件的 R 语言接口，可以拟合分层正态模型，再借助 **coda 包** [@coda2006] 可以分析 JAGS 返回的各项数据。 - -JAGS 代码和 Stan 代码有不少相似之处，最大的共同点在于以直观的统计模型的符号表示编码模型，仿照 Stan 代码， JAGS 编码的模型（BUGS 代码）如下： - -```{verbatim, file="code/rats.bugs", lang="bugs"} -``` - -转化主要集中在模型块，注意二者概率分布的名称以及参数含义对应关系，JAGS 使用 precision 而不是 standard deviation or variance，比如正态分布中的方差（标准偏差）被替换为其倒数。JAGS 可以省略类型声明（初始化模型时会补上），最后，JAGS 不支持 Stan 中的向量化操作，这种新特性是独特的。 - -```{r} -#| message: false - -library(rjags) -# 初始值 -rats_inits <- list( - list(".RNG.name" = "base::Marsaglia-Multicarry", - ".RNG.seed" = 20222022, - "alpha_c" = 100, "beta_c" = 6, "tau_c" = 5, "tau_alpha" = 10, "tau_beta" = 0.5), - list(".RNG.name" = "base::Marsaglia-Multicarry", - ".RNG.seed" = 20232023, - "alpha_c" = 200, "beta_c" = 10, "tau_c" = 15, "tau_alpha" = 15, "tau_beta" = 1) -) -# 模型 -rats_model <- jags.model( - file = "code/rats.bugs", - data = list(x = x, y = y, N = 30, T = 5, xbar = 22.0), - inits = rats_inits, - n.chains = 2, quiet = TRUE -) -# burn-in -update(rats_model, n.iter = 2000) -# 抽样 -rats_samples <- coda.samples(rats_model, - variable.names = c("alpha_c", "beta_c", "sigma_alpha", "sigma_beta", "sigma_c"), - n.iter = 4000, thin = 1 -) -# 参数的后验估计 -summary(rats_samples) -``` - -输出结果与 rstan 十分一致，且采样速度极快。类似地，`alpha0 = alpha_c - xbar * beta_c` 可得 alpha0 = 242.4752 - 22 \* 6.1878 = 106.3436。 - -### MCMCglmm - -同前，先考虑变截距的混合效应模型，**MCMCglmm** 包 [@Hadfield2010] 给出的拟合结果与 **nlme** 包很接近。 - -```{r} -## 变截距模型 -prior1 <- list( - R = list(V = 1, nu = 0.002), - G = list(G1 = list(V = 1, nu = 0.002)) -) -set.seed(20232023) -rats_mcmc1 <- MCMCglmm::MCMCglmm( - weight ~ days, random = ~ rats, - data = rats_data, verbose = FALSE, prior = prior1 -) -summary(rats_mcmc1) -``` - -随机效应的方差（组间方差）为 211.4 ，则标准差为 14.539。残差方差（组内方差）为 68.77，则标准差为 8.293。 - -再考虑变截距和斜率的混合效应模型。 - -```{r} -## 变截距、变斜率模型 -prior2 <- list( - R = list(V = 1, nu = 0.002), - G = list(G1 = list(V = diag(2), nu = 0.002)) -) -set.seed(20232023) -rats_mcmc2 <- MCMCglmm::MCMCglmm(weight ~ days, - random = ~ us(1 + days):rats, - data = rats_data, verbose = FALSE, prior = prior2 -) -summary(rats_mcmc2) -``` - -G-structure 代表随机效应部分，R-structure 代表残差效应部分，Location effects 代表固定效应部分。**MCMCglmm** 包的这套模型表示术语源自商业软件 [ASReml](https://vsni.co.uk/software/asreml) 。 - -随机截距的方差为 124.1327，标准差为 11.1415，随机斜率的方差 0.2783，标准差为 0.5275，随机截距和随机斜率的协方差 -0.7457，相关系数为 -0.1268，这与 **nlme** 包结果很接近。 - -### INLA - -同前，先考虑变截距的混合效应模型。 - -```{r} -#| message: false - -library(INLA) -inla.setOption(short.summary = TRUE) -# 数值稳定性考虑 -rats_data$weight <- rats_data$weight / 400 -# 变截距 -rats_inla1 <- inla(weight ~ days + f(rats, model = "iid", n = 30), - family = "gaussian", data = rats_data) -# 输出结果 -summary(rats_inla1) -``` - -再考虑变截距和斜率的混合效应模型。 - -```{r} -# https://inla.r-inla-download.org/r-inla.org/doc/latent/iid.pdf -# 二维高斯随机效应的先验为 Wishart prior -rats_data$rats <- as.integer(rats_data$rats) -rats_data$slopeid <- 30 + rats_data$rats -# 变截距、变斜率 -rats_inla2 <- inla( - weight ~ 1 + days + f(rats, model = "iid2d", n = 2 * 30) + f(slopeid, days, copy = "rats"), - data = rats_data, family = "gaussian" -) -# 输出结果 -summary(rats_inla2) -``` - -::: callout-warning -对于变截距和斜率混合效应模型，还未完全弄清楚 INLA 包的输出结果。固定效应部分和残差部分都是和前面一致的，但不清楚随机效应的方差协方差矩阵的估计与 INLA 输出的对应关系。参考[《Bayesian inference with INLA》](https://becarioprecario.bitbucket.io/inla-gitbook/index.html)第 3 章第 3 小节。 -::: - -## 总结 {#sec-hierarchical-normal-models-summary} - -基于 rats 数据建立变截距、变斜率的分层正态模型，也是线性混合效应模型的一种特殊情况，下表给出不同方法对模型各个参数的估计及置信区间。 - -| | $\beta_0$ | $\beta_1$ | $\sigma_0$ | $\sigma_1$ | $\rho_{\sigma}$ | $\sigma_{\epsilon}$ | -|-----------------|-----------|-----------|-----------|-----------|-----------|-----------| -| nlme (REML) | 106.568 | 6.186 | 10.743 | 0.511 | -0.159 | 6.015 | -| lme4 (REML) | 106.568 | 6.186 | 10.744 | 0.511 | -0.16 | 6.015 | -| glmmTMB (REML) | 106.568 | 6.186 | 10.743 | 0.511 | -0.16 | 6.015 | -| MASS (PQL) | 106.568 | 6.186 | 10.495 | 0.500 | -0.15 | 6.015 | -| spaMM (ML) | 106.568 | 6.186 | 10.49 | 0.499 | -0.15 | 6.015 | -| hglm | 106.568 | 6.186 | 10.171 | 0.491 | \- | 6.091 | -| mgcv (REML) | 106.568 | 6.186 | 10.311 | 0.492 | \- | 6.069 | - -: 频率派方法比较 {#tbl-rats-freqentist-compare} - -表中给出截距 $\beta_0$ 、斜率 $\beta_1$ 、随机截距 $\sigma_0$、随机斜率 $\sigma_1$、随机截距和斜率的相关系数 $\rho_{\sigma}$、残差 $\sigma_{\epsilon}$ 等参数的估计及 95% 的置信区间，四舍五入保留 3 位小数。固定效应部分的结果完全相同，随机效应部分略有不同。 - -| | $\beta_0$ | $\beta_1$ | $\sigma_0$ | $\sigma_1$ | $\rho_{\sigma}$ | $\sigma_{\epsilon}$ | -|-----------------|-----------|-----------|-----------|-----------|-----------|-----------| -| rstan (NUTS) | 106.4 | 6.2 | 14.6 | 0.5 | \- | 6.1 | -| cmdstanr (NUTS) | 106 | 6.19 | 14.5 | 0.513 | \- | 6.09 | -| brms (NUTS) | 106.47 | 6.18 | 11.27 | 0.54 | -0.11 | 6.15 | -| rstanarm (NUTS) | 106.575 | 6.187 | 10.194 | 0.551 | -0.0969 | 6.219 | -| blme (REML) | 106.568 | 6.186 | 10.787 | 0.512 | -0.160 | 5.949 | -| rjags (Gibbs) | 106.344 | 6.188 | 14.623 | 0.518 | \- | 6.073 | -| MCMCglmm (MCMC) | 106.40 | 6.19 | 11.14 | 0.53 | -0.13 | 6.18 | - -: 贝叶斯方法比较 {#tbl-rats-bayesian-compare} - -其中，**INLA** 结果的转化未完成，表格中暂缺。**rstan** 、 **cmdstanr** 和 **rjags** 未考虑随机截距和随机斜率的相关性，因此，相关系数暂缺。MCMC 是一种随机优化算法，在不同的实现中，可重复性的要求不同，设置随机数种子仅是其中的一个必要条件，故而，每次运行程序结果可能略微不同，但不影响结论。Stan 相关的 R 包输出结果中，**rstan** 保留 1 位小数，**cmdstanr** 保留 3 位有效数字，**brms** 保留 2 位小数，**rstanarm** 小数点后保留 3 位有效数字，各不相同，暂未统一处理。 - -## 习题 {#sec-hierarchical-models-exercises} - -1. 四个组的重复测量数据，如下表所示，建立贝叶斯线性混合效应模型/分层正态模型分析数据，与 nlme 包拟合的结果对比。 - - ```{r} - #| label: tbl-exer - #| tbl-cap: 实验数据 - #| echo: false - - y <- c( - 62, 60, 63, 59, - 63, 67, 71, 64, 65, 66, - 68, 66, 71, 67, 68, 68, - 56, 62, 60, 61, 63, 64, 63, 59 - ) - group <- c(rep(1, 4), rep(2, 6), rep(3, 6), rep(4, 8)) - id <- c(1:4, 1:6, 1:6, 1:8) - dat <- data.frame(y = y, group = group, id = id) - dat2 <- reshape(dat, direction = "wide", timevar = "group", idvar = "id") - options(knitr.kable.NA = '') - knitr::kable(dat2, col.names = c("编号", "第1组", "第2组", "第3组", "第4组"), row.names = FALSE) - ``` - - $$ - \begin{aligned} - y_{ij} \sim \mathcal{N}(\theta_i, \sigma^2) &\quad - \theta_i \sim \mathcal{N}(\mu, \tau^2) \\ - (\mu,\log \sigma, \tau) &\sim \mathrm{uniform\ prior} \\ - i = 1,2,3,4 &\quad j = 1,2, \ldots, n_i - \end{aligned} - $$ - - $y_{ij}$ 表示第 $i$ 组的第 $j$ 个测量值，$\theta_i$ 表示第 $i$ 组的均值，$\mu$ 表示整体的均值，$\sigma^2$ 表示组内的方差，$\tau^2$ 表示组内的方差。 - - ```{r} - library(nlme) - fit_lme <- lme(data = dat, fixed = y ~ 1, random = ~ 1 | group) - summary(fit_lme) - ``` - - 随机效应（组间标准差）$\tau^2$ 3.419288 、残差效应（组内标准差）$\sigma^2$ 2.366309。截距 $\mu$ 64.01266 代表整体的均值。各组的均值如下： - - ```{r} - 64.01266 + ranef(fit_lme) - ``` - - 也可以调用 **rjags** 包连接 JAGS 软件做贝叶斯推理，JAGS 代码如下： - - ```{verbatim, file="code/hnm.bugs", lang="bugs"} - ``` - - 完整的运行代码如下： - - ```{r} - #| message: false - - library(rjags) - # 参考值 - mu_a <- min(y) - mu_b <- max(y) - log_sigma_b <- 2 * log(sd(y)) - tau_b <- 2 * sd(y) - - J <- 4 # 4 个组 - n <- length(y) # 观察值数量 - N <- 1500 # 总采样数 - nthin <- 1 # 采样间隔 - nchains <- 2 # 2 条链 - ndiscard <- N / 2 # 预处理阶段 warm-up / burn-in - - # 初始值 - jags_inits <- list( - list(".RNG.name" = "base::Marsaglia-Multicarry", - ".RNG.seed" = 20222022, - "theta" = rep(3, 4), "mu" = 60, "log_sigma" = 0, "tau" = 1.5), - list(".RNG.name" = "base::Marsaglia-Multicarry", - ".RNG.seed" = 20232023, - "theta" = rep(2, 4), "mu" = 60, "log_sigma" = 1, "tau" = 0.375) - ) - # Call JAGS from R - jags_model <- jags.model( - file = "code/hnm.bugs", - data = list("y" = y, "group" = group, "J" = J, "n" = n), - inits = jags_inits, n.chains = nchains, quiet = TRUE - ) - # burn-in - update(jags_model, n.iter = ndiscard) - # 抽样 - jags_samples <- coda.samples(jags_model, - variable.names = c('theta','mu','sigma','tau'), n.iter = N - ) - # 参数的后验估计 - summary(jags_samples) - ``` - -2. 基于 **lme4** 包中学生对老师的评价数据 `InstEval` 建立（广义）线性混合效应模型分析数据。将响应变量（学生评价）视为有序的离散型变量，比较观察两个模型拟合效果（lme4、GLMMadaptive、spaMM 都不支持有序的响应变量，brms 则支持各类有序回归，使用语法与 lme4 完全一样。但是，由于数据规模比较大，计算时间数以天计，可考虑用 Stan 直接编码）。再者，从 Stan 实现的贝叶斯模型来看，感受 Stan 建模的灵活性和扩展性。（**nlme** 包不支持此等交叉随机效应的表达。） - - ```{r} - data(InstEval, package = "lme4") - str(InstEval) - ``` - - - 因子型变量 `s` 表示 1-2972 位参与评分的学生。 - - 因子型变量 `d` 表示 1-2160 位上课的讲师。 - - 因子型变量 `dept` 表示课程相关的 1-15 院系。 - - 因子型变量 `service` 表示讲师除了授课外，是否承担其它服务。 - - 数值型变量 `y` 表示学生给课程的评分，1-5 分对应从坏到很好。 - - ```{r} - # 数值型的响应变量 - fit_lme4 <- lme4::lmer(y ~ 1 + service + (1 | s) + (1 | d) + (1 | dept), data = InstEval) - summary(fit_lme4) - ``` - - **lme4** 包不支持响应变量为有序分类变量的情形，可用 **ordinal** 包，此等规模数据，拟合模型需要 5-10 分钟时间。 - - ```{r} - #| eval: false - #| echo: true - - # 有序因子型的响应变量 - InstEval$y <- factor(InstEval$y, ordered = TRUE) - library(ordinal) - fit_ordinal <- clmm( - y ~ 1 + service + (1 | s) + (1 | d) + (1 | dept), - data = InstEval, link = "probit", threshold = "equidistant" - ) - summary(fit_ordinal) - - ## MCMCglmm - library(MCMCglmm) - prior2 <- list( - R = list(V = 1, nu = 0.002), - G = list( - G1 = list(V = 1, nu = 0.002), - G2 = list(V = 1, nu = 0.002), - G3 = list(V = 1, nu = 0.002) - ) - ) - # 响应变量视为数值变量 - fit_mcmc2 <- MCMCglmm( - y ~ service, random = ~ s + d + dept, family = "gaussian", - data = InstEval, verbose = FALSE, prior = prior2 - ) - # 响应变量视为有序的分类变量 - fit_mcmc3 <- MCMCglmm( - y ~ service, random = ~ s + d + dept, family = "ordinal", - data = InstEval, verbose = FALSE, prior = prior2 - ) - ``` - - 当数据量较大时，**MCMCglmm** 包拟合模型需要很长时间，放弃，此时，Stan 的相对优势可以体现出来了。Stan 适合大型复杂概率统计模型。 diff --git a/matrix-operations.qmd b/matrix-operations.qmd deleted file mode 100644 index 1034c9cf..00000000 --- a/matrix-operations.qmd +++ /dev/null @@ -1,666 +0,0 @@ -# 矩阵运算 {#sec-matrix-operations} - -::: hidden -$$ - \def\bm#1{{\boldsymbol #1}} -$$ -::: - -> There's probably some examples, but there are some examples of people using `solve(t(X) %*% W %*% X) %*% W %*% Y` to compute regression coefficients, too. -> -> --- Thomas Lumley [^matrix-operations-1] - -[^matrix-operations-1]: - -本文主要介绍 Base R 提供的矩阵运算，包括加、减、乘等基础矩阵运算和常用的矩阵分解方法，总结 Base R 、**Matrix** 包和 Eigen 库对应的矩阵运算函数，分别对应基础、进阶和高阶的读者。最后，介绍矩阵运算在线性回归中的应用。 - -```{r} -library(Matrix) -``` - -## 基础运算 {#sec-basic-matrix-operations} - -约定符号 - -$$ -A = \begin{bmatrix} - a_{11} & a_{12} & a_{13} \\ - a_{21} & a_{22} & a_{23} \\ - a_{31} & a_{32} & a_{33} -\end{bmatrix} -$$ - -### 加、减、乘 - -矩阵 $A$ - -```{r} -A <- matrix(c(1, 1.2, 1.2, 3), nrow = 2) -A -B <- matrix(c(1, 2, 3, 4), nrow =2) -B -``` - -```{r} -A + A # 对应元素相加 -A - A # 对应元素相减 -A %*% A # 矩阵乘法 -``` - -### 对数、指数与幂 {#sec-log-exp} - -矩阵 $A$ 的对数 $\log A$ ，就是找一个矩阵 $L$ 使得 $A = \mathrm{e}^L$ - -```{r} -expm::logm(A) -``` - -矩阵 $A$ 的指数 $\mathrm{e}^{A}$ 的定义 - -$$ -\mathrm{e}^{A} = \sum_{k=1}^{\infty}\frac{A^k}{k!} -$$ - -**expm** 包可以计算矩阵的指数、开方、对数等。 - -```{r} -expm::expm(A) -``` - -或者使用奇异值分解 $A = UDV^{\top}$ ，则 $\mathrm{e}^A = U\mathrm{e}^DV^{\top}$ ，其中，D 是对角矩阵。 - -```{r} -(res <- svd(A)) -res$u %*% diag(exp(res$d)) %*% res$v -``` - -矩阵 $A$ 的 $n$ 次幂 $A^n$ ，利用奇异值分解 $A = UDV^{\top}$ - -$$ -\begin{aligned} -A^n &= A \times A \times \cdots \times A \\ -& = UDV^{\top} UDV^{\top} \cdots UDV^{\top} -\end{aligned} -$$ - -计算 $A^3$ - -```{r} -res$u %*% (diag(res$d)^3) %*% res$v -``` - -### 迹、秩、条件数 - -矩阵 $A$ 的迹 $\operatorname{tr}(A) = \sum_{i=1}^{n}a_{ii}$ - -```{r} -sum(diag(A)) -qr(A)$rank -kappa(A) -``` - -### 求逆与广义逆 - -Moore-Penrose Generalized Inverse 摩尔广义逆 $A^-$。 - -$$ -A^- = (A^{\top}A)^{-1}A -$$ - -如果 A 可逆，则广义逆就是逆。 - -```{r} -solve(A) # 逆 -MASS::ginv(A) # 广义逆 -``` - -### 行列式与伴随 {#sec-det-adjust} - -矩阵必须是方阵 - -伴随矩阵 $A*A^{\star} = A^{\star} *A = |A|*I, A^{\star} = |A|*A^{-1}$ - -- $|A^{\star}| = |A|^{n-1}, A \in \mathbb{R}^{n\times n},n \geq 2$ -- $(A^{\star})^{\star} = |A|^{n-2}A, A \in \mathbb{R}^{n\times n},n \geq 2$ -- $(A^{\star})^{\star}$ A 的 n 次伴随是？ - -```{r} -det(A) -det(A) * solve(A) -``` - -### 外积、直积与交叉积 {#sec-crossproduct} - -通常的矩阵乘法也叫矩阵内积 - -```{r} -A %*% B -``` - -外积 - -```{r} -A %o% B # outer(A, B, FUN = "*") -``` - -直积/克罗内克积 - -```{r} -A %x% B # kronecker(A, B, FUN = "*") -``` - -交叉积 $A^{\top}A$ - -```{r} -crossprod(A, A) # t(x) %*% y -tcrossprod(A, A) # x %*% t(y) -``` - -### Hadamard 积 {#subsec-hadamard-product} - -Hadamard 积（法国数学家 Jacques Hadamard）也叫 Schur 积（德国数学家 Issai Schur ）或 entrywise 积是两个维数相同的矩阵对应元素相乘，特别地，$A^2$ 表示将矩阵 $A$ 的每个元素平方 - -$$ -(A\circ B)_{ij} = (A)_{ij}(B)_{ij} -$$ - -$$ -\begin{bmatrix} - a_{11} & a_{12} & a_{13} \\ - a_{21} & a_{22} & a_{23} \\ - a_{31} & a_{32} & a_{33} -\end{bmatrix} -\circ -\begin{bmatrix} - b_{11} & b_{12} & b_{13} \\ - b_{21} & b_{22} & b_{23} \\ - b_{31} & b_{32} & b_{33} -\end{bmatrix} -= -\begin{bmatrix} - a_{11}b_{11} & a_{12}b_{12} & a_{13}b_{13} \\ - a_{21}b_{21} & a_{22}b_{22} & a_{23}b_{23} \\ - a_{31}b_{31} & a_{32}b_{32} & a_{33}b_{33} -\end{bmatrix} -$$ - -```{r} -fastmatrix::hadamard(A, B) -``` - -```{r} -A^2 # 每个元素平方 a_ij ^ 2 -A ** A # 每个元素的幂 a_ij ^ a_ij -2^A # 每个元素的指数 2 ^ a_ij -exp(A) # 每个元素的指数 exp(a_ij) -``` - -### 矩阵范数 {#subsec-matrix-norm} - -矩阵的范数，包括 1，2，无穷范数 - -$1$-范数 - -: 列和绝对值最大的 - -$2$ - 范数 - -: 又称谱范数，矩阵最大的奇异值，如果是方阵，就是最大的特征值 - -$\infty$ - 范数 - -: 行和绝对值最大的 - -Frobenius - 范数 - -: Euclidean 范数 - -$M$ - 范数 - -: 矩阵里模最大的元素，矩阵里面的元素可能含有复数，所以取模最大 - -```{r} -norm(A, type = "1") # max(abs(colSums(A))) -norm(A, type = "I") # max(abs(rowSums(A))) -norm(A, type = "F") -norm(A, type = "M") # -norm(A, type = "2") # max(svd(A)$d) -``` - -### 转置与旋转 {#sec-transpose-ratate} - -矩阵 $A$ - -```{r} -t(A) # 转置 -``` - -### 正交与投影 {#sec-orthogonal-projection} - -矩阵 $A$ 的投影 - -$$ -I - A(A^{\top}A)^{-1}A^{\top} -$$ - -```{r} -diag(rep(1, 2)) - A %*% solve(t(A) %*% A) %*% t(A) -``` - -### Givens 变换(\*) {#sec-matrix-givens} - -- [Givens 旋转](https://www.wikiwand.com/en/Givens_rotation) -- 帽子矩阵在统计中的应用，回归与方差分析 [@David1978] - -### Householder 变换(\*) {#sec-matrix-householder} - -Householder 变换是平面反射的一般情况： 要计算 $N\times P$ 维矩阵 $X$ 的 QR 分解，我们采用 Householder 变换 - -$$ -\mathbf{H}_{u} = \mathbf{I} -2\mathbf{u}\mathbf{u}^{\top} -$$ - -其中 $I$ 是 $N\times N$ 维的单位矩阵，$u$ 是 $N$ 维单位向量，即 $\| \mathbf{u}\| = \sqrt{\mathbf{u}\mathbf{u}^{\top}} = 1$。则 $H_u$ 是对称正交的，因为 - -$$ -\mathbf{H}_{u}^{\top} = \mathbf{I}^{\top} - 2\mathbf{u}\mathbf{u}^{\top} = \mathbf{H}_{u} -$$ - -并且 - -$$ -\mathbf{H}_{u}^{\top}\mathbf{H}_{u} = \mathbf{I} -4\mathbf{u}\mathbf{u}^{\top} + 4\mathbf{u}\mathbf{u}^{\top}\mathbf{u}\mathbf{u}^{\top} = \mathbf{I} -$$ - -让 $\mathbf{H}_{u}$ 乘以向量 $\mathbf{y}$，即 - -$$ -\mathbf{H}_{u}\mathbf{y} = \mathbf{y} - 2\mathbf{u}\mathbf{u}^{\top}\mathbf{y} -$$ - -它是 $y$ 关于垂直于过原点的 $u$ 的直线的反射，只要 - -$$ -\begin{aligned} -\mathbf{u} = \frac{\mathbf{y} - \| \mathbf{y} \|\mathbf{e}_{1}}{\| \mathbf{y} - \| \mathbf{y} \|\mathbf{e}_{1}\|} -\end{aligned} -$$ {#eq-householder-negative} - -或者 - -$$ -\begin{aligned} -\mathbf{u} = \frac{\mathbf{y} + \| \mathbf{y} \|\mathbf{e}_{1}}{\| \mathbf{y} + \| \mathbf{y} \|\mathbf{e}_{1}\|} -\end{aligned} -$$ {#eq-householder-positive} - -其中 $\mathbf{e}_{1} = (1,0,\ldots,0)^{\top}$，Householder 变换使得向量 $y$ 成为 $x$ 轴，在新的坐标系统中，向量 $H_{u}y$ 的坐标为 $(\pm\|y\|, 0, \ldots, 0)^\top$ - -举个例子 - -借助 Householder 变换做 QR 分解的优势： - -1. 更快、数值更稳定比直接构造 Q，特别当 N 大于 P 的时候 -2. 相比于存储矩阵 Q 的 $N^2$ 个元素，Householder 变换只存储 P 个向量 $u_1,\ldots,u_P$ -3. QR 分解的真实实现，比如在 LINPACK 中，定义 $u$ 的时候， @eq-householder-negative 或 @eq-householder-positive 的选择基于 $y$ 的第一个坐标的符号。如果坐标是负的，使用 @eq-householder-negative ，如果是正的，使用 @eq-householder-positive ， 这个做法可以使得数值计算更加稳定。 - -用 Householder 变换做 QR 分解 [@Bates1988] 及其 [R 语言](https://rpubs.com/aaronsc32/qr-decomposition-householder)、Eigen 实现。 - -### 单位矩阵 {#sec-identity-matrix} - -矩阵对角线上全是1，其余位置都是0 - -$$ -A = \begin{bmatrix} - 1 & 0 & 0 \\ - 0 & 1 & 0 \\ - 0 & 0 & 1 -\end{bmatrix} -$$ - -```{r} -diag(rep(3)) -``` - -而全1矩阵是所有元素都是1的矩阵，可以借助外积运算构造，如3阶全1矩阵 - -```{r} -rep(1,3) %o% rep(1,3) -``` - -### 对角矩阵 {#sec-matrix-diagonals} - -```{r} -diag(A) # 矩阵的对角 -diag(x = c(1, 2, 3)) # 构造对角矩阵 -``` - -### 稀疏矩阵 {#sec-sparse-matrix} - -稀疏矩阵的典型构造方式是通过三元组。 - -```{r} -i <- c(1, 3:8) # 行指标 -j <- c(2, 9, 6:10) # 列指标 -x <- 7 * (1:7) # 数据 -Matrix::sparseMatrix(i, j, x = x) -``` - -### 上、下三角矩阵 {#sec-upper-matrix} - -```{r} -m <- A -m -upper.tri(m) # 矩阵上三角 -m[upper.tri(m)] -m[lower.tri(m)] <- 0 # 获得上三角矩阵 -m -``` - -矩阵 A 的下三角矩阵 - -```{r} -m <- matrix(c(1, 2, 2, 3), nrow = 2) -m[row(m) < col(m)] <- 0 -m -``` - -## 矩阵分解 {#sec-matrix-decomposition} - -### LU 分解 {#sec-lu} - -矩阵 $A$ 的 LU 分解 $A = LU$ ， $L$ 是下三角矩阵，$U$ 是上三角矩阵 - -```{r} -Matrix::lu(A) -``` - -### Schur 分解 {#sec-schur} - -矩阵 $A$ 的 Schur 分解 $A = QTQ^{\top}$ - -```{r} -(res <- Matrix::Schur(A)) -``` - -其中 $Q$ 是一个正交矩阵 $QQ = I$ ，$T$ 是一个分块上三角矩阵 - -```{r} -res$Q %*% t(res$Q) -``` - -```{r} -res$Q %*% res$T %*% t(res$Q) -``` - -### QR 分解 {#sec-qr} - -矩阵 $A$ 的 QR 分解 $A = QR$ - -```{r} -(res <- qr(A)) -``` - -QR 分解结果中的 Q - -```{r} -qr.Q(res) -``` - -QR 分解结果中的 R - -```{r} -qr.R(res) -``` - -恢复矩阵 $A$ - -```{r} -qr.Q(res) %*% qr.R(res) -``` - -### Cholesky 分解 {#sec-cholesky} - -矩阵 $A$ 的 Cholesky 分解 $A = L^{\top}L$ ，其中 $L$ 是上三角矩阵 - -```{r} -(res <- chol(A)) -``` - -```{r} -t(res) %*% res -``` - -### 特征值分解 {#sec-spectral} - -特征值分解（Eigenvalues Decomposition）也叫谱分解（Spectral Decomposition） - -矩阵 $A$ 的特征值分解 $A = V\Lambda V^{-1}$ - -```{r} -(res <- eigen(A)) -``` - -返回值列表中的元素 vectors 就是 $V$ - -```{r} -res$vectors %*% diag(res$values) %*% solve(res$vectors) -``` - -计算特征值，即求解如下一元 $n$ 次方程 - -$|A - \lambda I| = 0$ - -```{r} -rootSolve::uniroot.all( - f = function(x) (x - 1) * (x - 3) - 1.2^2, - lower = -10, upper = 10 -) -``` - -### SVD 分解 {#sec-svd} - -矩阵 $A$ 的 SVD 分解 $A = UDV^{\top}$ ，矩阵 U 和 V 是正交的，矩阵 D 是对角的，矩阵 D 的对角元素是按降序排列的奇异值。 - -当矩阵是对称矩阵时，SVD 分解和特征值分解结果是一样的。 - -```{r} -(res <- svd(A)) -``` - -```{r} -# A = U D V' -res$u %*% diag(res$d) %*% t(res$v) -# D = U'AV -t(res$u) %*% A %*% res$v -# I = VV' -res$v %*% t(res$v) -# I = UU' -res$u %*% t(res$u) -``` - -## Eigen 库 {#sec-eigen-library} - -Eigen 是一个高性能的线性代数计算库，基于 C++ 编写，有 R 语言接口 **RcppEigen** 包。示例来自 **RcppEigen** 包，本文增加了特征向量，下面介绍如何借助 **RcppEigen** 包调用 Eigen 库做 SVD 矩阵分解。 - -``` {#rcpp-eigen .cpp} -#include - -// [[Rcpp::depends(RcppEigen)]] - -using Eigen::Map; // 'maps' rather than copies -using Eigen::MatrixXd; // variable size matrix, double precision -using Eigen::VectorXd; // variable size vector, double precision -using Eigen::SelfAdjointEigenSolver; // one of the eigenvalue solvers - -// [[Rcpp::export]] -VectorXd getEigenValues(Map M) { - SelfAdjointEigenSolver es(M); - return es.eigenvalues(); -} -// [[Rcpp::export]] -MatrixXd getEigenVectors(Map M) { - SelfAdjointEigenSolver es(M); - return es.eigenvectors(); -} -``` - -对上面的代码做几点说明： - -1. `// [[Rcpp::depends(RcppEigen)]]` 可以看作一种标记，表示依赖 **RcppEigen** 包提供的 C++ 头文件，并导入到 C++ 命名空间中。`// [[Rcpp::export]]` 也可以看作一种标记，表示下面的函数需要导出到 R 语言环境中，这样 C++ 中定义的函数可以在 R 语言环境中使用。 -2. `MatrixXd` 和 `VectorXd` 分别是 Eigen 库中定义的可变大小的双精度矩阵、向量类型。 -3. `SelfAdjointEigenSolver` 是 Eigen 库中关于特征值分解方法中的一个求解器，特征值分解的结果有两个部分：一个是由特征值构成的向量，一个是特征向量构成的矩阵。求解器 `SelfAdjointEigenSolver` 名称中 `SelfAdjoint` 是伴随的意思，它是做矩阵 $A$ 的伴随矩阵 $A^{\star}$ 的特征值分解。 -4. `getEigenValues` 和 `getEigenVectors` 是用户自定义的两个函数名称，分别计算特征值和特征向量。 - -伴随矩阵的特征值分解和原矩阵的特征值分解有何关系？为什么不直接求原矩阵的特征值分解呢？ - -1. 伴随矩阵的特征值与原矩阵是一样的。 -2. 伴随矩阵的特征向量有一个符号差异。 - -**RcppEigen** 包封装了 Eigen 库，它在 **RcppEigen** 包的源码路径为 - -`RcppEigen/inst/include/Eigen/src/Eigenvalues/SelfAdjointEigenSolver.h` - -在 Eigen 库的源码路径如下： - -`Eigen/src/Eigenvalues/SelfAdjointEigenSolver.h` 。 - -如何使用 **RcppEigen** 包加速计算？还是要看 Eigen 库的文档和源码，通过阅读源码，可以知道有哪些求解器，比如名称 `SelfAdjointEigenSolver` ，以及求解器包含的方法，比如 `eigenvalues()` 和 `eigenvectors()`，还有参数和返回值类型等。以特征值分解器 `SelfAdjointEigenSolver` 为例，编译上面的 C++ 代码，获得在 R 语言环境中可直接使用的函数 `getEigenValues()` 。 - -```{r} -#| message: false -# 编译代码 -Rcpp::sourceCpp(file = "code/rcpp_eigen.cpp") -``` - -然后，函数 `getEigenValues()` 计算特征值，返回一个向量。 - -```{r} -# 计算特征值 -getEigenValues(A) -``` - -返回一个矩阵，列是特征向量。 - -```{r} -# 计算特征向量 -getEigenVectors(A) -``` - -根据上述分解结果计算矩阵 A 的伴随矩阵 $A^{\star}$ 。 - -```{r} -t(getEigenVectors(A)) %*% diag(getEigenValues(A)) %*% getEigenVectors(A) -``` - -## 应用 {#sec-matrix-linear-regression} - -以线性模型为例讲述一些初步的计算性能提升办法。回顾一下线性回归的矩阵表示。 - -$$ -\begin{aligned} -&\boldsymbol{y} = X\boldsymbol{\beta} + \boldsymbol{\epsilon} \\ -&\boldsymbol{\epsilon} \sim \mathrm{MVN}(\boldsymbol{0}, \sigma^2I) -\end{aligned} -$$ - -模型中 $\boldsymbol{\beta}, \sigma^2$ 是待估的参数，它们的最小二乘估计分别记为 $\hat{\boldsymbol{\beta}},\hat{\sigma^2}$ 。 - -$$ -\begin{aligned} -\hat{\boldsymbol{\beta}} &= (X^{\top}X)^{-1}X^{\top}\boldsymbol{y} \\ -\hat{\sigma^2} &= \frac{\boldsymbol{y}^{\top}(I - X(X^{\top}X)^{-1}X^{\top})\boldsymbol{y}}{n - \mathrm{rank}(X)} -\end{aligned} -$$ - -在获得参数的估计后，响应变量 $\boldsymbol{y}$ 的预测 $\hat{\boldsymbol{y}}$ 及其预测方差 $\mathsf{Var}(\hat{\boldsymbol{y}})$ 如下。 - -$$ -\begin{aligned} -\hat{\boldsymbol{y}} &= X(X^{\top}X)^{-1}X^{\top}\boldsymbol{y} \\ -\mathsf{Var}(\hat{\boldsymbol{y}}) & = \sigma^2 X(X^{\top}X)^{-1}X^{\top} -\end{aligned} -$$ - -```{r} -set.seed(2023) -n <- 200 -p <- 50 -x <- matrix(rnorm(n * p), n) -y <- rnorm(n) -fit_lm <- lm(y ~ x + 0) -``` - -下面不同的方法来计算预测值 $\hat{\boldsymbol{y}}$ ，从慢到快地优化。教科书版就是从左至右依次计算。 - -```{r} -fit_base = function(x, y) { - x %*% solve(t(x) %*% x) %*% t(x) %*% y -} -``` - -矩阵乘向量比矩阵乘矩阵快。虽然矩阵乘法没有交换律，但是有结合律。先向量计算，然后矩阵计算。 - -$$ -\hat{\boldsymbol{y}} = X(X^{\top}X)^{-1}X^{\top}\boldsymbol{y} -$$ - -```{r} -fit_vector <- function(x, y) { - x %*% (solve(t(x) %*% x) %*% (t(x) %*% y)) -} -``` - -解线性方程组比求逆快。 $X^{\top}X$ 是对称的，通过解线性方程组来避免求逆。 - -$$ -\hat{\boldsymbol{y}} = X(X^{\top}X)^{-1}X^{\top}\boldsymbol{y} -$$ - -```{r} -fit_inv <- function(x, y) { - x %*% solve(crossprod(x), crossprod(x, y)) -} -``` - -QR 分解。 $X_{n\times p} = Q_{n\times p} R_{p\times p}$，$n > p$，$Q^{\top}Q = I$，$R$ 是上三角矩阵。 - -$$ -\begin{aligned} -\hat{\boldsymbol{y}} &= X(X^{\top}X)^{-1}X^{\top}\boldsymbol{y} \\ -& = QR \big((QR)^{\top}QR\big)^{-1}(QR)^{\top}\boldsymbol{y} \\ -& = QR(R^{\top}R)^{-1}R^{\top}Q^{\top}\boldsymbol{y} \\ -& = QQ^{\top}\boldsymbol{y} -\end{aligned} -$$ - -```{r} -fit_qr <- function(x, y) { - decomp <- qr(x) - qr.qy(decomp, qr.qty(decomp, y)) -} -fit_qr2 <- lm.fit(x, y) -``` - -其中，函数 `qr.qy(decomp, y)` 表示 `Q %*% y` ，函数 `qr.qty(decomp, y)` 表示 `t(Q) %*% y` 。实际上，Base R 提供的线性回归拟合函数 `lm()` 就采用 QR 分解。 - -Cholesky 分解。记 $A = X^{\top}X$ ，若 $A$ 是正定矩阵，则 $A$ 可做 Cholesky 分解。不妨设$A = L^{\top}L$，其中 $L$ 是上三角矩阵。 - -$$ -\begin{aligned} -\hat{\boldsymbol{y}} &= X(X^{\top}X)^{-1}X^{\top}\boldsymbol{y} \\ -& = X\big(L^{\top}L\big)^{-1}X^{\top}\boldsymbol{y} \\ -& = XL^{-1}(L^{\top})^{-1}X^{\top}\boldsymbol{y} -\end{aligned} -$$ - -```{r} -fit_chol <- function(x, y) { - decomp <- chol(crossprod(x)) - lxy <- backsolve(decomp, crossprod(x, y), transpose = TRUE) - b <- backsolve(decomp, lxy) - x %*% b -} -``` - -函数 `backsolve()` 求解上三角线性方程组。 diff --git a/mixed-effects-models.qmd b/mixed-effects-models.qmd deleted file mode 100644 index fc2fb970..00000000 --- a/mixed-effects-models.qmd +++ /dev/null @@ -1,1288 +0,0 @@ -# 混合效应模型 {#sec-mixed-effects-models} - -::: hidden -$$ - \def\bm#1{{\boldsymbol #1}} -$$ -::: - -> I think that the formula language does allow expressions with '/' to represent nested factors but I can't check right now as there is a fire in the building where my office is located. I prefer to simply write nested factors as `factor1 + factor1:factor2`. -> -> --- Douglas Bates [^mixed-effects-models-1] - -[^mixed-effects-models-1]: - -```{r} -#| echo: false - -source("_common.R") -``` - -```{r} -#| message: false - -library(nlme) # 线性混合效应模型 -library(GLMMadaptive) # 广义线性混合效应模型 -library(mgcv) # 广义线性/可加混合效应模型 -library(INLA) -library(splines) # 样条 -library(cmdstanr) # 编译采样 -library(ggplot2) # 作图 -library(bayesplot) # 后验分布 -library(loo) # LOO-CV -``` - -混合效应模型在心理学、生态学、计量经济学和空间统计学等领域应用十分广泛。线性混合效应模型有多个化身，比如生态学里的分层线性模型（Hierarchical linear Model，简称 HLM），心理学的多水平线性模型（Multilevel Linear Model）。模型名称的多样性正说明它应用的广泛性！ 混合效应模型内容非常多，非常复杂，因此，本章仅对常见的四种类型提供入门级的实战内容。从频率派和贝叶斯派两个角度介绍模型结构及说明、R 代码或 Stan 代码实现及输出结果解释。 - -除了 R 语言社区提供的开源扩展包，商业的软件有 [Mplus](https://www.statmodel.com/) 、[ASReml](https://vsni.co.uk/software/asreml) 和 [SAS](https://www.sas.com/) 等，而开源的软件 [OpenBUGS](https://www.mrc-bsu.cam.ac.uk/software/bugs/openbugs/) 、 [JAGS](https://mcmc-jags.sourceforge.io/) 和 [Stan](https://mc-stan.org/) 等。混合效应模型的种类非常多，一部分可以在一些流行的 R 包能力范围内解决，其余可以放在更加灵活、扩展性强的框架 Stan 内解决。因此，本章同时介绍 Stan 框架和一些 R 包。 - -本章用到 4 个数据集，其中 `sleepstudy` 和 `cbpp` 均来自 **lme4** 包 [@Bates2015]，分别用于介绍线性混合效应模型和广义线性混合效应模型，`Loblolly` 来自 **datasets** 包，用于介绍非线性混合效应模型。 - -在介绍理论的同时给出 R 语言或 S 语言实现的几本参考书籍。 - -- 《Mixed-Effects Models in S and S-PLUS》[@Pinheiro2000] -- 《Mixed Models: Theory and Applications with R》[@Demidenko2013] -- 《Linear Mixed-Effects Models Using R: A Step-by-Step Approach》[@Andrzej2013] -- 《Linear and Generalized Linear Mixed Models and Their Applications》[@Jiang2021] - -## 线性混合效应模型 {#sec-lmm} - -> I think what we are seeking is the marginal variance-covariance matrix of the parameter estimators (marginal with respect to the random effects random variable, B), which would have the form of the inverse of the crossproduct of a $(q+p)$ by $p$ matrix composed of the vertical concatenation of $-L^{-1}RZXRX^{-1}$ and $RX^{-1}$. (Note: You do *not* want to calculate the first term by inverting $L$, use `solve(L, RZX, system = "L")` -> -> - \[...\] don't even think about using `solve(L)` -> -> - don't!, don't!, don't! -> -> - have I made myself clear? -> -> - don't do that (and we all know that someone will do exactly that for a very large $L$ and then send out messages about "R is SOOOOO SLOOOOW!!!!" :-) ) -> -> --- Douglas Bates [^mixed-effects-models-2] - -[^mixed-effects-models-2]: - -::: callout-tip -1. 一般的模型结构和假设 -2. 一般的模型表达公式 -3. **nlme** 包的函数 `lme()` -4. 公式语法和示例模型表示 -::: - -线性混合效应模型（Linear Mixed Models or Linear Mixed-Effects Models，简称 LME 或 LMM），介绍模型的基础理论，包括一般形式，矩阵表示，参数估计，假设检验，模型诊断，模型评估。参数方法主要是极大似然估计和限制极大似然估计。一般形式如下： - -$$ -\bm{y} = X\bm{\beta} + Z\bm{u} + \bm{\epsilon} -$$ - -其中，$\bm{y}$ 是一个向量，代表响应变量，$X$ 代表固定效应对应的设计矩阵，$\bm{\beta}$ 是一个参数向量，代表固定效应对应的回归系数，$Z$ 代表随机效应对应的设计矩阵，$\bm{u}$ 是一个参数向量，代表随机效应对应的回归系数，$\bm{\epsilon}$ 表示残差向量。 - -一般假定随机向量 $\bm{u}$ 服从多元正态分布，这是无条件分布，随机向量 $\bm{y}|\bm{u}$ 服从多元正态分布，这是条件分布。 - -$$ -\begin{aligned} -\bm{u} &\sim \mathcal{N}(0,\Sigma) \\ -\bm{y}|\bm{u} &\sim \mathcal{N}(X\bm{\beta} + Z\bm{u},\sigma^2W) -\end{aligned} -$$ - -其中，方差协方差矩阵 $\Sigma$ 必须是半正定的，$W$ 是一个对角矩阵。nlme 和 lme4 等 R 包共用一套表示随机效应的公式语法。 - -sleepstudy 数据集来自 lme4 包，是一个睡眠研究项目的实验数据。实验对象都是有失眠情况的人，有的人有严重的失眠问题（一天只有 3 个小时的睡眠时间）。进入实验后的前10 天的情况，记录平均反应时间、睡眠不足的天数。 - -```{r} -data(sleepstudy, package = "lme4") -str(sleepstudy) -``` - -Reaction 表示平均反应时间（毫秒），数值型，Days 表示进入实验后的第几天，数值型，Subject 表示参与实验的个体编号，因子型。 - -```{r} -xtabs(~ Days + Subject, data = sleepstudy) -``` - -每个个体每天产生一条数据，下 @fig-sleepstudy-line 中每条折线代表一个个体。 - -```{r} -#| label: fig-sleepstudy-line -#| fig-cap: sleepstudy 数据集 -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true - -library(ggplot2) -ggplot(data = sleepstudy, aes(x = Days, y = Reaction, group = Subject)) + - geom_line() + - scale_x_continuous(n.breaks = 6) + - theme_bw() + - labs(x = "睡眠不足的天数", y = "平均反应时间") -``` - -对于连续重复测量的数据（continuous repeated measurement outcomes），也叫纵向数据（longitudinal data），针对不同个体 Subject，相比于上图，下面绘制反应时间 Reaction 随睡眠时间 Days 的变化趋势更合适。图中趋势线是简单线性回归的结果，分面展示不同个体Subject 之间对比。 - -```{r} -#| label: fig-sleepstudy-facet -#| fig-cap: 分面展示 sleepstudy 数据集 -#| fig-width: 6 -#| fig-height: 6 -#| fig-showtext: true - -ggplot(data = sleepstudy, aes(x = Days, y = Reaction)) + - geom_point() + - geom_smooth(formula = "y ~ x", method = "lm", se = FALSE) + - scale_x_continuous(n.breaks = 6) + - theme_bw() + - facet_wrap(facets = ~Subject, labeller = "label_both", ncol = 6) + - labs(x = "睡眠不足的天数", y = "平均反应时间") -``` - -### nlme - -考虑两水平的混合效应模型，其中随机截距 $\beta_{0j}$ 和随机斜率 $\beta_{1j}$，指标 $j$ 表示分组的编号，也叫变截距和变斜率模型 - -$$ -\begin{aligned} -\mathrm{Reaction}_{ij} &= \beta_{0j} + \beta_{1j} \cdot \mathrm{Days}_{ij} + \epsilon_{ij} \\ -\beta_{0j} &= \gamma_{00} + U_{0j} \\ -\beta_{1j} &= \gamma_{10} + U_{1j} \\ -\begin{pmatrix} -U_{0j} \\ -U_{1j} -\end{pmatrix} &\sim \mathcal{N} -\begin{bmatrix} -\begin{pmatrix} -0 \\ -0 -\end{pmatrix} -, -\begin{pmatrix} -\tau^2_{00} & \tau_{01} \\ -\tau_{01} & \tau^2_{10} -\end{pmatrix} -\end{bmatrix} \\ -\epsilon_{ij} &\sim \mathcal{N}(0, \sigma^2) \\ -i = 0,1,\cdots,9 &\quad j = 308,309,\cdots, 372. -\end{aligned} -$$ - -下面用 nlme 包 [@Pinheiro2000] 拟合模型。 - -```{r} -library(nlme) -sleep_nlme <- lme(Reaction ~ Days, random = ~ Days | Subject, data = sleepstudy) -summary(sleep_nlme) -``` - -随机效应（Random effects）部分： - -```{r} -# 前 6 个 subject -head(ranef(sleep_nlme)) -``` - -固定效应（Fixed effects）部分： - -```{r} -fixef(sleep_nlme) -``` - -[**ggeffects**](https://github.com/strengejacke/ggeffects) 包的函数 `ggpredict()` 和 `ggeffect()` 可以用来绘制混合效应模型的边际效应（ Marginal Effects），[**ggPMX**](https://github.com/ggPMXdevelopment/ggPMX) 包 可以用来绘制混合效应模型的诊断图。下 @fig-lme-effects 展示关于变量 Days 的边际效应图。 - -```{r} -#| label: fig-lme-effects -#| fig-cap: 边际效应图 -#| fig-showtext: true -#| fig-width: 4.5 -#| fig-height: 4 - -library(ggeffects) -mydf <- ggpredict(sleep_nlme, terms = "Days") -ggplot(mydf, aes(x = x, y = predicted)) + - geom_line() + - geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = 0.2) + - scale_x_continuous(n.breaks = 6) + - theme_bw() + - labs(x = "Days", y = "Reaction") -``` - -```{r} -#| echo: false -#| eval: false - -plot(mydf) -``` - -### MASS - -```{r} -sleep_mass <- MASS::glmmPQL(Reaction ~ Days, - random = ~ Days | Subject, verbose = FALSE, - data = sleepstudy, family = gaussian -) -summary(sleep_mass) -``` - -### lme4 - -```{r} -sleep_lme4 <- lme4::lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) -summary(sleep_lme4) -``` - -### blme - -```{r} -sleep_blme <- blme::blmer( - Reaction ~ Days + (Days | Subject), data = sleepstudy, - control = lme4::lmerControl(check.conv.grad = "ignore"), - cov.prior = NULL) -summary(sleep_blme) -``` - -### brms - -```{r} -#| eval: false -#| echo: true - -sleep_brms <- brms::brm(Reaction ~ Days + (Days | Subject), data = sleepstudy) -summary(sleep_brms) -``` - -``` markdown - Family: gaussian - Links: mu = identity; sigma = identity -Formula: Reaction ~ Days + (Days | Subject) - Data: sleepstudy (Number of observations: 180) - Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup draws = 4000 - -Group-Level Effects: -~Subject (Number of levels: 18) - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sd(Intercept) 27.03 6.60 15.88 42.13 1.00 1728 2469 -sd(Days) 6.61 1.50 4.18 9.97 1.00 1517 2010 -cor(Intercept,Days) 0.08 0.29 -0.46 0.65 1.00 991 1521 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -Intercept 251.26 7.42 236.27 266.12 1.00 1982 2687 -Days 10.36 1.77 6.85 13.85 1.00 1415 1982 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sigma 25.88 1.54 22.99 29.06 1.00 3204 2869 - -Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS -and Tail_ESS are effective sample size measures, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -```{r} -#| eval: false -#| echo: true - -# predictions -conds <- brms::make_conditions(sleep_brms, "Subject") -sleep_brms |> - brms::marginal_effects( - re_formula = NULL, - conditions = conds - ) |> - plot(points = TRUE, ncol = 6) -``` - -### MCMCglmm - -MCMCglmm 包拟合变截距、变斜率模型，随机截距和随机斜率之间存在相关性。 - -```{r} -## 变截距、变斜率模型 -prior1 <- list( - R = list(V = 1, fix = 1), - G = list(G1 = list(V = diag(2), nu = 0.002)) -) -set.seed(20232023) -sleep_mcmcglmm <- MCMCglmm::MCMCglmm( - Reaction ~ Days, random = ~ us(1 + Days):Subject, prior = prior1, - data = sleepstudy, family = "gaussian", verbose = FALSE -) -summary(sleep_mcmcglmm) -``` - -固定随机效应 R-structure 方差。固定效应 Location effects 截距 (Intercept) 为 251.374，斜率 Days 为 10.419 。 - -### INLA - -将数据集 sleepstudy 中的 Reaction 除以 1000，目的是数值稳定性，减小迭代序列的相关性。先考虑变截距模型 - -```{r} -library(INLA) -inla.setOption(short.summary = TRUE) -# 做尺度变换 -sleepstudy$Reaction <- sleepstudy$Reaction / 1000 -# 变截距 -sleep_inla1 <- inla(Reaction ~ Days + f(Subject, model = "iid", n = 18), - family = "gaussian", data = sleepstudy) -# 输出结果 -summary(sleep_inla1) -``` - -再考虑变截距和变斜率模型 - -```{r} -# https://inla.r-inla-download.org/r-inla.org/doc/latent/iid.pdf -# 二维高斯随机效应的先验为 Wishart prior -sleepstudy$Subject <- as.integer(sleepstudy$Subject) -sleepstudy$slopeid <- 18 + sleepstudy$Subject -# 变截距、变斜率 -sleep_inla2 <- inla( - Reaction ~ 1 + Days + f(Subject, model = "iid2d", n = 2 * 18) + f(slopeid, Days, copy = "Subject"), - data = sleepstudy, family = "gaussian" -) -# 输出结果 -summary(sleep_inla2) -``` - -## 广义线性混合效应模型 {#sec-glmm} - -当响应变量分布不再是高斯分布，线性混合效应模型就扩展到广义线性混合效应模型。有一些 R 包可以拟合此类模型，MASS 包的函数 `glmmPQL()` ，**mgcv** 包的函数 `gam()`，lme4 包的函数 `glmer()` ，GLMMadaptive 包的函数 `mixed_model()` ，brms 包的函数 `brm()` 等。 - -| 响应变量分布 | MASS | mgcv | lme4 | GLMMadaptive | brms | -|--------------|--------|------|------|--------------|------| -| 伯努利分布 | 支持 | 支持 | 支持 | 支持 | 支持 | -| 二项分布 | 支持 | 支持 | 支持 | 支持 | 支持 | -| 泊松分布 | 支持 | 支持 | 支持 | 支持 | 支持 | -| 负二项分布 | 不支持 | 支持 | 支持 | 支持 | 支持 | -| 伽马分布 | 支持 | 支持 | 支持 | 支持 | 支持 | - -: 响应变量的分布 {#tbl-response} - -函数 `glmmPQL()` 支持的分布族见函数 `glm()` 的参数 `family` ，lme4 包的函数 `glmer.nb()` 和 GLMMadaptive 包的函数 `negative.binomial()` 都可用于拟合响应变量服从负二项分布的情况。除了这些常规的分布，GLMMadaptive 和 brms 包还支持许多常见的分布，比如零膨胀的泊松分布、二项分布等，还可以自定义分布。 - -- 伯努利分布 `family = binomial(link = "logit")` -- 二项分布 `family = binomial(link = "logit")` -- 泊松分布 `family = poisson(link = "log")` -- 负二项分布 `lme4::glmer.nb()` 或 `GLMMadaptive::negative.binomial()` -- 伽马分布 `family = Gamma(link = "inverse")` - -[GLMMadaptive](https://github.com/drizopoulos/GLMMadaptive) 包 [@Dimitris2023] 的主要函数 `mixed_model()` 是用来拟合广义线性混合效应模型的。下面以牛传染性胸膜肺炎（Contagious bovine pleuropneumonia，简称 CBPP）数据 cbpp 介绍函数 `mixed_model()` 的用法，该数据集来自 lme4 包。 - -```{r} -data(cbpp, package = "lme4") -str(cbpp) -``` - -herd 牛群编号，period 时间段，incidence 感染的数量，size 牛群大小。疾病在种群内扩散 - -```{r} -#| label: fig-glmm-cbpp -#| fig-cap: 感染比例随变量 herd 和 period 的变化 -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 3 - -ggplot(data = cbpp, aes(x = herd, y = period)) + - geom_tile(aes(fill = incidence / size)) + - scale_fill_viridis_c(label = scales::percent_format(), - option = "C", name = "") + - theme_minimal() -``` - -### MASS - -```{r} -cbpp_mass <- MASS::glmmPQL( - cbind(incidence, size - incidence) ~ period, - random = ~ 1 | herd, verbose = FALSE, - data = cbpp, family = binomial("logit") -) -summary(cbpp_mass) -``` - -### GLMMadaptive - -```{r} -library(GLMMadaptive) -cbpp_glmmadaptive <- mixed_model( - fixed = cbind(incidence, size - incidence) ~ period, - random = ~ 1 | herd, data = cbpp, family = binomial(link = "logit") -) -summary(cbpp_glmmadaptive) -``` - -### glmmTMB - -```{r} -cbpp_glmmtmb <- glmmTMB::glmmTMB( - cbind(incidence, size - incidence) ~ period + (1 | herd), - data = cbpp, family = binomial, REML = TRUE -) -summary(cbpp_glmmtmb) -``` - -### lme4 - -```{r} -cbpp_lme4 <- lme4::glmer( - cbind(incidence, size - incidence) ~ period + (1 | herd), - family = binomial("logit"), data = cbpp -) -summary(cbpp_lme4) -``` - -### mgcv - -或使用 **mgcv** 包，可以得到近似的结果。随机效应部分可以看作可加的惩罚项 - -```{r} -#| message: false - -library(mgcv) -cbpp_mgcv <- gam( - cbind(incidence, size - incidence) ~ period + s(herd, bs = "re"), - data = cbpp, family = binomial(link = "logit"), method = "REML" -) -summary(cbpp_mgcv) -``` - -下面给出随机效应的标准差的估计及其上下限，和前面 **GLMMadaptive** 包和 **lme4** 包给出的结果也是接近的。 - -```{r} -gam.vcomp(cbpp_mgcv) -``` - -### blme - -```{r} -cbpp_blme <- blme::bglmer( - cbind(incidence, size - incidence) ~ period + (1 | herd), - family = binomial("logit"), data = cbpp -) -summary(cbpp_blme) -``` - -### brms - -表示二项分布，公式语法与前面的 lme4 等包不同。 - -```{r} -#| eval: false -#| echo: true - -cbpp_brms <- brms::brm( - incidence | trials(size) ~ period + (1 | herd), - family = binomial("logit"), data = cbpp -) -summary(cbpp_brms) -``` - -``` markdown - Family: binomial - Links: mu = logit -Formula: incidence | trials(size) ~ period + (1 | herd) - Data: cbpp (Number of observations: 56) - Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup draws = 4000 - -Group-Level Effects: -~herd (Number of levels: 15) - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sd(Intercept) 0.76 0.22 0.39 1.29 1.00 1483 1962 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -Intercept -1.40 0.26 -1.92 -0.88 1.00 2440 2542 -period2 -1.00 0.31 -1.63 -0.41 1.00 5242 2603 -period3 -1.14 0.34 -1.83 -0.50 1.00 4938 3481 -period4 -1.61 0.44 -2.49 -0.81 1.00 4697 2966 - -Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS -and Tail_ESS are effective sample size measures, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -### MCMCglmm - -```{r} -set.seed(20232023) -cbpp_mcmcglmm <- MCMCglmm::MCMCglmm( - cbind(incidence, size - incidence) ~ period, random = ~herd, - data = cbpp, family = "multinomial2", verbose = FALSE -) -summary(cbpp_mcmcglmm) -``` - -对于服从非高斯分布的响应变量，MCMCglmm 总是假定存在过度离散的情况，即存在一个与分类变量无关的随机变量，或者说存在一个残差服从正态分布的随机变量（效应），可以看作测量误差，这种假定对真实数据建模是有意义的，所以，与以上 MCMCglmm 代码等价的 lme4 包模型代码如下： - -```{r} -cbpp$id <- as.factor(1:dim(cbpp)[1]) -cbpp_lme4 <- lme4::glmer( - cbind(incidence, size - incidence) ~ period + (1 | herd) + (1 | id), - family = binomial, data = cbpp -) -summary(cbpp_lme4) -``` - -贝叶斯的结果与频率派的结果相近，但还是有明显差异。MCMCglmm 总是假定存在残差，残差的分布服从 0 均值的高斯分布，下面将残差分布的方差固定，重新拟合模型，之后再根据残差方差为 0 调整估计结果。 - -```{r} -prior2 <- list( - R = list(V = 1, fix = 1), - G = list(G1 = list(V = 1, nu = 0.002)) -) -set.seed(20232023) -cbpp_mcmcglmm <- MCMCglmm::MCMCglmm( - cbind(incidence, size - incidence) ~ period, random = ~herd, prior = prior2, - data = cbpp, family = "multinomial2", verbose = FALSE -) -summary(cbpp_mcmcglmm) -``` - -下面对结果进行调整 - -```{r} -# 调整常数 -c2 <- ((16 * sqrt(3)) / (15 * pi))^2 -# 固定效应 -cbpp_sol_adj <- cbpp_mcmcglmm$Sol / sqrt(1 + c2 * cbpp_mcmcglmm$VCV[, 2]) -summary(cbpp_sol_adj) -# 方差成分 -cbpp_vcv_adj <- cbpp_mcmcglmm$VCV / (1 + c2 * cbpp_mcmcglmm$VCV[, 2]) -summary(cbpp_vcv_adj) -``` - -可以看到，调整后固定效应的部分和前面 lme4 等的输出非常接近，方差成分仍有差距。 - -### INLA - -表示二项分布，公式语法与前面的 brms 包和 lme4 等包都不同。 - -```{r} -cbpp_inla <- inla( - formula = incidence ~ period + f(herd, model = "iid", n = 15), - Ntrials = size, family = "binomial", data = cbpp -) -summary(cbpp_inla) -``` - -## 非线性混合效应模型 {#sec-nlmm} - -Loblolly 数据集来自 R 内置的 datasets 包，记录了 14 颗火炬树种子的生长情况。 - -```{r} -#| label: tbl-Loblolly -#| tbl-cap: Loblolly 数据集 -#| echo: false - -loblolly_df <- reshape(Loblolly, idvar = "Seed", timevar = "age", - v.names = "height", direction = "wide", sep = "") - -knitr::kable(loblolly_df, - row.names = FALSE, align = "c", - col.names = gsub("(height)", "", names(loblolly_df)) - ) -``` - -火炬树种子基本决定了树的长势，不同种子预示最后的高度，并且在生长期也是很稳定地生长 - -```{r} -#| label: fig-Loblolly -#| fig-cap: 火炬松树的高度（英尺）随时间（年）的变化 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true - -ggplot(data = Loblolly, aes(x = age, y = height, color = Seed)) + - geom_point() + - geom_line() + - theme_bw() + - labs(x = "age (yr)", y = "height (ft)") -``` - -### nlme - -非线性回归 - -```{r} -nfm1 <- nls(height ~ SSasymp(age, Asym, R0, lrc), - data = Loblolly, subset = Seed == 329) -summary(nfm1) -``` - -非线性函数 `SSasymp()` 的内容如下 - -$$ -\mathrm{Asym}+(\mathrm{R0}-\mathrm{Asym})\times\exp\big(-\exp(\mathrm{lrc})\times\mathrm{input}\big) -$$ - -其中，$\mathrm{Asym}$ 、$\mathrm{R0}$ 、$\mathrm{lrc}$ 是参数，$\mathrm{input}$ 是输入值。 - -示例来自 **nlme** 包的函数 `nlme()` 帮助文档 - -```{r} -nfm2 <- nlme(height ~ SSasymp(age, Asym, R0, lrc), - data = Loblolly, - fixed = Asym + R0 + lrc ~ 1, - random = Asym ~ 1, - start = c(Asym = 103, R0 = -8.5, lrc = -3.3) -) -summary(nfm2) -# 更新模型的随机效应部分 -nfm3 <- update(nfm2, random = pdDiag(Asym + lrc ~ 1)) -summary(nfm3) -``` - -### lme4 - -lme4 的公式语法是与 nlme 包不同的。 - -```{r} -lob_lme4 <- lme4::nlmer( - height ~ SSasymp(age, Asym, R0, lrc) ~ (Asym + R0 + lrc) + (Asym | Seed), - data = Loblolly, - start = c(Asym = 103, R0 = -8.5, lrc = -3.3) -) -summary(lob_lme4) -``` - -### brms - -根据数据的情况，设定参数的先验分布 - -```{r} -#| eval: false -#| echo: true - -lob_prior <- c( - brms::set_prior("normal(101, 0.1)", nlpar = "Asym", lb = 100, ub = 102), - brms::set_prior("normal(-8, 1)", nlpar = "R0", lb = -10), - brms::set_prior("normal(-3, 3)", nlpar = "lrc", lb = -9), - brms::set_prior("normal(3, 0.2)", class = "sigma") -) -``` - -根据模型表达式编码 - -```{r} -#| eval: false -#| echo: true - -lob_formula <- brms::bf( - height ~ Asym + (R0 - Asym) * exp( - exp(lrc) * age), - # Nonlinear variables - # Fixed effects: Asym R0 lrc - R0 + lrc ~ 1, - # Nonlinear variables - # Random effects: Seed - Asym ~ 1 + (1 | Seed), - # Nonlinear fit - nl = TRUE -) -``` - -```{r} -#| eval: false -#| echo: true - -lob_brms <- brms::brm(lob_formula, data = Loblolly, prior = lob_prior) -summary(lob_brms) -``` - -``` markdown - Family: gaussian - Links: mu = identity; sigma = identity -Formula: height ~ Asym + (R0 - Asym) * exp(-exp(lrc) * age) - R0 ~ 1 - lrc ~ 1 - Asym ~ 1 + (1 | Seed) - Data: Loblolly (Number of observations: 84) - Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup draws = 4000 - -Group-Level Effects: -~Seed (Number of levels: 14) - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sd(Asym_Intercept) 3.90 1.09 2.24 6.51 1.00 1033 1647 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -R0_Intercept -8.53 0.43 -9.37 -7.68 1.00 2236 1434 -lrc_Intercept -3.23 0.02 -3.27 -3.20 1.00 981 1546 -Asym_Intercept 101.00 0.10 100.80 101.20 1.00 4443 2907 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sigma 1.68 0.25 1.20 2.17 1.00 1910 2258 - -Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS -and Tail_ESS are effective sample size measures, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -## 模拟实验比较（补充） {#sec-mixed-effects-simulation} - -从广义线性混合效应模型生成模拟数据，用至少 6 个不同的 R 包估计模型参数，比较和归纳不同估计方法和实现算法的效果。举例：带漂移项的泊松型广义线性混合效应模型。$y_{ij}$ 表示响应变量，$\bm{u}$ 表示随机效应，$o_{ij}$ 表示漂移项。 - -$$ -\begin{aligned} -y_{ij}|\bm{u} &\sim \mathrm{Poisson}(o_{ij}\lambda_{ij}) \\ -\log(\lambda_{ij}) &= \beta_{ij}x_{ij} + u_{j} \\ -u_j &\sim \mathcal{N}(0, \sigma^2) \\ -i = 1,2,\ldots, n &\quad j = 1,2,\ldots,q -\end{aligned} -$$ - -首先准备数据 - -```{r} -set.seed(2023) -Ngroups <- 25 # 一个随机效应分 25 个组 -NperGroup <- 100 # 每个组 100 个观察值 -# 样本量 -N <- Ngroups * NperGroup -# 截距和两个协变量的系数 -beta <- c(0.5, 0.3, 0.2) -# 两个协变量 -X <- MASS::mvrnorm(N, mu = rep(0, 2), Sigma = matrix(c(1, 0.8, 0.8, 1), 2)) -# 漂移项 -o <- rep(c(2, 4), each = N / 2) -# 分 25 个组 每个组 100 个观察值 -g <- factor(rep(1:Ngroups, each = NperGroup)) -u <- rnorm(Ngroups, sd = .5) # 随机效应的标准差 0.5 -# 泊松分布的期望 -lambda <- o * exp(cbind(1, X) %*% beta + u[g]) -# 响应变量的值 -y <- rpois(N, lambda = lambda) -# 模拟的数据集 -sim_data <- data.frame(y, X, o, g) -colnames(sim_data) <- c("y", "x1", "x2", "o", "g") -``` - -### lme4 - -```{r} -# 模型拟合 -fit_lme4 <- lme4::glmer(y ~ x1 + x2 + (1 | g), - data = sim_data, offset = log(o), family = poisson(link = "log") -) -summary(fit_lme4) -``` - -### GLMMadaptive - -对随机效应采用 adaptive Gauss-Hermite quadrature 积分 - -```{r} -library(GLMMadaptive) -fit_glmmadaptive <- mixed_model( - fixed = y ~ x1 + x2 + offset(log(o)), - random = ~ 1 | g, data = sim_data, - family = poisson(link = "log") -) -summary(fit_glmmadaptive) -``` - -### glmmTMB - -```{r} -fit_glmmtmb <- glmmTMB::glmmTMB( - y ~ x1 + x2 + (1 | g), offset = log(o), - data = sim_data, family = poisson, REML = TRUE -) -summary(fit_glmmtmb) -``` - -### hglm - -hglm 包的名称是 Hierarchical Generalized Linear Models 的首字母缩写拼成的。 - -```{r} -# extended quasi likelihood (EQL) method -fit_hglm <- hglm::hglm( - fixed = y ~ x1 + x2, random = ~ 1 | g, - family = poisson(link = "log"), - offset = log(o), data = sim_data -) -summary(fit_hglm) -``` - -### glmmML - -[glmmML](https://CRAN.R-project.org/package=glmmML) 包 Maximum Likelihood and numerical integration via Gauss-Hermite quadrature - -```{r} -#| eval: false - -fit_glmmml <- glmmML::glmmML( - formula = y ~ x1 + x2, family = poisson, - data = sim_data, offset = log(o), cluster = g -) -summary(fit_glmmml) -``` - -``` markdown -Call: glmmML::glmmML(formula = y ~ x1 + x2, family = poisson, data = sim_data, cluster = g, offset = log(o)) - - - coef se(coef) z Pr(>|z|) -(Intercept) 0.556 0.1281 4.34 1.4e-05 -x1 0.284 0.0128 22.21 0.0e+00 -x2 0.209 0.0129 16.11 0.0e+00 - -Scale parameter in mixing distribution: 0.638 gaussian -Std. Error: 0.0865 - - LR p-value for H_0: sigma = 0: 0 - -Residual deviance: 2770 on 2496 degrees of freedom AIC: 2780 -``` - -### glmm - -[glmm](https://github.com/knudson1/glmm) 包对随机效应的积分采用 Monte Carlo Likelihood Approximation 近似 - -```{r} -#| eval: false - -# 对迭代时间没有给出预估，一旦执行，不知道什么时候会跑完 -set.seed(2023) -# 设置双核并行迭代 -clust <- parallel::makeCluster(2) -fit_glmm <- glmm::glmm(y ~ x1 + x2 + offset(log(o)), - random = list(~ 1 + g), # 随机效应 - varcomps.names = "G", # 给随机效应取个名字 - data = sim_data, - family.glmm = glmm::poisson.glmm, # 泊松型 - m = 10^4, debug = TRUE, cluster = clust -) -parallel::stopCluster(clust) -summary(fit_glmm) -``` - -glmm 包的帮助文档中的示例如下，可复现结果，运行时间 1-2 分钟。 - -```{r} -#| eval: false - -set.seed(1234) -clust <- makeCluster(2) -sal <- glmm( - Mate ~ 0 + Cross, random = list(~ 0 + Female, ~ 0 + Male), - varcomps.names = c("F", "M"), data = salamander, - family.glmm = bernoulli.glmm, m = 10^4, debug = TRUE, cluster = clust -) -summary(sal) -stopCluster(clust) -``` - -``` markdown -Call: -glmm(fixed = Mate ~ 0 + Cross, random = list(~0 + Female, ~0 + Male), - varcomps.names = c("F", "M"), data = salamander, - family.glmm = bernoulli.glmm, m = 10^4, debug = TRUE, cluster = clust) - -Link is: "logit (log odds)" - -Fixed Effects: - Estimate Std. Error z value Pr(>|z|) -CrossR/R 1.230 0.300 4.045 5.24e-05 *** -CrossR/W 0.320 0.267 1.198 0.23077 -CrossW/R -2.000 0.330 -6.042 1.52e-09 *** -CrossW/W 0.920 0.300 3.084 0.00204 ** ---- -Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 - -Variance Components for Random Effects (P-values are one-tailed): - Estimate Std. Error z value Pr(>|z|)/2 -F 1.46 0.31 4.695 1.33e-06 *** -M 1.64 0.33 4.918 4.36e-07 *** ---- -Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 -``` - -### gee - -gee 包采用广义估计方程（Generalized Estimation Equation）方法 - -```{r} -#| eval: false - -fit_gee <- gee::gee(y ~ x1 + x2 + offset(log(o)), id = g, - data = sim_data, family = poisson(link = "log"), corstr = "exchangeable" -) -# 输出 -fit_gee -``` - -``` markdown - GEE: GENERALIZED LINEAR MODELS FOR DEPENDENT DATA - gee S-function, version 4.13 modified 98/01/27 (1998) - -Model: - Link: Logarithm - Variance to Mean Relation: Poisson - Correlation Structure: Exchangeable - -Call: -gee::gee(formula = y ~ x1 + x2 + offset(log(o)), id = g, data = sim_data, - family = poisson(link = "log"), corstr = "exchangeable") - -Number of observations : 2500 -Maximum cluster size : 100 - -Coefficients: -(Intercept) x1 x2 - 0.6098935 0.3003721 0.2165055 - -Estimated Scale Parameter: 4.979956 -Number of Iterations: 3 - -Working Correlation[1:4,1:4] - [,1] [,2] [,3] [,4] -[1,] 1.0000000 0.7220617 0.7220617 0.7220617 -[2,] 0.7220617 1.0000000 0.7220617 0.7220617 -[3,] 0.7220617 0.7220617 1.0000000 0.7220617 -[4,] 0.7220617 0.7220617 0.7220617 1.0000000 - -Returned Error Value: -[1] 0 -``` - -输出结果中，尺度参数（Estimated Scale Parameter）的估计结果与随机效应的方差的联系？ - -### geepack - -[geepack](https://cran.r-project.org/package=geepack) 包类似 **gee** 包。 - -```{r} -#| eval: false - -fit_geepack <- geepack::geeglm( - formula = y ~ x1 + x2, family = poisson(link = "log"), - id = g, offset = log(o), data = sim_data, - corstr = "exchangeable", scale.fix = FALSE -) -summary(fit_geepack) -``` - -``` markdown -Call: -geepack::geeglm(formula = y ~ x1 + x2, family = poisson(link = "log"), - data = sim_data, offset = log(o), id = g, corstr = "exchangeable", - scale.fix = FALSE) - - Coefficients: - Estimate Std.err Wald Pr(>|W|) -(Intercept) 0.60964 0.17310 12.4 0.000428 *** -x1 0.30040 0.02353 163.1 < 2e-16 *** -x2 0.21653 0.01458 220.6 < 2e-16 *** ---- -Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 - -Correlation structure = exchangeable -Estimated Scale Parameters: - - Estimate Std.err -(Intercept) 4.975 1.39 - Link = identity - -Estimated Correlation Parameters: - Estimate Std.err -alpha 0.723 0.06703 -Number of clusters: 25 Maximum cluster size: 100 -``` - -### blme - -blme 包采用贝叶斯估计 - -```{r} -fit_blme <- blme::bglmer( - formula = y ~ x1 + x2 + (1 | g), - data = sim_data, offset = log(o), - family = poisson(link = "log") -) -summary(fit_blme) -``` - -GLMMadaptive、glmmML、gee、geepack 和 lme4 的模型输出结果是接近的。 - -### brms - -```{r} -#| eval: false - -fit_brms <- brms::brm( - y ~ x1 + x2 + (1 | g) + offset(log(o)), - data = sim_data, family = poisson(link = "log"), - silent = 2, refresh = 0, seed = 20232023 -) -summary(fit_brms) -``` - -``` markdown - Family: poisson - Links: mu = log -Formula: y ~ x1 + x2 + (1 | g) + offset(log(o)) - Data: sim_data (Number of observations: 2500) - Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup draws = 4000 - -Group-Level Effects: -~g (Number of levels: 25) - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -sd(Intercept) 0.68 0.11 0.51 0.94 1.01 295 491 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS -Intercept 0.56 0.14 0.31 0.85 1.02 297 344 -x1 0.28 0.01 0.26 0.31 1.00 1053 1625 -x2 0.21 0.01 0.18 0.23 1.01 1071 1298 - -Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS -and Tail_ESS are effective sample size measures, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -``` - -### MCMCglmm - -MCMCglmm 包采用贝叶斯估计 - -```{r} -prior1 <- list( - R = list(V = 1, fix = 1), - G = list(G1 = list(V = 1, nu = 0.002)) -) -set.seed(20232023) -fit_mcmcglmm <- MCMCglmm::MCMCglmm( - fixed = y ~ x1 + x2 + offset(log(o)), - random = ~g, family = "poisson", - data = sim_data, verbose = FALSE, prior = prior1 -) -summary(fit_mcmcglmm) -``` - -随机效应的方差 G-structure 为 0.5443，则标准差为 0.738。 - -对于离散型响应变量，MCMCglmm 包默认添加一个可加的随机变量表示过度离散，如何将其去掉？将残差方差设置为常数，不再作为参数去估计，`fix = 1` 表示在 R-structure 中固定方差， `V = 1` 表示残差方差为 1。 - -```{r} -#| label: fig-fit-mcmcglmm -#| fig-cap: 方差协方差参数的后验分布 -#| fig-showtext: true -#| fig-width: 6 -#| fig-height: 6 - -# 固定效应参数的后验分布 -# plot(fit_mcmcglmm$Sol) -plot(fit_mcmcglmm$VCV) -``` - -根据响应变量的服从的分布类型，确定调整因子。固定效应乘以调整因子的平方根，随机效应的方差乘以调整因子，详见 [@diggle2002] 第 136-137 页。二项分布联系函数对应的调整因子如下： - -$$ -\frac{1 + c^2\sigma^2_{\epsilon}}{1 + c^2\sigma^2_{\mathrm{units}}} -$$ - -其中， $c$ 是与联系函数有关的常数，二项分布联系函数对应 $c = 16\sqrt{3}/(15\pi)$。此处，假定 $\sigma^2_{\epsilon} = 0$ ，代入泊松分布对应的调整因子。调整后的固定效应（回归系数）、随机效应的方差如下： - -```{r} -#| eval: false - -# 调整公式中的调整因子 c2 取决于联系函数 -c2 <- ((16 * sqrt(3))/(15 * pi))^2 # 需要修改为泊松分布对应的值 -# 固定效应的调整 -adjusted_sol <- fit_mcmcglmm$Sol / sqrt(1 + c2 * fit_mcmcglmm$VCV[, 2]) -plot(adjusted_sol) -# 随机效应的方差调整 -adjusted_vcv <- fit_mcmcglmm$VCV[, 1] / (1 + c2 * fit_mcmcglmm$VCV[, 2]) -plot(adjusted_vcv) -``` - -### INLA - -```{r} -library(INLA) -fit_inla <- inla( - formula = y ~ x1 + x2 + f(g, model = "iid", n = 25), - E = o, family = "poisson", data = sim_data -) -summary(fit_inla) -``` - -随机效应的标准（偏）差为 $1/\sqrt{\mathrm{Precision}}$ ，即 0.625。 - -## 总结 {#sec-mixed-effects-summary} - -本章介绍函数 `MASS::glmmPQL()`、 `nlme::lme()`、`lme4::lmer()` 和 `brms::brm()` 的用法，以及它们求解线性混合效应模型的区别和联系。在贝叶斯估计方法中，**brms** 包和 **INLA** 包都支持非常丰富的模型种类，前者是贝叶斯精确推断，后者是贝叶斯近似推断，**brms** 基于概率编程语言 Stan 框架打包了许多模型的 Stan 实现，INLA 基于求解随机偏微分方程的有限元方法和拉普拉斯近似技巧，将各类常见统计模型统一起来，计算速度快，计算结果准确。 - -1. 函数 `nlme::lme()` 提供极大似然估计和限制极大似然估计。 -2. 函数 `MASS::glmmPQL()` 惩罚拟似然估计，MASS 是依赖 nlme 包， nlme 不支持模型中添加漂移项，所以函数 `glmmPQL()` 也不支持添加漂移项。 -3. 函数 `lme4::lmer()` 拉普拉斯近似关于随机效应的高维积分。 -4. 函数 `brms::brm()` 汉密尔顿蒙特卡罗抽样。HMC 方法结合自适应步长的采样器 NUTS 来抽样。 -5. 函数 `INLA::inla()` 集成嵌套拉普拉斯近似。 - -| 模型 | nlme | MASS | lme4 | GLMMadaptive | brms | -|------------|------------|------------|------------|------------|------------| -| 线性混合效应模型 | `lme()` | `glmmPQL()` | `lmer()` | 不支持 | `brm()` | -| 广义线性混合效应模型 | 不支持 | `glmmPQL()` | `glmer()` | `mixed_model()` | `brm()` | -| 非线性混合效应模型 | `nlme()` | 不支持 | `nlmer()` | 不支持 | `brm()` | - -: 混合效应模型及相关 R 包拟合函数 {#tbl-mixed-models} - -通过对频率派和贝叶斯派方法的比较，发现一些有意思的结果。与 Stan 不同，INLA 包做近似贝叶斯推断，计算效率很高。 - -INLA 软件能处理上千个高斯随机效应，但最多只能处理 15 个超参数，因为 INLA 使用 CCD 处理超参数。如果使用 MCMC 处理超参数，就有可能处理更多的超参数，Daniel Simpson 等把 Laplace approximation 带入 Stan，这样就可以处理上千个超参数。 更多理论内容见 2009 年 INLA 诞生的[论文](https://inla.r-inla-download.org/r-inla.org/papers/inla-rss.pdf)和《Advanced Spatial Modeling with Stochastic Partial Differential Equations Using R and INLA》中第一章的估计方法 [CCD](https://becarioprecario.bitbucket.io/spde-gitbook/ch-INLA.html#estimation-method)。 - -## 习题 {#sec-mixed-effects-models-exercise} - -1. 基于奥克兰火山地形数据集 volcano ，随机拆分成训练数据和测试数据，训练数据可以看作采样点的观测数据，建立高斯过程回归模型，比较测试数据与未采样的位置上的预测数据，在计算速度、准确度、易用性等方面总结 Stan 和 INLA 的特点。 - -2. 基于 `PlantGrowth` 数据集，比较将 `group` 变量视为随机变量与随机效应的异同？ - - ```{r} - #| eval: false - - fit_lm <- lm(weight ~ group, data = PlantGrowth) - summary(fit_lm) - fit_lme <- nlme::lme(weight ~ 1, random = ~ 1 | group, data = PlantGrowth) - summary(fit_lme) - fit_lme4 <- lme4::lmer(weight ~ 1 + (1 | group), data = PlantGrowth) - summary(fit_lme4) - ``` - -3. **MASS** 包的数据集 epil 记录癫痫发作的次数及病人的特征，请建立混合效应模型分析癫痫病发作的风险与病人特征之间的关系。 - - ```{r} - #| eval: false - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - data(epil, package = "MASS") - epil_glm <- glm(y ~ lbase * trt + lage + V4, - family = poisson, data = epil - ) - summary(epil_glm) - - epil_mass <- MASS::glmmPQL(y ~ lbase * trt + lage + V4, - random = ~ 1 | subject, family = poisson, data = epil - ) - summary(epil_mass) - - epil_lme4 <- lme4::glmer( - y ~ lbase * trt + lage + V4 + (1 | subject), - family = poisson, data = epil - ) - summary(epil_lme4) - - epil_glmmtmb <- glmmTMB::glmmTMB( - y ~ lbase * trt + lage + V4 + (1 | subject), - data = epil, family = poisson, REML = TRUE - ) - summary(epil_glmmtmb) - - epil_glmmadaptive <- GLMMadaptive::mixed_model( - fixed = y ~ lbase * trt + lage + V4, - random = ~ 1 | subject, data = epil, - family = poisson() - ) - summary(epil_glmmadaptive) - ``` - -4. 基于数据集 Puromycin 分析酶促反应的反应速率（提示：Michaelis-Menten 模型和函数 `SSmicmen()`）。 - - ```{r} - #| label: fig-Puromycin - #| fig-cap: Puromycin 反应速率变化趋势 - #| fig-width: 5 - #| fig-height: 4 - #| fig-showtext: true - - ggplot(data = Puromycin, aes(x = conc, y = rate, color = state)) + - geom_point() + - geom_line() + - theme_minimal() + - labs( - x = "Substrate concentration (ppm)", - y = "Reaction velocity (counts/min/min)" - ) - ``` - -5. 基于 **MASS** 包的地形数据集 topo，建立高斯过程回归模型，比较贝叶斯预测与克里金插值预测的效果。 - - ```{r} - #| eval: false - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - data(topo, package = "MASS") - set.seed(20232023) - nchains <- 2 # 2 条迭代链 - # 给每条链设置不同的参数初始值 - inits_data_gaussian <- lapply(1:nchains, function(i) { - list( - beta = rnorm(1), - sigma = runif(1), - phi = runif(1), - tau = runif(1) - ) - }) - # 预测区域网格化 - nx <- ny <- 27 - topo_grid_df <- expand.grid( - x = seq(from = 0, to = 6.5, length.out = nx), - y = seq(from = 0, to = 6.5, length.out = ny) - ) - # 对数高斯模型 - topo_gaussian_d <- list( - N1 = nrow(topo), # 观测记录的条数 - N2 = nrow(topo_grid_df), - D = 2, # 2 维坐标 - x1 = topo[, c("x", "y")], # N x 2 坐标矩阵 - x2 = topo_grid_df[, c("x", "y")], - y1 = topo[, "z"] # N 向量 - ) - library(cmdstanr) - # 编码 - mod_topo_gaussian <- cmdstan_model( - stan_file = "code/gaussian_process_pred.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) - ) - # 高斯过程回归模型 - fit_topo_gaussian <- mod_topo_gaussian$sample( - data = topo_gaussian_d, # 观测数据 - init = inits_data_gaussian, # 迭代初值 - iter_warmup = 500, # 每条链预处理迭代次数 - iter_sampling = 1000, # 每条链总迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = 2, # 指定 CPU 核心数，可以给每条链分配一个 - threads_per_chain = 1, # 每条链设置一个线程 - show_messages = FALSE, # 不显示迭代的中间过程 - refresh = 0, # 不显示采样的进度 - output_dir = "data-raw/", - seed = 20232023 - ) - # 诊断 - fit_topo_gaussian$diagnostic_summary() - # 对数高斯模型 - fit_topo_gaussian$summary( - variables = c("lp__", "beta", "sigma", "phi", "tau"), - .num_args = list(sigfig = 4, notation = "dec") - ) - # 未采样的位置的预测值 - ypred <- fit_topo_gaussian$summary(variables = "ypred", "mean") - # 预测值 - topo_grid_df$ypred <- ypred$mean - # 整理数据 - library(sf) - topo_grid_sf <- st_as_sf(topo_grid_df, coords = c("x", "y"), dim = "XY") - library(stars) - # 26x26 的网格 - topo_grid_stars <- st_rasterize(topo_grid_sf, nx = 26, ny = 26) - - library(ggplot2) - ggplot() + - geom_stars(data = topo_grid_stars, aes(fill = ypred)) + - scale_fill_viridis_c(option = "C") + - theme_bw() - ``` diff --git a/notations.qmd b/notations.qmd deleted file mode 100644 index 6d65493f..00000000 --- a/notations.qmd +++ /dev/null @@ -1,79 +0,0 @@ -# 数学符号 {#sec-math-notations} - -::: hidden -$$ - \def\bm#1{{\boldsymbol #1}} -$$ -::: - -| 符号 | 含义 | -|--------------------------|----------------------| -| $\mathbb{R}^n$ | $n$ 维实数 | -| $\mathbb{R}^{n\times p}$ | $n\times p$ 维实矩阵 | -| $\mathbb{Z}$ | 整数 | -| $\mathcal{N}$ | 正态分布 | -| $\mathcal{D}$ | 研究区域 | -| $\mathcal{S}$ | 随机过程 | -| $\mathcal{G}$ | 图 | -| $\mathcal{L}$ | 似然 | -| $\mathrm{MVN}$ | 多元正态分布 | -| $\Sigma$ | 协方差矩阵 | -| $x$ | 标量 | -| $\bm{x}$ | 向量 | -| $X$ | 矩阵 | -| $X^{\top}$ | 矩阵转置 | -| $X^{-1}$ | 矩阵求逆 | -| $I$ | 单位矩阵 | -| $J$ | 全 1 矩阵 | -| $\bm{1}$ | 全 1 向量 | -| $\bm{0}$ | 全 0 向量 | -| $\beta$ | 截距 | -| $\bm{\beta}$ | 系数向量 | -| $\ell$ | 对数似然 | -| $\mathsf{E}$ | 期望 | -| $\mathsf{Var}$ | 方差 | -| $\mathsf{Cov}$ | 协方差 | -| $\mathrm{Bernoulli}$ | 伯努利分布 | -| $\mathrm{Binomial}$ | 二项分布 | -| $\mathrm{Poisson}$ | 泊松分布 | -| $\mathrm{Gamma}$ | 伽马分布 | -| $\mathrm{Beta}$ | 贝塔分布 | -| $\Gamma$ | 伽马函数 | -| $\|\bm{x}\|_0$ | 向量的 0 范数 | -| $\|\bm{x}\|_1$ | 向量的 1 范数 | -| $\|\bm{x}\|_2$ | 向量的 2 范数 | -| $\|\bm{x}\|_p$ | 向量的 $p$ 范数 | - -: 数学符号表 {#tbl-math-symbols} - -全书英文字母表示数据，希腊字母表示参数，加粗表示向量，大写表示矩阵，花体字母各有含义。所有的向量都是列向量，如上表中的 $\bm{x}$ ，而 $\bm{x}^{\top}$ 则表示行向量。 - -下表给出本书用到的一些统计术语的英文缩写。 - -| 统计术语 | 英文缩写 | -|----------------------|----------| -| 最小二乘估计 | LSE | -| 极大似然估计 | MLE | -| 最佳线性无偏估计 | BLUE | -| 最小方差无偏估计 | MVUE | -| 一致最小方差无偏估计 | UMVUE | -| 最小范数二次无偏估计 | MINQUE | -| 普通最小二乘估计 | OLS | -| 偏最小二乘估计 | PLS | -| 广义最小二乘估计 | GLS | -| 带权最小二乘估计 | WLS | -| Lasso 估计 | LASSO | -| 均方误差 | MSE | -| 均方根误差 | RMSE | -| 平均绝对误差 | MAE | -| 惩罚拟似然 | PQL | -| 剖面极大似然 | PML | -| 限制极大似然 | REML | -| 线性模型 | LM | -| 广义线性模型 | GLM | -| 广义可加模型 | GAM | -| 线性混合效应模型 | LMM | -| 广义线性混合效应模型 | GLMM | -| 广义可加混合效应模型 | GAMM | - -: 统计术语的英文缩写 {#tbl-stats-acronym} diff --git a/probabilistic-reasoning-framework.qmd b/probabilistic-reasoning-framework.qmd deleted file mode 100644 index 6c27e9a8..00000000 --- a/probabilistic-reasoning-framework.qmd +++ /dev/null @@ -1,957 +0,0 @@ -# 概率推理框架 {#sec-probabilistic-reasoning-framework} - -```{r} -#| echo: false - -Sys.setenv(CMDSTANR_NO_VER_CHECK = TRUE) -source("_common.R") -``` - -::: hidden -$$ - \def\bm#1{{\boldsymbol #1}} -$$ -::: - -本章的目的是让读者快速熟悉和上手，主要分为以下几个部分。 - -1. Stan 的概览，介绍 Stan 是什么，怎么样。 -2. Stan 的入门，以推理一个正态分布均值参数为例，从基础语法、类型声明和代码结构三个方面介绍 Stan 的使用。 -3. 选择先验分布，先验分布在贝叶斯推理中的重要性不言而喻，本节以一个简单的广义线性模型为例，介绍常见的几个先验分布对模型的影响。 -4. 选择推理算法，接上一节的例子，围绕怎么用、效果如何介绍 Stan 内置的几个推理算法。 - -## Stan 概览 {#sec-stan-overview} - -[Stan](https://github.com/stan-dev) 是一个贝叶斯统计建模和计算的概率推理框架，也是一门用于贝叶斯推断和优化的概率编程语言 [@Gelman2015; @Carpenter2017]。它使用汉密尔顿蒙特卡罗算法（Hamiltonian Monte Carlo algorithm ，简称 HMC 算法）抽样，内置一种可以自适应调整采样步长的 No-U-Turn sampler （简称 NUTS 采样器） 。Stan 还提供自动微分变分推断（Automatic Differentiation Variational Inference algorithm 简称 ADVI 算法）算法做近似贝叶斯推断获取参数的后验分布，以及拟牛顿法（the limited memory Broyden-Fletcher-Goldfarb-Shanno algorithm 简称 L-BFGS 算法）优化算法获取参数的惩罚极大似然估计。 - -经过 10 多年的发展，Stan 已经形成一个相对成熟的生态，它提供统计建模、数据分析和预测能力，广泛应用于社会、生物、物理、工程、商业等领域，在学术界和工业界的影响力也不小。下 @fig-stan-api 是 Stan 生态中各组件依赖架构图，[math](https://github.com/stan-dev/math) 库[@Carpenter2015]是 Stan 框架最核心的组件，它基于 [Boost](https://github.com/boostorg/boost) 、[Eigen](https://gitlab.com/libeigen/eigen) 、[OpenCL](https://www.khronos.org/opencl/) 、[SUNDIALS](https://github.com/LLNL/sundials) 和 [oneTBB](https://github.com/oneapi-src/oneTBB) 等诸多 C++ 库，提供概率推理、自动微分、矩阵计算、并行计算、GPU 计算和求解代数微分方程等功能。 - -```{mermaid} -%%| label: fig-stan-api -%%| fig-width: 6.5 -%%| fig-cap: Stan、CmdStan 和 CmdStanR 等的依赖关系图 - -flowchart TB - Boost(Boost) --> math(math) - Eigen(Eigen) --> math(math) - OpenCL(OpenCL) --> math(math) - SUNDIALS(SUNDIALS) --> math(math) - oneTBB(oneTBB) --> math(math) - math(math) --> Stan(Stan) - Stan(Stan) --> CmdStan(CmdStan) - Stan(Stan) --> RStan(RStan) - RStan --> rstanarm(rstanarm) - RStan --> brms(brms) - RStan --> prophet(prophet) - CmdStan --> CmdStanR(CmdStanR) - CmdStan --> CmdStanPy(CmdStanPy) - CmdStan --> MathematicaStan(MathematicaStan) - CmdStanR --> bayesplot(bayesplot) - CmdStanR --> loo(loo) - CmdStanR --> posterior(posterior) - CmdStanR --> projpred(projpred) -``` - -CmdStan 是 Stan 的命令行接口，可在 MacOS / Linux 的终端软件，Windows 的命令行窗口或 PowerShell 软件中使用。**CmdStanR** [@Gabry2023]**、**CmdStanPy 和 MathematicaStan 分别是 CmdStan 的 R 语言、Python 语言和 Mathematica 语言接口。每次当 Stan 发布新版本时，CmdStan 也会随之发布新版，只需指定新的 CmdStan 安装路径，**CmdStanR** 就可以使用上，**CmdStanR** 包与 Stan 是相互独立的更新机制。 **CmdStanR** 负责处理 CmdStan 运行的结果，而编译代码，生成模型和模拟采样等都是由 **CmdStan 完成**。入门 **CmdStanR** 后，可以快速转入对 Stan 底层原理的学习，有利于编码符合实际需要的复杂模型，有利于掌握常用的炼丹技巧，提高科研和工作的效率。 - -此外，**bayesplot** 包 [@Gabry2019] 针对 cmdstanr 包生成的拟合模型对象提供一系列可视化图形，用于诊断采样过程、展示后验分布等。**loo** 包[@Vehtari2017]计算 LOOIC （留一交叉验证信息准则）和 WAIC （通用信息准则）等指标，用于模型评估与比较。**posterior** 包 [@Vehtari2021] 对采样数据提供统一的操作方法和类型转化，计算常用的后验分布的统计量等。**projpred** 包 [@Piironen2017b; @Piironen2020] 实现投影预测推断用于模型预测和特征选择。 - -[**rstan**](https://github.com/stan-dev/rstan) 包[@RStan2023]是 Stan 的 R 语言接口，该接口依赖 **Rcpp** [@Rcpp2011; @Rcpp2018]、**RcppEigen** [@Bates2013]、**BH** [@BH2023]、**RcppParallel** [@RcppParallel2023]和 **StanHeaders** [@StanHeaders2023]等 R 包，由于存在众多上游 R 包依赖和兼容性问题，尤其在 Windows 系统环境中，因此，**RStan 的**安装、更新都比较麻烦。**RStan** 的更新通常严重滞后于 Stan 的更新，不利于及时地使用最新的学术研究成果。 而相比于 **rstan** 包，**CmdStanR** 更加轻量，可以更快地将 CmdStan 的新功能融入进来，而且 **cmdstanr** 和 CmdStan 是分离的，方便用户升级和维护。 - -[**rstanarm**](https://github.com/stan-dev/rstanarm) [@Goodrich2023] 和 [**brms**](https://github.com/paul-buerkner/brms) [@brms2017] 是 **RStan** 的扩展包，各自提供了一套用于表示统计模型的公式语法。它们都支持丰富的统计模型，比如线性模型、广义线性模型、线性混合效应模型、广义线性混合效应模型等。相比于 **rstan**， 它们使用起来更加方便，因为它内置了大量统计模型的 Stan 实现，即将公式语法翻译成 Stan 编码的模型，然后调用 **rstan** 或 **cmdstanr** 翻译成 C++，最后编译成动态链接库。除了依赖 **rstan** 包，**rstanarm** 和 **brms** 还依赖大量其它 R 包。 - -顺便一提，类似的用于概率推理和统计分析的框架，还有 Python 社区的 [PyMC](https://github.com/pymc-devs/pymc) [@pymc2023]和 [TensorFlow Probability](https://github.com/tensorflow/probability) [@Dillon2017]，它们采用的 MCMC 采样算法也是基于 NUTS 的 HMC 算法。 - -## Stan 入门 {#sec-getting-started} - -### Stan 的基础语法 {#sec-stan-syntax} - -下面以一个简单示例介绍 Stan 的用法，包括 Stan 的基本用法、变量类型、代码结构等， - -```{r} -#| echo: false - -# 注册 Stan 引擎替换 Quarto 文档中默认的 Stan 块 -# 原 Stan 块的编译采用 rstan 包 -# eng_cmdstan 不支持传递函数 cmdstan_model 的其他参数选项 -knitr::knit_engines$set(stan = cmdstanr::eng_cmdstan) -``` - -考虑一个已知方差的正态分布，设 $-3, -2, -1, 0, 1, 2, 3$ 是取自正态分布 $\mathcal{N}(\mu,1)$ 的一个样本，也是取自该正态分布的一组随机数。现在的问题是估计该正态分布的均值参数 $\mu$ 。Stan 编码的正态分布模型如下： - -```{stan output.var="mod_gaussian"} -transformed data { - vector[7] y = [-3, -2, -1, 0, 1, 2, 3]'; -} -parameters { - real mu; -} -model { - y ~ normal(mu, 1); -} -``` - -- `transformed data` 代码块是一组已知的数据，这部分数据是不需要从外部传递进来的。这个样本是以向量存储的，需要声明向量的长度和类型（默认类型是实数），每一行以分号结尾，这与 C++ 的语法一样。 - -- `parameters` 代码块是未知的参数，需要声明各个参数的类型。这里只有一个参数，且只是一个未知的实数，声明类型即可。 - -- `model` 代码块是抽样语句表示的模型结构，符号 `~` 表示服从的意思，函数 `y ~ normal(mu, 1)` 是正态分布的抽样语句。 - -接下来，编译 Stan 代码，准备参数初值，配置采样的参数。首先加载 **cmdstanr** 包，设置 2 条迭代链，给每条链设置相同的参数初始值。代码编译后，生成一个模型对象 `mod_gaussian`，接着，调用方法 `sample()` ，传递迭代初值 `init`，初始化阶段的迭代次数 `iter_warmup` ，采样阶段的迭代次数 `iter_sampling`，采样的链条数 `chains` 及并行时 分配的 CPU 核心数 `parallel_chains` ，随机数种子 `seed` 。 - -```{r} -#| message: false - -library(cmdstanr) -nchains <- 2 # 2 条迭代链 -# 给每条链设置相同的参数初始值 -inits_data_gaussian <- lapply(1:nchains, function(i) { - list( - mu = 1 - ) -}) - -fit_gaussian <- mod_gaussian$sample( - init = inits_data_gaussian, # 迭代初值 - iter_warmup = 200, # 每条链初始化迭代次数 - iter_sampling = 200, # 每条链采样迭代次数 - chains = nchains, # 马尔科夫链的数目 - parallel_chains = nchains,# 指定 CPU 核心数，可以给每条链分配一个 - seed = 20232023 # 设置随机数种子，不要使用 set.seed() 函数 -) -``` - -默认情况下，采样过程中会输出一些信息，以上是 2 条链并行采样的过程，给出百分比进度及时间消耗。采样完成后，调用方法 `summary()` 汇总和展示采样结果。 - -```{r} -fit_gaussian$summary() -``` - -输出模型中各个参数的后验分布的一些统计量，如均值（mean）、中位数（median）、标准差（sd），0.05 分位点（q5），0.95 分位点（q95）等。此外，还有 `lp__` 后验对数概率密度值，每个模型都会有该值。`summary()` 方法有一些参数可以控制数字的显示方式和精度。下面展示的是保留 4 位有效数字的结果。 - -```{r} -fit_gaussian$summary(.num_args = list(sigfig = 4, notation = "dec")) -``` - -接下来，要介绍 Stan 代码中的保留字 target 的含义，因为它在 Stan 代码中很常见，与输出结果中的 `lp__` 一行紧密相关。 - -- `lp__` 表示后验概率密度函数的对数。 -- target 累加一些和参数无关的数不影响参数的估计，但影响 `lp__` 的值。 -- 抽样语句表示模型会扔掉后验概率密度函数的对数的常数项。 - -```{r} -#| label: fig-stan-lp -#| fig-cap: lp__ 的后验分布 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| message: false - -library(ggplot2) -library(bayesplot) -mcmc_hist(fit_gaussian$draws("lp__")) + - theme_classic() -``` - -为此，不妨在之前的 Stan 代码的基础上添加两行，新的 Stan 代码如下： - -```{stan output.var="mod_gaussian_target"} -transformed data { - vector[7] y = [-3, -2, -1, 0, 1, 2, 3]'; -} -parameters { - real mu; -} -model { - y ~ normal(mu, 1); - target += 12345; - target += mean(exp(y)); -} -``` - -接着，再次编译代码、采样，为了节约篇幅，设置两个参数 `show_messages` 和 `refresh` ，不显示中间过程和采样进度。其它参数设置不变，代码如下： - -```{r} -fit_gaussian <- mod_gaussian_target$sample( - init = inits_data_gaussian, - iter_warmup = 200, - iter_sampling = 200, - chains = nchains, - parallel_chains = nchains, - show_messages = FALSE, # 不显示中间过程 - refresh = 0, # 不显示采样进度 - seed = 20232023 -) -fit_gaussian$summary(.num_args = list(sigfig = 4, notation = "dec")) -``` - -可以清楚地看到 `lp__` 的值发生了变化，而参数 `mu` 的值没有变化。这是因为抽样语句 `y ~ normal(mu, 1);` 隐含一个 `lp__` ，target 指代 `lp__` 的值，符号 `+=` 表示累加。两次累加后得到 12335.09。 - -``` stan -model { - y ~ normal(mu, 1); - target += 12345; - target += mean(exp(y)); -} -``` - -```{r} -y <- c(-3, -2, -1, 0, 1, 2, 3) -12345 + mean(exp(y)) - 14.45 -``` - -下面从概率密度函数出发，用 R 语言来计算逐点对数似然函数值。一般地，不妨设 $x_1,x_2,\cdots,x_n$ 是来自正态总体 $\mathcal{N}(\mu,1)$ 的一个样本。则正态分布的概率密度函数 $f(x)$ 的对数如下： - -$$ -\log f(x) = \log \frac{1}{\sqrt{2\pi}} - \frac{(x - \mu)^2}{2} -$$ - -已知参数 $\mu$ 是一个非常接近 0 的数，不妨将 $\mu = 0$ 代入计算。 - -```{r} -sum(dnorm(x = y, mean = 0, sd = 1, log = TRUE)) -``` - -去掉常数项后，计算概率密度函数值的对数和。 - -```{r} -# 扔掉常数 -f <- function(y, mu) { - return(-0.5 * (y - mu)^2) -} -sum(f(-3:3, 0)) -``` - -这就比较接近原 `lp__` 的值了，所以，`lp__` 表示后验概率密度函数的对数，扔掉了与参数无关的常数项。若以概率密度函数的对数 `normal_lpdf` 替代抽样语句，则常数项是保留的。`normal_lpdf` 是 Stan 内置的函数，输入值为随机变量的取值 `y` 、位置参数 `mu` 和尺度参数 `sigma`，返回值为 `real` 实数。 - -`real` **`normal_lpdf`**`(reals y | reals mu, reals sigma)` - -```{stan output.var="mod_gaussian_lpdf"} -transformed data { - vector[7] y = [-3, -2, -1, 0, 1, 2, 3]'; -} -parameters { - real mu; -} -model { - target += normal_lpdf(y | mu, 1); -} -``` - -接着，编译上述代码以及重复采样的步骤，参数设置也一样。 - -```{r} -fit_gaussian <- mod_gaussian_lpdf$sample( - init = inits_data_gaussian, - iter_warmup = 200, - iter_sampling = 200, - chains = nchains, - parallel_chains = nchains, - show_messages = FALSE, - refresh = 0, - seed = 20232023 -) -fit_gaussian$summary(.num_args = list(sigfig = 4, notation = "dec")) -``` - -可以看到，此时 `lp__` 的值包含常数项，两种表示方式对参数的计算结果没有影响。 - -### Stan 的变量类型 {#sec-stan-variables} - -Stan 语言和 C/C++ 语言比较类似，变量需要先声明再使用，函数需要用 `return` 返回值，总而言之，类型声明比较严格。变量的声明没有太多的内涵，就是 C++ 和 Stan 定义的语法，比如整型用 `int` 声明。建模过程中，时常需要将 R 语言环境中的数据传递给 Stan 代码编译出来的模型，而 Stan 是基于 C++ 语言，在变量类型方面有继承有发展。下表给出 Stan 与 R 语言中的变量类型对应关系。值得注意， R 语言的类型检查是不严格的，使用变量也不需要提前声明和初始化。Stan 语言中向量、矩阵的类型都是实数，下标也从 1 开始，元组类型和 R 语言中的列表类似，所有向量默认都是列向量。 - -下表第一列表示 Stan 语言的变量类型，第二列给出使用该变量的声明示例，第三列给出 R 语言中构造该类型变量的示例。 - -| 类型 | Stan 语言 | R 语言 | -|--------|-------------------------------|-------------------------------------| -| 整型 | `int x = 1;` | `x = 1L` | -| 实数 | `real x = 3.14;` | `x = 3.14` | -| 向量 | `vector[3] x = [1, 2, 3]';` | `x = c(1, 2, 3)` | -| 矩阵 | `matrix[3,1] x;` | `matrix(data = c(1, 2, 3), nrow = 3)` | -| 数组 | `array[3] int x;` | `array(data = c(1L, 2L, 3L), dim = c(3, 1, 1))` | -| 元组 | `tuple(vector[3],vector[3]) x;` | `list(x = c(1, 2, 3), y = c(4, 5, 6))` | - -: Stan 变量类型和 R 语言中的对应 {#tbl-stan-var-dec} - -### Stan 的代码结构 {#sec-stan-code} - -一般地，Stan 代码文件包含数据、参数和模型三块内容，一个简单的示例如 @sec-stan-syntax 所示。Stan 代码文件最多有如下 7 块内容，函数块 `functions` 放一些自定义的函数，数据变换块 `transformed data` 对输入数据做一些变换，预计算，以便放入后续模型，参数变换块 `transformed parameters` 作用类似数据变换块，方便在模型中使用，它们也会作为参数在输出结果中显示。生成量块 `generated quantities` 计算一些统计量，概率分布的随机数、分位数等。模拟、拟合和预测模型会用到其中的一部分或全部。 - -``` stan -functions { - // ... function declarations and definitions ... -} -data { - // ... declarations ... -} -transformed data { - // ... declarations ... statements ... -} -parameters { - // ... declarations ... -} -transformed parameters { - // ... declarations ... statements ... -} -model { - // ... declarations ... statements ... -} -generated quantities { - // ... declarations ... statements ... -} -``` - -### Stan 的函数使用 {#sec-stan-function} - -Stan 有大量的内建函数，然而，有时候，Stan 内建的函数不足以满足需求，需要自己创建函数。下面以函数 `cholesky_decompose` 为例介绍 Stan 内置/一般函数的调用，在该函数的基础上自定义函数 `cholesky_decompose2` ，这不过是对它改个名字，其它内容只要符合 Stan 语言即可，不甚重要。 - -根据 Stan 官网函数 `cholesky_decompose` 帮助文档，Cholesky 分解的形式（Cholesky 分解有多种形式）如下： - -$$ -M = LL^{\top} -$$ - -$M$ 是一个对称正定的矩阵，而 $L$ 是一个下三角矩阵。函数 `cholesky_decompose` 有一个参数 A， A 需要传递一个对称正定的矩阵。不妨设这个对称正定的矩阵为 - -$$ -M = \begin{bmatrix} -4 & 1 \\ -1 & 1 -\end{bmatrix} -$$ - -```{r} -# 准备函数 -stan_file <- write_stan_file(" -functions { - matrix cholesky_decompose2(matrix A) { - return cholesky_decompose(A); - } -} -parameters { - real x; -} -model { - x ~ std_normal(); -} -") -``` - -接着，将以上 Stan 代码编译 - -```{r} -#| message: false - -mod_cholesky_decompose <- cmdstan_model(stan_file = stan_file, compile = TRUE) -``` - -准备测试数据，只要是一个对称正定的矩阵都可以做 cholesky 分解。 - -```{r} -# 测试矩阵 -M <- rbind(c(4, 1), c(1, 1)) -``` - -**cmdstanr** 包导出函数的方法将以上 Stan 代码中的函数部分独立导出。 - -```{r} -#| message: false - -# 编译独立的函数 -mod_cholesky_decompose$expose_functions() -``` - -现在，可以直接调用导出的函数 `cholesky_decompose2` 。 - -```{r} -# cholesky 分解 -mod_cholesky_decompose$functions$cholesky_decompose2(A = M) -``` - -最后，将 Stan 函数计算的结果与 R 语言内置的 cholesky 分解函数的结果比较。发现，函数 `chol()` 的结果正好是 `cholesky_decompose2` 的转置。 - -```{r} -chol(M) -``` - -查看帮助文档，可知 R 软件对 Cholesky 分解的定义如下： - -$$ -M = L^{\top}L -$$ - -根据数学表达式，感觉上都是差不多的，但还是有差异。R 与 Stan 混合编程就需要注意这些表达上不同的，不然，排错会很麻烦。 - -::: callout-tip -StanHeaders 可以编译和调用 Stan 的内置的数学函数，比如 Cholesky 分解函数 `cholesky_decompose` 。 - -```{r} -library(StanHeaders) -stanFunction("cholesky_decompose", A = M) -``` - -可以看到，结果和前面一样。 -::: - -## 先验分布 {#sec-choose-prior} - -考虑一个响应变量服从伯努利分布的广义线性模型。 - -$$ -\begin{aligned} -&\boldsymbol{y} \sim \mathrm{Bernoulli}(\boldsymbol{p}) \\ -&\mathrm{logit}(\boldsymbol{p}) = \log (\frac{\boldsymbol{p}}{1-\boldsymbol{p}})= \alpha + X \boldsymbol{\beta} -\end{aligned} -$$ - -下面模拟生成 2500 个样本，其中 10 个正态协变量，非 0 的回归系数是截距 $\alpha = 1$ 和向量 $\boldsymbol{\beta}$ 中的 $\beta_1 = 3,\beta_2 = -2$ 。对模型实际有用的是 3 个变量，采用贝叶斯建模，其它变量应该被收缩掉。贝叶斯收缩 （Bayesian shrinkage）与变量选择 （Variable selection） 是有关系的，先验分布影响收缩的力度。 - -```{r} -set.seed(2023) -n <- 2500 -k <- 10 -X <- matrix(rnorm(n * k), ncol = k) -y <- rbinom(n, size = 1, prob = plogis(1 + 3 * X[, 1] - 2 * X[, 2])) -# 准备数据 -mdata <- list(k = k, n = n, y = y, X = X) -``` - -在贝叶斯先验分布中，有几个常用的概率分布，分别是正态分布、拉普拉斯分布（双指数分布）、柯西分布，下图集中展示了这几个的标准分布。 - -```{r} -#| label: fig-prior -#| fig-cap: 几个常用的概率分布 -#| fig-width: 4.5 -#| fig-height: 3.5 -#| dev: 'tikz' -#| fig-process: !expr to_png -#| code-fold: true -#| echo: !expr knitr::is_html_output() - -dlaplace <- function(x, mu = 0, sigma = 1) { - 1 / (2*sigma) * exp(- abs(x - mu) / sigma) -} - -ggplot() + - geom_function( - fun = dnorm, args = list(mean = 0, sd = 1), - aes(colour = "正态分布"), linewidth = 1.2, xlim = c(-6, 6) - ) + - geom_function( - fun = dlaplace, args = list(mu = 0, sigma = 1), - aes(colour = "双指数分布"), linewidth = 1.2, xlim = c(-6, 6) - ) + - geom_function( - fun = dcauchy, args = list(location = 0, scale = 0.5), - aes(colour = "柯西分布"), linewidth = 1.2, xlim = c(-6, 6) - ) + - theme_classic() + - theme(legend.position = "inside", legend.position.inside = c(0.8, 0.8)) + - labs(x = "$x$", y = "$f(x)$", colour = "先验分布") -``` - -接下来，考虑几种常见的先验设置。 - -### 正态先验 {#sec-prior-normal} - -指定回归系数 $\alpha,\beta$ 的先验分布如下 - -$$ -\begin{aligned} -\alpha &\sim \mathcal{N}(0, 1000) \\ -\beta &\sim \mathcal{N}(0, 1000) -\end{aligned} -$$ - -正态分布中设置相当大的方差意味着分布相当扁平， $\alpha,\beta$ 的取值在区间 $(-\infty,+\infty)$ 上比较均匀。 - -```{verbatim, file="code/bernoulli_logit_glm_normal.stan", lang="stan"} -``` - -```{r} -#| message: false - -mod_logit_normal <- cmdstan_model( - stan_file = "code/bernoulli_logit_glm_normal.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) - -fit_logit_normal <- mod_logit_normal$sample( - data = mdata, - chains = 2, - parallel_chains = 2, - iter_warmup = 1000, - iter_sampling = 1000, - threads_per_chain = 2, - seed = 20232023, - show_messages = FALSE, - refresh = 0 -) - -# 输出结果 -fit_logit_normal$summary(c("alpha", "beta", "lp__")) -``` - -### Lasso 先验 {#sec-prior-lasso} - -指定回归系数 $\alpha,\beta$ 的先验分布如下 - -$$ -\begin{aligned} -\lambda &\sim \mathrm{Half\_Cauchy}(0,0.01) \\ -\alpha &\sim \mathrm{Double\_exponential}(0, \lambda) \\ -\beta &\sim \mathrm{Double\_exponential}(0, \lambda) -\end{aligned} -$$ - -其中， $\alpha,\beta$ 服从双指数分布，惩罚因子 $\lambda$ 服从柯西分布。顺便一提，若把双指数分布改为正态分布，则 Lasso 先验变为岭先验。相比于岭先验，Lasso 先验有意将回归系数往 0 上收缩，这非常类似于频率派中的岭回归与 Lasso 回归的关系 [@Bhadra2019]。 - -```{verbatim, file="code/bernoulli_logit_glm_lasso.stan", lang="stan"} -``` - -```{r} -#| message: false -mod_logit_lasso <- cmdstan_model( - stan_file = "code/bernoulli_logit_glm_lasso.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) - -fit_logit_lasso <- mod_logit_lasso$sample( - data = mdata, - chains = 2, - parallel_chains = 2, - iter_warmup = 1000, - iter_sampling = 1000, - threads_per_chain = 2, - seed = 20232023, - show_messages = FALSE, - refresh = 0 -) - -# 输出结果 -fit_logit_lasso$summary(c("alpha", "beta", "lambda", "lp__")) -``` - -计算 LOO-CV 比较正态先验和 Lasso 先验 - -```{r} -fit_logit_normal_loo <- fit_logit_normal$loo(variables = "log_lik", cores = 1) -print(fit_logit_normal_loo) - -fit_logit_lasso_loo <- fit_logit_lasso$loo(variables = "log_lik", cores = 1) -print(fit_logit_lasso_loo) -``` - -loo 包的函数 `loo_compare()` 比较两个模型 - -```{r} -loo::loo_compare(list(model0 = fit_logit_normal_loo, - model1 = fit_logit_lasso_loo)) -``` - -输出结果中最好的模型放在第一行。LOOIC 越小越好，所以，Lasso 先验更好。 - -### Horseshoe 先验 {#sec-prior-horseshoe} - -Horseshoe 先验（Horse shoe）[@Piironen2017a] 指定回归系数 $\alpha,\bm{\beta}$ 的先验分布如下 - -$$ -\begin{aligned} -\lambda_i &\sim \mathrm{Half\_Cauchy}(0,1) \\ -\alpha | \lambda_0,\tau &\sim \mathcal{N}(0, \tau^2\lambda_0^2) \\ -\beta_i | \lambda_i,\tau &\sim \mathcal{N}(0, \tau^2\lambda_i^2),\quad i = 1,2,\cdots,10 -\end{aligned} -$$ - -其中，$\tau$ 称之为全局超参数，它将所有的回归系数朝着 0 收缩。而作用在局部超参数 $\lambda_i$ 上的重尾柯西先验允许某些回归系数逃脱收缩。 - -```{verbatim, file="code/bernoulli_logit_glm_horseshoe.stan", lang="stan"} -``` - -```{r} -#| message: false - -# horseshoe 先验 -mod_logit_horseshoe <- cmdstan_model( - stan_file = "code/bernoulli_logit_glm_horseshoe.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) - -fit_logit_horseshoe <- mod_logit_horseshoe$sample( - data = mdata, - chains = 2, - parallel_chains = 2, - iter_warmup = 1000, - iter_sampling = 1000, - threads_per_chain = 2, - seed = 20232023, - show_messages = FALSE, - refresh = 0 -) - -fit_logit_horseshoe$summary(c("alpha", "beta", "tau", "lambda", "lp__")) -``` - -可以看到回归系数小的压缩效果很明显，而回归系数大的几乎没有压缩。 - -```{r} -fit_logit_horseshoe_loo <- fit_logit_horseshoe$loo(variables = "log_lik", cores = 1) -print(fit_logit_horseshoe_loo) -``` - -LOOIC 比之 Lasso 先验的情况更小了。 - -::: callout-note -```{r} -#| eval: false - -library(rstanarm) -# set up the prior, use hyperprior tau ∼ half-Cauchy(0,tau0^2) -D <- ncol(X) # 10 变量 -n <- nrow(X) # 2500 样本量 -p0 <- 5 # prior guess for the number of relevant variables -sigma <- 1 / sqrt(mean(y)*(1-mean(y))) # pseudo sigma -tau0 <- p0 / (D - p0) * sigma / sqrt(n) -# hs() 函数指定层次收缩先验 Hierarchical shrinkage -# 拟合模型 -fit <- stan_glm( - y ~ X, family = binomial(), data = data.frame(I(X), y), - # horseshoe 先验 - prior = hs(df = 1, global_df = 1, global_scale = tau0) -) -# 输出结果 -summary(fit, digits = 4) -``` - -模型输出如下： - -``` markdown -Model Info: - function: stan_glm - family: binomial [logit] - formula: y ~ X - algorithm: sampling - sample: 4000 (posterior sample size) - priors: see help('prior_summary') - observations: 2500 - predictors: 11 - -Estimates: - mean sd 10% 50% 90% -(Intercept) 1.0016 0.0732 0.9080 1.0007 1.0947 -X1 3.0921 0.1343 2.9219 3.0888 3.2660 -X2 -1.9907 0.1002 -2.1200 -1.9903 -1.8631 -X3 0.0205 0.0429 -0.0180 0.0084 0.0804 -X4 -0.0069 0.0364 -0.0534 -0.0018 0.0297 -X5 0.0045 0.0367 -0.0336 0.0008 0.0474 -X6 0.0062 0.0364 -0.0323 0.0014 0.0519 -X7 0.0469 0.0559 -0.0068 0.0327 0.1258 -X8 -0.0082 0.0376 -0.0545 -0.0021 0.0296 -X9 -0.0342 0.0492 -0.1042 -0.0196 0.0109 -X10 0.0310 0.0472 -0.0125 0.0180 0.0971 - -Fit Diagnostics: - mean sd 10% 50% 90% -mean_PPD 0.5915 0.0087 0.5804 0.5916 0.6028 - -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.0010 0.9994 5422 -X1 0.0021 0.9996 3994 -X2 0.0016 1.0000 3817 -X3 0.0006 0.9997 4531 -X4 0.0005 0.9998 4652 -X5 0.0005 0.9993 5052 -X6 0.0005 0.9994 4795 -X7 0.0010 1.0002 3045 -X8 0.0006 1.0000 4397 -X9 0.0009 1.0002 3034 -X10 0.0008 1.0003 3292 -mean_PPD 0.0001 0.9994 4742 -log-posterior 0.1367 1.0012 1206 - -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). -``` - -**rstanarm** 包可以获得与前面一致的结果，甚至收缩效果比手写的 Stan 代码好一点点。 -::: - -### SpikeSlab 先验 {#sec-prior-spikeslab} - -SpikeSlab 先验（Spike Slab）放在非 0 协变量的个数上，是离散的先验。回归系数的先验分布的有限混合，常用有限混合多元正态分布。参考文章 [Discrete Mixture Models](https://betanalpha.github.io/assets/case_studies/modeling_sparsity.html#221_Discrete_Mixture_Models) - -::: callout-note -**BoomSpikeSlab** 包是 **Boom** 包的扩展，提供基于 SpikeSlab 先验的贝叶斯变量选择功能。 - -```{r} -#| eval: false - -set.seed(2023) -n <- 2500 -k <- 10 -X <- matrix(rnorm(n * k), ncol = k) -y <- rbinom(n, size = 1, prob = plogis(1 + 3 * X[, 1] - 2 * X[, 2])) -# 加载 BoomSpikeSlab -library(BoomSpikeSlab) -fit_logit_spike <- logit.spike(y ~ X, niter = 500) -# 模型输出 -summary(fit_logit_spike) -``` - -``` markdown - -null log likelihood: -1690.677 -posterior mean log likelihood: -766.5283 -posterior max log likelihood: -754.8686 -mean deviance R-sq: 0.5466147 - -predicted vs observed success rates, by decile: - predicted observed -(0.00596,0.0279] 0.01388670 0.008032129 -(0.0279,0.108] 0.06371528 0.060000000 -(0.108,0.273] 0.17839881 0.176000000 -(0.273,0.496] 0.39146661 0.404000000 -(0.496,0.734] 0.61807048 0.608000000 -(0.734,0.865] 0.80694458 0.764000000 -(0.865,0.942] 0.90690322 0.928000000 -(0.942,0.979] 0.96436544 0.976000000 -(0.979,0.992] 0.98636201 0.992000000 -(0.992,0.996] 0.99441504 1.000000000 - -summary of coefficients: - mean sd mean.inc sd.inc inc.prob -(Intercept) 1.02 0.105 1.02 0.105 1.00 -X2 -2.00 0.232 -2.02 0.118 0.99 -X1 3.10 0.354 3.13 0.170 0.99 -X10 0.00 0.000 0.00 0.000 0.00 -X9 0.00 0.000 0.00 0.000 0.00 -X8 0.00 0.000 0.00 0.000 0.00 -X7 0.00 0.000 0.00 0.000 0.00 -X6 0.00 0.000 0.00 0.000 0.00 -X5 0.00 0.000 0.00 0.000 0.00 -X4 0.00 0.000 0.00 0.000 0.00 -X3 0.00 0.000 0.00 0.000 0.00 -``` -::: - -## 推理算法 {#sec-choose-inference} - -开篇提及 Stan 内置了多种推理算法，不同的算法获得的结果是存在差异的。 - -- full Bayesian statistical inference with MCMC sampling (NUTS, HMC) -- approximate Bayesian inference with variational inference (ADVI) -- penalized maximum likelihood estimation with optimization (L-BFGS) - -### 惩罚极大似然算法 {#sec-optimization-algorithms} - -L-BFGS 算法拟合模型，速度非常快。 - -```{r} -# L-BFGS 算法拟合模型 -fit_optim_logit <- mod_logit_lasso$optimize( - data = mdata, # 观测数据 - init = 0, # 所有参数初值设为 0 - refresh = 0, # 不显示迭代进程 - algorithm = "lbfgs", # 优化器 - threads = 1, # 单线程 - seed = 20232023 # 随机数种子 -) - -fit_optim_logit$summary(c("alpha", "beta", "lambda", "lp__")) -``` - -### 变分近似推断算法 {#sec-variational-approximation-algorithms} - -ADVI 算法拟合模型，可选的优化器有 `meanfield` 和 `fullrank` ，相比于 L-BFGS 稍慢 - -```{r} -# ADVI 算法拟合模型 -fit_advi_logit <- mod_logit_lasso$variational( - data = mdata, # 观测数据 - init = 0, # 所有参数初值设为 0 - refresh = 0, # 不显示迭代进程 - algorithm = "meanfield", # 优化器 - threads = 1, # 单线程 - seed = 20232023 # 随机数种子 -) - -fit_advi_logit$summary(c("alpha", "beta", "lambda", "lp__")) -``` - -### 拉普拉斯近似算法 {#sec-laplace-approximation-algorithms} - -Stan 内置的 Laplace 近似算法是对后验分布的 Laplace 正态近似，再从近似的后验分布中采样获得样本，最后，对样本进行统计分析获得参数的后验估计。详见 Stan 语言参考手册的[Laplace Approximation 一章](https://mc-stan.org/docs/reference-manual/laplace-approximation.html)。 - -```{r} -# Laplace 算法 -fit_laplace_logit <- mod_logit_lasso$laplace( - data = mdata, # 观测数据 - init = 0, # 所有参数初值设为 0 - refresh = 0, # 不显示迭代进程 - threads = 1, # 单线程 - seed = 20232023 # 随机数种子 -) - -fit_laplace_logit$summary(c("alpha", "beta", "lambda", "lp__")) -``` - -### 探路者变分算法 {#sec-pathfinder-algorithms} - -探路者算法 Pathfinder 属于变分法，针对可微的对数目标密度函数，沿着逆牛顿优化算法的迭代路径，获得目标密度函数的正态近似。正态近似中的局部协方差的估计采用 LBFGS 计算的负逆 Hessian 矩阵。探路者算法的优势是可以极大地减少对数密度函数和梯度的计算次数，缓解迭代陷入局部最优点和鞍点（何为鞍点，一个可视化示例详见 @sec-gaussian-process-regression ）。 - -```{r} -# Pathfinder 算法 -fit_pathfinder_logit <- mod_logit_lasso$pathfinder( - data = mdata, # 观测数据 - init = 0, # 所有参数初值设为 0 - refresh = 0, # 不显示迭代进程 - num_threads = 1, # 单线程 - seed = 20232023 # 随机数种子 -) - -fit_pathfinder_logit$summary(c("alpha", "beta", "lambda", "lp__")) -``` - -## 习题 - -1. 在 @sec-choose-prior 的基础上，比较 Stan 实现的贝叶斯 Lasso 和 R 包 **glmnet** 的结果，发现 **glmnet** 包是很有竞争力的。在选择 Lasso 先验的情况下，收缩效果比 Stan 还好，运行速度也很快。Stan 的优势在于不限于先验分布的选取，当选择 Horseshoe 先验时，Stan 的收缩又比 **glmnet** 包更好。Stan 的优势还在于不限于 **glmnet** 包支持的常见分布族，如高斯、二项、泊松、多项、Cox 等。本质上，这两点都是 Stan 作为一门概率编程语言的优势，只要知道概率分布的数学表达式，总是可以用 Stan 编码出来的。 - - ```{r} - #| message: false - - library(glmnet) - # 10 折交叉验证 Lasso 回归 - fit_lasso <- cv.glmnet(x = X, y = y, family = "binomial", alpha = 1, nfolds = 10) - # 回归系数 - coef(fit_lasso, s = fit_lasso$lambda.min) - ``` - -2. 基于德国信用卡评分数据，建立逻辑回归模型，分析 20 个协变量对响应变量的贡献，采用合适的先验分布选择适当的变量数。 - - ```{r} - german_credit_data <- readRDS(file = "data/german_credit_data.rds") - str(german_credit_data) - ``` - -3. 下图是美国黄石公园老忠实间歇泉喷发时间和等待时间的分布规律，请建立合适的正态混合模型，用 Stan 拟合模型，并对结果做出说明。（提示：参考 Stan 用户手册的[有限混合章节](https://mc-stan.org/docs/stan-users-guide/mixture-modeling.html)） - - ```{r} - #| label: fig-faithful-mixture - #| fig-cap: 黄石公园老忠实间歇泉 - #| fig-width: 7 - #| fig-height: 3 - #| fig-showtext: true - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - p1 <- ggplot(data = faithful, aes(x = eruptions)) + - geom_histogram(aes(y = after_stat(density)), - bins = 30, fill = "white", color = "gray") + - geom_density() + - theme_classic() + - labs(x = "喷发时间", y = "概率密度值") - - p2 <- ggplot(data = faithful, aes(x = waiting)) + - geom_histogram(aes(y = after_stat(density)), - bins = 30, fill = "white", color = "gray") + - geom_density() + - theme_classic() + - labs(x = "等待时间", y = "概率密度值") - - library(patchwork) - p1 | p2 - ``` - - ```{verbatim, file="code/faithful_finite_mixtures.stan", lang="stan"} - ``` - - ```{r} - #| code-fold: true - #| echo: !expr knitr::is_html_output() - #| eval: false - #| message: false - - library(cmdstanr) - - faithful_d <- list( - K = 2, # 几个正态分布混合 - N = 272, # 样本量 - # y = faithful$waiting, - y = faithful$eruptions - ) - - mod_faithful_normal <- cmdstan_model( - stan_file = "code/faithful_finite_mixtures.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) - ) - - fit_faithful_normal <- mod_faithful_normal$sample( - data = faithful_d, - chains = 2, - parallel_chains = 2, - iter_warmup = 1000, - iter_sampling = 1000, - threads_per_chain = 2, - seed = 20232023, - show_messages = FALSE, - refresh = 0 - ) - - # 输出结果 - fit_faithful_normal$summary(c("theta", "mu", "sigma", "lp__")) - # theta[1] = 0.350 混合比例 - # theta[2] = 0.650 - # mu[1] = 2.02 均值 - # mu[2] = 4.27 - # sigma[1] = 0.243 标准差 - # sigma[2] = 0.437 - ``` - -4. 在 @sec-visualization-practice 的探索分析基础上，对美国黄石公园的老忠实泉喷发规律，建立二项分布和二维正态分布的混合模型，请用 Stan 编码估计模型中的参数。 - - $$ - f(\bm{x};p,\bm{\mu_1},\Sigma_1,\bm{\mu_2},\Sigma_2) = p\mathcal{N}(\bm{x};\bm{\mu_1},\Sigma_1) + (1-p) \mathcal{N}(\bm{x};\bm{\mu_2},\Sigma_2) - $$ - - 其中，参数 $p$ 是一个介于 0 到 1 之间的常数，参数 $\bm{\mu_1} = (\mu_{11},\mu_{12})^\top,\bm{\mu_2}=(\mu_{21},\mu_{22})^\top$ 是二维的列向量，参数 $\Sigma_1 = (\sigma_{ij}),\Sigma_2 = (\delta_{ij}),i=1,2,j=1,2$ 是二阶的协方差矩阵。（提示：因有限混合模型存在可识别性问题，简单起见，考虑各个多元正态分布的协方差矩阵相同的情况。） - - ```{verbatim, file="code/faithful_2d_finite_mixtures.stan", lang="stan"} - ``` - - ```{r} - #| code-fold: true - #| echo: !expr knitr::is_html_output() - #| eval: false - #| message: false - - data("faithful") - library(cmdstanr) - # 准备数据 - faithful_2d <- list( - K = 2, # 2 个分布混合 - N = 272, # 样本量 nrow(faithful) - D = 2, # 二维正态分布 - y = faithful # 数据集 - ) - # 编译模型 - mod_faithful_normal_2d <- cmdstan_model( - stan_file = "code/faithful_2d_finite_mixtures.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) - ) - # 采样 - fit_faithful_normal_2d <- mod_faithful_normal_2d$sample( - data = faithful_2d, - chains = 2, - parallel_chains = 2, - iter_warmup = 1000, - iter_sampling = 1000, - threads_per_chain = 2, - seed = 20232023, - show_messages = FALSE, - refresh = 0 - ) - # 输出结果 - fit_faithful_normal_2d$summary(c("theta", "mu", "lp__")) - ``` diff --git a/regression-problems.qmd b/regression-problems.qmd deleted file mode 100644 index a4f2a68f..00000000 --- a/regression-problems.qmd +++ /dev/null @@ -1,687 +0,0 @@ -# 回归问题 {#sec-regression-problems} - -::: hidden -$$ - \def\bm#1{{\boldsymbol #1}} -$$ -::: - -```{r} -#| echo: false - -source("_common.R") -``` - -```{r} -#| message: false - -library(MASS) -library(pls) # PC / PLS -library(glmnet) # 惩罚回归 -library(ncvreg) # MCP / SCAD -library(lars) # LAR -library(abess) # Best subset -library(kernlab) # 基于核的支持向量机 ksvm -library(nnet) # 神经网络 nnet -library(rpart) # 决策树 -library(randomForest) # 随机森林 -library(xgboost) # 梯度提升 -library(lattice) -# Root Mean Squared Error 均方根误差 -rmse <- function(y, y_pred) { - sqrt(mean((y - y_pred)^2)) -} -``` - -本章基于波士顿郊区房价数据集 Boston 介绍处理回归问题的 10 种方法。数据集 Boston 来自 R 软件内置的 **MASS** 包，一共 506 条记录 14 个变量，由 Boston Standard Metropolitan Statistical Area (SMSA) 在 1970 年收集。 - -```{r} -data("Boston", package = "MASS") -str(Boston) -``` - -14 个变量的含义如下： - -- crim: 城镇人均犯罪率 per capita crime rate by town -- zn: 占地面积超过25,000平方尺的住宅用地比例 proportion of residential land zoned for lots over 25,000 sq.ft. -- indus: 每个城镇非零售业务的比例 proportion of non-retail business acres per town. -- chas: 查尔斯河 Charles River dummy variable (= 1 if tract bounds river; 0 otherwise). -- nox: 氮氧化物浓度 nitrogen oxides concentration (parts per 10 million). -- rm: 每栋住宅的平均房间数量 average number of rooms per dwelling. 容积率 -- age: 1940年以前建造的自住单位比例 proportion of owner-occupied units built prior to 1940. 房龄 -- dis: 到波士顿五个就业中心的加权平均值 weighted mean of distances to five Boston employment centres. 商圈 -- rad: 径向高速公路可达性指数 index of accessibility to radial highways. 交通 -- tax: 每10,000美元的全额物业税率 full-value property-tax rate per \$10,000. 物业 -- ptratio: 城镇的师生比例 pupil-teacher ratio by town. 教育 -- black: 城镇黑人比例 $1000(Bk - 0.63)^2$ where Bk is the proportion of blacks by town. 安全 -- lstat: 较低的人口状况（百分比）lower status of the population (percent). -- medv: 自住房屋的中位数为 1000 美元 median value of owner-occupied homes in \$1000s. 房价，这是响应变量。 - -## 线性回归 {#sec-linear-regressions} - -对于线性回归问题，为了处理变量之间的相关关系，衍生出许多处理办法。有的办法是线性的，有的办法是非线性的。 - -### 最小二乘回归 {#sec-ordinary-least-square-regression} - -$$ -\mathcal{L}(\bm{\beta}) = \sum_{i=1}^{n}(y_i - \bm{x}_i^{\top}\bm{\beta})^2 -$$ - -```{r} -fit_lm <- lm(medv ~ ., data = Boston) -summary(fit_lm) -``` - -### 逐步回归 {#sec-stepwise-regression} - -逐步回归是筛选变量，有向前、向后和两个方向同时进行三个方法。 - -- `direction = "both"` 双向 -- `direction = "backward"` 向后 -- `direction = "forward"` 向前 - -```{r} -fit_step <- step(fit_lm, direction = "both", trace = 0) -summary(fit_step) -``` - -### 偏最小二乘回归 {#sec-partial-least-square-regression} - -偏最小二乘回归适用于存在多重共线性问题或变量个数远大于样本量的情况。 - -10 折交叉验证，`ncomp = 6` 表示 6 个主成分，拟合方法 `kernelpls` 表示核算法，`validation = "CV"` 表示采用交叉验证的方式调整参数。 - -```{r} -fit_pls <- pls::plsr(medv ~ ., ncomp = 6, data = Boston, validation = "CV") -summary(fit_pls) -``` - -交叉验证的方法还可选留一交叉验证 `validation = "LOO"` 。预测的均方根误差 RMSEP 来评估交叉验证的结果。 - -```{r} -#| label: fig-pls -#| fig-cap: RMSE 随成分数量的变化 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true - -pls::validationplot(fit_pls, val.type = "RMSEP") -``` - -### 主成分回归 {#sec-principal-component-regression} - -主成分回归采用降维的方法处理高维和多重共线性问题。 - -10 折交叉验证，6 个主成分，拟合方法 `svdpc` 表示奇异值分解算法。 - -```{r} -fit_pcr <- pls::pcr(medv ~ ., ncomp = 6, data = Boston, validation = "CV") -summary(fit_pcr) -``` - -## 惩罚回归 {#sec-penalty-regression} - -本节主要介绍 4 个 R 包的使用，分别是 **glmnet** 包 [@Friedman2010]、 **ncvreg** 包 [@Breheny2011] 、 **lars** 包 [@Efron2004] 和 **abess** 包 [@abess2022]。 - -| R 包 | 惩罚方法 | 函数实现 | -|------------|-------------------|--------------------------------| -| **glmnet** | 岭回归 | `glmnet(...,alpha = 0)` | -| **glmnet** | Lasso 回归 | `glmnet(...,alpha = 1)` | -| **glmnet** | 弹性网络回归 | `glmnet(...,alpha)` | -| **glmnet** | 自适应 Lasso 回归 | `glmnet(...,penalty.factor)` | -| **glmnet** | 松驰 Lasso 回归 | `glmnet(...,relax = TRUE)` | -| **ncvreg** | MCP | `ncvreg(...,penalty = "MCP")` | -| **ncvreg** | SCAD | `ncvreg(...,penalty = "SCAD")` | -| **lars** | 最小角回归 | `lars(...,type = "lar")` | -| **abess** | 最优子集回归 | `abess()` | - -: 惩罚回归的 R 包实现 {#tbl-penalty} - -函数 `glmnet()` 的参数 `penalty.factor` 表示惩罚因子，默认值为全 1 向量，自适应 Lasso 回归中需要指定。弹性网络回归要求参数 `alpha` 介于 0-1 之间。 - -### 岭回归 {#sec-ridge-regression} - -岭回归 - -$$ -\mathcal{L}(\bm{\beta}) = \sum_{i=1}^{n}(y_i - \bm{x}_i^{\top}\bm{\beta})^2 + \lambda\|\bm{\beta}\|_2^2 -$$ - -```{r} -library(glmnet) -fit_ridge <- glmnet(x = Boston[, -14], y = Boston[, "medv"], family = "gaussian", alpha = 0) -``` - -```{r} -#| label: fig-ridge-glmnet -#| fig-cap: 岭回归 -#| fig-subcap: -#| - 回归系数的迭代路径 -#| - 惩罚系数的迭代路径 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true -#| layout-ncol: 2 - -plot(fit_ridge) -plot(fit_ridge$lambda, - ylab = expression(lambda), xlab = "迭代次数", main = "惩罚系数的迭代路径" -) -``` - -```{r} -fit_ridge$lambda[60] -coef(fit_ridge, s = 28.00535) -``` - -### Lasso 回归 {#sec-lasso-regression} - -Lasso 回归 - -$$ -\mathcal{L}(\bm{\beta}) = \sum_{i=1}^{n}(y_i - \bm{x}_i^{\top}\bm{\beta})^2 + \lambda\|\bm{\beta}\|_1 -$$ - -```{r} -fit_lasso <- glmnet(x = Boston[, -14], y = Boston[, "medv"], family = "gaussian", alpha = 1) -``` - -```{r} -#| label: fig-lasso-glmnet -#| fig-cap: Lasso 回归 -#| fig-subcap: -#| - 回归系数的迭代路径 -#| - 惩罚系数的迭代路径 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true -#| layout-ncol: 2 - -plot(fit_lasso) -plot(fit_lasso$lambda, - ylab = expression(lambda), xlab = "迭代次数", - main = "惩罚系数的迭代路径" -) -``` - -```{r} -fit_lasso$lambda[60] -coef(fit_lasso, s = 0.02800535) -``` - -### 弹性网络 {#sec-elastic-net-regression} - -弹性网络 [@Zou2005] - -$$ -\mathcal{L}(\bm{\beta}) = \sum_{i=1}^{n}(y_i - \bm{x}_i^{\top}\bm{\beta})^2 + \lambda(\frac{1-\alpha}{2}\|\bm{\beta}\|_2^2 + \alpha \|\bm{\beta}\|_1) -$$ - -```{r} -fit_elasticnet <- glmnet(x = Boston[, -14], y = Boston[, "medv"], family = "gaussian") -``` - -```{r} -#| label: fig-elasticnet-glmnet -#| fig-cap: 弹性网络 -#| fig-subcap: -#| - 回归系数的迭代路径 -#| - 惩罚系数的迭代路径 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true -#| layout-ncol: 2 - -plot(fit_elasticnet) -plot(fit_elasticnet$lambda, - ylab = expression(lambda), xlab = "迭代次数", - main = "惩罚系数的迭代路径" -) -``` - -```{r} -fit_elasticnet$lambda[60] -coef(fit_elasticnet, s = 0.02800535) -``` - -### 自适应 Lasso {#sec-adaptive-lasso} - -自适应 Lasso [@Zou2006] - -$$ -\mathcal{L}(\bm{\beta}) = \sum_{i=1}^{n}(y_i - \bm{x}_i^{\top}\bm{\beta})^2 + \lambda_n\sum_{j=1}^{p}\frac{1}{w_j}|\beta_j| -$$ - -普通最小二乘估计或岭回归估计的结果作为适应性 Lasso 回归的权重。其中 $w_j = (|\hat{\beta}_{ols_j}|)^{\gamma}$ 或 $w_j = (|\hat{\beta}_{ridge_j}|)^{\gamma}$ ， $\gamma$ 是一个用于调整自适应权重向量的正常数，一般建议的正常数是 0.5，1 或 2。 - -```{r} -# 岭权重 gamma = 1 -g <- 1 -set.seed(20232023) -## 岭回归 -ridge_model <- cv.glmnet( - x = as.matrix(Boston[, -14]), - y = Boston[, 14], alpha = 0 -) -ridge_coef <- as.matrix(coef(ridge_model, s = ridge_model$lambda.min)) -ridge_weight <- 1 / (abs(ridge_coef[-1, ]))^g - -## Adaptive Lasso -set.seed(20232023) -fit_adaptive_lasso <- cv.glmnet( - x = as.matrix(Boston[, -14]), - y = Boston[, 14], alpha = 1, - penalty.factor = ridge_weight # 惩罚权重 -) -``` - -岭回归和自适应 Lasso 回归模型的超参数 - -```{r} -#| label: fig-adaptive-lasso -#| fig-width: 4 -#| fig-height: 4 -#| fig-showtext: true -#| fig-cap: 自适应 Lasso 回归模型的超参数选择 -#| layout-ncol: 2 -#| fig-subcap: -#| - 岭回归 -#| - 自适应 Lasso 回归 - -plot(ridge_model) -plot(fit_adaptive_lasso) -``` - -$\lambda$ 超参数 - -```{r} -fit_adaptive_lasso$lambda.min -``` - -自适应 Lasso 回归参数 - -```{r} -coef(fit_adaptive_lasso, s = fit_adaptive_lasso$lambda.min) -``` - -预测 - -```{r} -pred_medv_adaptive_lasso <- predict( - fit_adaptive_lasso, newx = as.matrix(Boston[, -14]), - s = fit_adaptive_lasso$lambda.min, type = "response" -) -``` - -预测的均方根误差 - -```{r} -rmse(Boston[, 14], pred_medv_adaptive_lasso) -``` - -### 松弛 Lasso {#sec-relaxed-lasso} - -Lasso 回归倾向于将回归系数压缩到 0，松弛 Lasso - -$$ -\hat{\beta}_{relax}(\lambda,\gamma) = \gamma \hat{\beta}_{lasso}(\lambda) + (1 - \gamma)\hat{\beta}_{ols}(\lambda) -$$ - -其中，$\gamma \in[0,1]$ 是一个超参数。 - -```{r} -fit_relax_lasso <- cv.glmnet( - x = as.matrix(Boston[, -14]), - y = Boston[, "medv"], relax = TRUE -) -``` - -```{r} -#| label: fig-relax-lasso -#| fig-cap: "回归系数的迭代路径" -#| fig-width: 6 -#| fig-height: 5 -#| fig-showtext: true - -plot(fit_relax_lasso) -``` - -CV 交叉验证筛选出来的超参数 $\lambda$ 和 $\gamma$ ，$\gamma = 0$ 意味着松弛 Lasso 退化为 OLS 估计 - -```{r} -fit_relax_lasso$relaxed$lambda.min -fit_relax_lasso$relaxed$gamma.min -``` - -松弛 Lasso 回归系数与 OLS 估计的结果一样 - -```{r} -coef(fit_relax_lasso, s = "lambda.min", gamma = "gamma.min") -``` - -松弛 Lasso 预测 - -```{r} -pred_medv_relax_lasso <- predict( - fit_relax_lasso, - newx = as.matrix(Boston[, -14]), - s = "lambda.min", gamma = "gamma.min" -) -``` - -```{r} -rmse(Boston[, 14], pred_medv_relax_lasso) -``` - -### MCP {#sec-mcp-regression} - -**ncvreg** 包 [@Breheny2011] 提供额外的两种非凸/凹惩罚类型，分别是 MCP （minimax concave penalty）和 SCAD（smoothly clipped absolute deviation）。 - -```{r} -library(ncvreg) -fit_mcp <- ncvreg(X = Boston[, -14], y = Boston[, "medv"], penalty = "MCP") -``` - -```{r} -#| label: fig-mcp-ncvreg -#| fig-cap: "回归系数的迭代路径" -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true -#| par: true - -plot(fit_mcp) -``` - -回归系数 - -```{r} -coef(fit_mcp, lambda = 0.85) -summary(fit_mcp, lambda = 0.85) -``` - -10 折交叉验证，选择超参数 $\lambda$ - -```{r} -fit_mcp_cv <- cv.ncvreg( - X = Boston[, -14], y = Boston[, "medv"], - penalty = "MCP", seed = 20232023 -) -summary(fit_mcp_cv) -``` - -在 $\lambda = 0.1362$ 时，交叉验证的误差最小，非 0 回归系数 11 个。 - -```{r} -#| label: fig-mcp-lambda -#| fig-cap: "惩罚系数的迭代路径" -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true - -plot(fit_mcp_cv) -``` - -### SCAD {#sec-scad-regression} - -```{r} -fit_scad <- ncvreg(X = Boston[, -14], y = Boston[, "medv"], penalty = "SCAD") -``` - -```{r} -#| label: fig-scad-ncvreg -#| fig-cap: "回归系数的迭代路径" -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true -#| par: true - -plot(fit_scad) -``` - -```{r} -coef(fit_scad, lambda = 0.85) -summary(fit_scad, lambda = 0.85) -``` - -10 折交叉验证，选择超参数 $\lambda$ - -```{r} -fit_scad_cv <- cv.ncvreg( - X = Boston[, -14], y = Boston[, "medv"], - penalty = "SCAD", seed = 20232023 -) -summary(fit_scad_cv) -``` - -在 $\lambda = 0.1362$ 时，交叉验证的误差最小，非 0 回归系数 11 个。 - -```{r} -#| label: fig-scad-lambda -#| fig-cap: "惩罚系数的迭代路径" -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true - -plot(fit_scad_cv) -``` - -### 最小角回归 {#sec-least-angle} - -**lars** 包提供 Lasso 回归和最小角（Least Angle）回归[@Efron2004]。 - -```{r} -#| message: false - -library(lars) -# Lasso 回归 -fit_lars_lasso <- lars( - x = as.matrix(Boston[, -14]), y = as.matrix(Boston[, "medv"]), - type = "lasso", trace = FALSE, normalize = TRUE, intercept = TRUE -) -# LAR 回归 -fit_lars_lar <- lars( - x = as.matrix(Boston[, -14]), y = as.matrix(Boston[, "medv"]), - type = "lar", trace = FALSE, normalize = TRUE, intercept = TRUE -) -``` - -参数 `type = "lasso"` 表示采用 Lasso 回归，参数 `trace = FALSE` 表示不显示迭代过程，参数 `normalize = TRUE` 表示每个变量都标准化，使得它们的 L2 范数为 1，参数 `intercept = TRUE` 表示模型中包含截距项，且不参与惩罚。 - -Lasso 和最小角回归系数的迭代路径见下图。 - -```{r} -#| label: fig-lars-lasso -#| fig-width: 4 -#| fig-height: 4 -#| fig-showtext: true -#| fig-cap: Lasso 和最小角回归系数的迭代路径 -#| layout-ncol: 2 -#| fig-subcap: -#| - Lasso 回归 -#| - 最小角回归 - -plot(fit_lars_lasso) -plot(fit_lars_lar) -``` - -采用 10 折交叉验证筛选变量 - -```{r} -#| label: fig-cv-lars -#| fig-cap: 交叉验证均方误差的变化 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true -#| layout-ncol: 2 -#| fig-subcap: -#| - Lasso 回归 -#| - 最小角回归 - -set.seed(20232023) -cv.lars( - x = as.matrix(Boston[, -14]), y = as.matrix(Boston[, "medv"]), - type = "lasso", trace = FALSE, plot.it = TRUE, K = 10 -) -set.seed(20232023) -cv.lars( - x = as.matrix(Boston[, -14]), y = as.matrix(Boston[, "medv"]), - type = "lar", trace = FALSE, plot.it = TRUE, K = 10 -) -``` - -### 最优子集回归 {#sec-best-subset} - -$$ -\mathcal{L}(\bm{\beta}) = \sum_{i=1}^{n}(y_i - \bm{x}_i^{\top}\bm{\beta})^2 + \lambda\|\bm{\beta}\|_0 -$$ - -最优子集回归，添加 L0 惩罚，[abess](https://github.com/abess-team/abess) 包 [@abess2022] 支持线性回归、泊松回归、逻辑回归、多项回归等模型，可以非常高效地做最优子集筛选变量。 - -```{r} -library(abess) -fit_abess <- abess(medv ~ ., data = Boston, family = "gaussian", - tune.type = "cv", nfolds = 10, seed = 20232023) -``` - -参数 `tune.type = "cv"` 表示交叉验证的方式确定超参数来筛选变量，参数 `nfolds = 10` 表示将数据划分为 10 份，采用 10 折交叉验证，参数 `seed` 用来设置随机数，以便可重复交叉验证 CV 的结果。惩罚系数的迭代路径见下左图。使用交叉验证筛选变量个数，不同的 support size 表示进入模型中的变量数目。 - -```{r} -#| label: fig-abess-lambda -#| fig-cap: 最优子集回归 -#| fig-subcap: -#| - 惩罚系数的迭代路径 -#| - 交叉验证筛选变量个数 -#| fig-width: 5 -#| fig-height: 5 -#| fig-showtext: true -#| par: true -#| layout-ncol: 2 - -plot(fit_abess, label = TRUE, main = "惩罚系数的迭代路径") -plot(fit_abess, type = "tune", main = "交叉验证筛选变量个数") -``` - -从上右图可以看出，选择 6 个变量是比较合适的，作为最终的模型。 - -```{r} -best_model <- extract(fit_abess, support.size = 6) -# 模型的结果，惩罚参数值、各个变量的系数 -str(best_model) -``` - -## 支持向量机 {#sec-svm-regression} - -```{r} -library(kernlab) -fit_ksvm <- ksvm(medv ~ ., data = Boston) -fit_ksvm -``` - -```{r} -# 预测 -pred_medv_svm <- predict(fit_ksvm, newdata = Boston) -# RMSE -rmse(Boston$medv, pred_medv_svm) -``` - -## 神经网络 {#sec-nnet-regression} - -单隐藏层的神经网络 - -```{r} -library(nnet) -fit_nnet <- nnet(medv ~ ., - data = Boston, trace = FALSE, - size = 12, # 隐藏层单元数量 - maxit = 500, # 最大迭代次数 - linout = TRUE, # 线性输出单元 - decay = 0.01 # 权重下降的参数 -) -pred_medv_nnet <- predict(fit_nnet, newdata = Boston[, -14], type = "raw") -rmse(Boston$medv, pred_medv_nnet) -``` - -## 决策树 {#sec-rpart-regression} - -```{r} -library(rpart) -fit_rpart <- rpart(medv ~ ., - data = Boston, control = rpart.control(minsplit = 5) -) - -pred_medv_rpart <- predict(fit_rpart, newdata = Boston[, -14]) - -rmse(Boston$medv, pred_medv_rpart) -``` - -```{r} -#| label: fig-Boston-rpart -#| fig-width: 5 -#| fig-height: 4 -#| fig-cap: 分类回归树 -#| fig-showtext: true -#| par: true - -library(rpart.plot) -rpart.plot(fit_rpart) -``` - -## 随机森林 {#sec-rf-regression} - -```{r} -library(randomForest) -fit_rf <- randomForest(medv ~ ., data = Boston) -print(fit_rf) - -pred_medv_rf <- predict(fit_rf, newdata = Boston[, -14]) -rmse(Boston$medv, pred_medv_rf) -``` - -## 集成学习 {#sec-boosting-regression} - -```{r} -# 输入数据 x 和采样比例 prop -add_mark <- function(x = Boston, prop = 0.7) { - idx <- sample(x = nrow(x), size = floor(nrow(x) * prop)) - rbind( - cbind(x[idx, ], mark = "train"), - cbind(x[-idx, ], mark = "test") - ) -} - -set.seed(20232023) -Boston_df <- add_mark(Boston, prop = 0.7) - -library(data.table) -Boston_dt <- as.data.table(Boston_df) - -# 训练数据 -Boston_train <- list( - data = as.matrix(Boston_dt[Boston_dt$mark == "train", -c("mark", "medv")]), - label = as.matrix(Boston_dt[Boston_dt$mark == "train", "medv"]) -) -# 测试数据 -Boston_test <- list( - data = as.matrix(Boston_dt[Boston_dt$mark == "test", -c("mark", "medv")]), - label = as.matrix(Boston_dt[Boston_dt$mark == "test", "medv"]) -) -``` - -```{r} -library(xgboost) -Boston_xgb <- xgboost( - data = Boston_train$data, - label = Boston_train$label, - objective = "reg:squarederror", # 学习任务 - eval_metric = "rmse", # 评估指标 - nrounds = 6 -) -``` - -```{r} -# ?predict.xgb.Booster -Boston_pred <- predict(object = Boston_xgb, newdata = Boston_test$data) -# RMSE -rmse(Boston_test$label, Boston_pred) -``` diff --git a/time-series-regression.qmd b/time-series-regression.qmd deleted file mode 100644 index 9a253089..00000000 --- a/time-series-regression.qmd +++ /dev/null @@ -1,617 +0,0 @@ -# 时间序列回归 {#sec-time-series-regression} - -```{r} -#| echo: false - -source("_common.R") -``` - -```{r} -#| message: false - -library(cmdstanr) -library(zoo) -library(xts) # xts 依赖 zoo -library(fGarch) -library(INLA) -library(mgcv) -library(tensorflow) -library(ggplot2) -library(bayesplot) -``` - -## 随机波动率模型 - -随机波动率模型主要用于股票时间序列数据建模。本节以美团股价数据为例介绍随机波动率模型，并分别以 Stan 框架和 **fGarch** 包拟合模型。 - -```{r} -#| label: fig-meituan-stack -#| message: false -#| fig-cap: 美团股价走势 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 - -# 美团上市至 2023-07-15 -meituan <- readRDS(file = "data/meituan.rds") -library(zoo) -library(xts) -library(ggplot2) -autoplot(meituan[, "3690.HK.Adjusted"]) + - theme_classic() + - labs(x = "日期", y = "股价") -``` - -对数收益率的计算公式如下： - -$$ -\text{对数收益率} = \ln(\text{今日收盘价} / \text{昨日收盘价} ) = \ln (1 + \text{普通收益率}) -$$ - -下图给出股价对数收益率变化和股价对数收益率的分布，可以看出在不同时间段，收益率波动幅度是不同的，美团股价对数收益率的分布可以看作正态分布。 - -```{r} -#| label: fig-meituan-log-return -#| fig-cap: 美团股价对数收益率的情况 -#| fig-subcap: -#| - 对数收益率的变动 -#| - 对数收益率的分布 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| layout-ncol: 2 - -meituan_log_return <- diff(log(meituan[, "3690.HK.Adjusted"]))[-1] -autoplot(meituan_log_return) + - theme_classic() + - labs(x = "日期", y = "对数收益率") -ggplot(data = meituan_log_return, aes(x = `3690.HK.Adjusted`)) + - geom_histogram(color = "black", fill = "gray", bins = 30) + - theme_classic() + - labs(x = "对数收益率", y = "频数（天数）") -``` - -检查对数收益率序列的自相关图 - -```{r} -#| label: fig-log-return -#| fig-cap: 对数收益率的自相关图 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -acf(meituan_log_return, main = "") -``` - -发现，滞后 2、3、6、26 阶都有出界，滞后 17 阶略微出界，其它的自相关都在零水平线的界限内。 - -```{r} -Box.test(meituan_log_return, lag = 12, type = "Ljung") -``` - -在 0.05 水平下拒绝了白噪声检验，说明对数收益率序列存在相关性。同理，也注意到对数收益率的绝对值和平方序列都不是独立的，存在相关性。 - -```{r} -# ARCH 效应的检验 -Box.test((meituan_log_return - mean(meituan_log_return))^2, - lag = 12, type = "Ljung") -``` - -结果高度显著，说明有 ARCH 效应。 - -### Stan 框架 - -随机波动率模型如下 - -$$ -\begin{aligned} -y_t &= \epsilon_t \exp(h_t / 2) \\ -h_{t+1} &= \mu + \phi (h_t - \mu) + \delta_t \sigma \\ -h_1 &\sim \textsf{normal}\left( \mu, \frac{\sigma}{\sqrt{1 - \phi^2}} \right) \\ -\epsilon_t &\sim \textsf{normal}(0,1) \\ -\delta_t &\sim \textsf{normal}(0,1) -\end{aligned} -$$ - -其中， $y_t$ 表示在时间 $t$ 时股价的回报（对数收益率），$\epsilon_t$ 表示股价回报在时间 $t$ 时的白噪声扰/波动，$\delta_t$ 表示波动率在时间$t$ 时的波动。$h_t$ 表示对数波动率，带有参数 $\mu$ （对数波动率的均值），$\phi$ （对数波动率的趋势）。代表波动率的序列 $\{h_t\}$ 假定是平稳 $(|\phi| < 1)$ 的随机过程，$h_1$ 来自平稳的分布（此处为正态分布），$\epsilon_t$ 和 $\delta_t$ 是服从不相关的标准正态分布。 - -Stan 代码如下 - -```{verbatim, file="code/stochastic_volatility_models.stan", lang="stan"} -``` - -编译和拟合模型 - -```{r} -#| message: false - -library(cmdstanr) -# 编译模型 -mod_volatility_normal <- cmdstan_model( - stan_file = "code/stochastic_volatility_models.stan", - compile = TRUE, cpp_options = list(stan_threads = TRUE) -) -# 准备数据 -mdata = list(T = 1274, y = as.vector(meituan_log_return)) -# 拟合模型 -fit_volatility_normal <- mod_volatility_normal$sample( - data = mdata, - chains = 2, - parallel_chains = 2, - iter_warmup = 1000, - iter_sampling = 1000, - threads_per_chain = 2, - seed = 20232023, - show_messages = FALSE, - refresh = 0 -) -# 输出结果 -fit_volatility_normal$summary(c("mu", "phi", "sigma", "lp__")) -``` - -### fGarch 包 - -[《金融时间序列分析讲义》](https://www.math.pku.edu.cn/teachers/lidf/course/fts/ftsnotes/html/_ftsnotes/index.html)两个波动率建模方法 - -- 自回归条件异方差模型（Autoregressive Conditional Heteroskedasticity，简称 ARCH）。 -- 广义自回归条件异方差模型 （Generalized Autoregressive Conditional Heteroskedasticity，简称 GARCH ） - -确定 ARCH 模型的阶，观察残差的平方的 ACF 和 PACF 。 - -```{r} -#| label: fig-log-return-resid -#| fig-cap: 对数收益率的残差平方 -#| fig-subcap: -#| - 自相关图 -#| - 偏自相关图 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| layout-ncol: 2 -#| par: true - -acf((meituan_log_return - mean(meituan_log_return))^2, main = "") -pacf((meituan_log_return - mean(meituan_log_return))^2, main = "") -``` - -发现 ACF 在滞后 1、2、3 阶比较突出，PACF 在滞后 1、2、16、18、29 阶比较突出。所以下面先来考虑低阶的 ARCH(2) 模型，设 $r_t$ 为对数收益率。 - -$$ -\begin{aligned} -r_t &= \mu + a_t, \quad a_t = \sigma_t \epsilon_t, \quad \epsilon_t \sim \mathcal{N}(0,1) \\ -\sigma_t^2 &= \alpha_0 + \alpha_1 a_{t-1}^2 - + \alpha_2 a_{t-2}^2. -\end{aligned} -$$ - -拟合 ARCH 模型，比较模型估计结果，根据系数显著性的结果，采纳 ARCH(2) 模型。 - -```{r} -#| message: false - -library(fGarch) -meituan_garch1 <- garchFit( - formula = ~ 1 + garch(2, 0), - data = meituan_log_return, trace = FALSE, cond.dist = "std" -) -summary(meituan_garch1) -``` - -函数 `garchFit()` 的参数 `cond.dist` 默认值为 `"norm"` 表示标准正态分布，`cond.dist = "std"` 表示标准 t 分布。模型均值的估计值接近 0 是符合预期的，且显著性没通过，对数收益率在 0 上下波动。将估计结果代入模型，得到 - -$$ -\begin{aligned} -r_t &= -5.665 \times 10^{-5} + a_t, \quad a_t = \sigma_t \epsilon_t, \quad \epsilon_t \sim \mathcal{N}(0,1) \\ -\sigma_t^2 &= 1.070 \times 10^{-3} + 0.1156 a_{t-1}^2 + 0.1438a_{t-2}^2. -\end{aligned} -$$ - -下面考虑 GARCH(1,1) 模型 - -$$ -\begin{aligned} -r_t &= \mu + a_t, \quad a_t = \sigma_t \epsilon_t, \quad \epsilon_t \sim \mathcal{N}(0,1) \\ -\sigma_t^2 &= \alpha_0 + \alpha_1 a_{t-1}^2 - + \beta_1 \sigma_{t-1}^2. -\end{aligned} -$$ - -```{r} -meituan_garch2 <- garchFit( - formula = ~ 1 + garch(1, 1), - data = meituan_log_return, trace = FALSE, cond.dist = "std" -) -summary(meituan_garch2) -``` - -波动率的贡献主要来自 $\sigma_{t-1}^2$ ，其系数 $\beta_1$ 为 0.918。通过对数似然的比较，可以发现 GARCH(1,1) 模型比 ARCH(2) 模型更好。 - -## 贝叶斯可加模型 - -大规模时间序列回归，观察值是比较多的，可达数十万、数百万，乃至更多。粗粒度时时间跨度往往很长，比如数十年的天粒度数据，细粒度时时间跨度可短可长，比如数年的半小时级数据，总之，需要包含多个季节的数据，各种季节性重复出现。通过时序图可以观察到明显的季节性，而且往往是多种周期不同的季节性混合在一起，有时还包含一定的趋势性。举例来说，比如 2018-2023 年美国旧金山犯罪[事件报告数据](https://data.sfgov.org/Public-Safety/Police-Department-Incident-Reports-2018-to-Present/wg3w-h783)，事件数量的变化趋势，除了上述季节性因素，特殊事件疫情肯定会影响，数据规模约 200 M 。再比如 2018-2023 年美国境内和跨境旅游业中的[航班数据](https://www.transtats.bts.gov/)，原始数据非常大，R 包 [nycflights13](https://github.com/tidyverse/nycflights13) 提供纽约机场的部分航班数据。 - -为简单起见，下面以 R 内置的数据集 AirPassengers 为例，介绍 Stan 框架和 INLA 框架建模的过程。数据集 AirPassengers 包含周期性（季节性）和趋势性。作为对比的基础，下面建立非线性回归模型，趋势项和周期项是可加的形式： - -$$ -y = at + b + c \sin(\frac{t}{12} \times 2\pi) + d \cos(\frac{t}{12} \times 2\pi) + \epsilon -$$ - -根据数据变化的周期规律，设置周期为 12，还可以在模型中添加周期为 3 或 4 的小周期。其中，$y$ 代表观察值， $a,b,c,d$ 为待定的参数，$\epsilon$ 代表服从标准正态分布的随机误差。 - -```{r} -#| label: fig-lm -#| fig-cap: 非线性回归 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -air_passengers_df <- data.frame(y = as.vector(AirPassengers), t = 1:144) -fit_lm1 <- lm(y ~ t + sin(t / 12 * 2 * pi) + cos(t / 12 * 2 * pi), data = air_passengers_df) -fit_lm2 <- update(fit_lm1, . ~ . + - sin(t / 12 * 2 * 2 * pi) + cos(t / 12 * 2 * 2 * pi), data = air_passengers_df -) -fit_lm3 <- update(fit_lm2, . ~ . + - sin(t / 12 * 3 * 2 * pi) + cos(t / 12 * 3 * 2 * pi), data = air_passengers_df -) -plot(y ~ t, air_passengers_df, type = "l") -lines(x = air_passengers_df$t, y = fit_lm1$fitted.values, col = "red") -lines(x = air_passengers_df$t, y = fit_lm2$fitted.values, col = "green") -lines(x = air_passengers_df$t, y = fit_lm3$fitted.values, col = "orange") -``` - -模型 1 已经很好地捕捉到趋势和周期信息，当添加小周期后，略有改善，继续添加更多的小周期，不再有明显改善。实际上，小周期对应的回归系数也将不再显著。所以，这类模型的优化空间见顶了，需要进一步观察和利用残差的规律，使用更加复杂的模型。 - -### Stan 框架 - -非线性趋势、多季节性（多个周期混合）、特殊节假日、突发热点事件、残差成分（平稳），能同时应对这五种情况的建模方法是贝叶斯可加模型和神经网络模型，比如基于 Stan 实现的 prophet 包和 tensorflow 框架。 - -::: callout-tip -prophet 包是如何同时处理这些情况，是否可以在 cmdstanr 包中实现，是否可以在 mgcv 和 INLA 中实现？ -::: - -```{r} -library(cmdstanr) -``` - -### INLA 框架 {#sec-kaust-inla} - -阿卜杜拉国王科技大学（King Abdullah University of Science and Technology 简称 KAUST）的 Håvard Rue 等开发了 INLA 框架 [@Rue2009]。《贝叶斯推断与 INLA 》的第3章混合效应模型中随机游走部分 [@Virgilio2020]，一个随机过程（如随机游走、AR(p) 过程）作为随机效应。AirPassengers 的方差在变大，取对数尺度后，方差基本保持不变，一阶差分后基本保持平稳。 - -```{r} -#| label: fig-log-airpassengers -#| fig-cap: AirPassengers 的时序图 -#| fig-subcap: -#| - 对数尺度 -#| - 一阶差分 -#| layout-ncol: 2 -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true - -library(ggfortify) -autoplot(log(AirPassengers)) + - theme_classic() + - labs(x = "年月", y = "对数值") -autoplot(diff(log(AirPassengers))) + - theme_classic() + - labs(x = "年月", y = "差分对数值") -``` - -因此，下面基于对数尺度建模。首先考虑 RW1 随机游走模型，而后考虑季节性。RW1 模型意味着取对数、一阶差分后序列平稳高斯过程，序列值服从高斯分布。下面设置似然函数的高斯先验 $\mathcal{N}(1,0.2)$ ，目的是防止过拟合。 - -```{r} -#| message: false - -library(INLA) -inla.setOption(short.summary = TRUE) -air_passengers_df <- data.frame( - y = as.vector(AirPassengers), - year = as.factor(rep(1949:1960, each = 12)), - month = as.factor(rep(1:12, times = 12)), - ID = 1:length(AirPassengers) -) -mod_inla_rw1 <- inla( - formula = log(y) ~ year + f(ID, model = "rw1"), - family = "gaussian", data = air_passengers_df, - control.family = list(hyper = list(prec = list(param = c(1, 0.2)))), - control.predictor = list(compute = TRUE) -) -summary(mod_inla_rw1) -``` - -这里，将年份作为因子型变量，从输出结果可以看出，以1949年作为参照，回归系数的后验均值在逐年变大，这符合 AirPassengers 时序图呈现的趋势。 - -存在周期性的波动规律，考虑季节性 - -```{r} -mod_inla_sea <- inla( - formula = log(y) ~ year + f(ID, model = "seasonal", season.length = 12), - family = "gaussian", data = air_passengers_df, - control.family = list(hyper = list(prec = list(param = c(1, 0.2)))), - control.predictor = list(compute = TRUE) -) -summary(mod_inla_sea) -``` - -最后，将两个模型的拟合结果展示出来，见下图，黑线表示原对数值，红线表示拟合值，灰色区域表示在置信水平 95% 下的区间。区间更短说明季节性模型更好。 - -```{r} -#| label: fig-fitted-airpassengers -#| fig-cap: AirPassengers 的拟合图 -#| fig-subcap: -#| - 随机游走模型 -#| - 季节效应模型 -#| layout-ncol: 2 -#| fig-width: 5 -#| fig-height: 4 -#| fig-showtext: true - -mod_inla_rw1_fitted <- data.frame( - ID = 1:length(AirPassengers), - y = as.vector(log(AirPassengers)), - mean = mod_inla_rw1$summary.fitted.values$mean, - `0.025quant` = mod_inla_rw1$summary.fitted.values$`0.025quant`, - `0.975quant` = mod_inla_rw1$summary.fitted.values$`0.975quant`, - check.names = FALSE -) -mod_inla_sea_fitted <- data.frame( - ID = 1:length(AirPassengers), - y = as.vector(log(AirPassengers)), - mean = mod_inla_sea$summary.fitted.values$mean, - `0.025quant` = mod_inla_sea$summary.fitted.values$`0.025quant`, - `0.975quant` = mod_inla_sea$summary.fitted.values$`0.975quant`, - check.names = FALSE -) -ggplot(data = mod_inla_rw1_fitted, aes(ID)) + - geom_ribbon(aes(ymin = `0.025quant`, ymax = `0.975quant`), fill = "gray") + - geom_line(aes(y = y)) + - geom_line(aes(y = mean), color = "red") + - theme_classic() + - labs(x = "序号", y = "对数值") -ggplot(data = mod_inla_sea_fitted, aes(ID)) + - geom_ribbon(aes(ymin = `0.025quant`, ymax = `0.975quant`), fill = "gray") + - geom_line(aes(y = y)) + - geom_line(aes(y = mean), color = "red") + - theme_classic() + - labs(x = "序号", y = "对数值") -``` - -## 一些非参数模型 - -### mgcv 包 {#sec-gnu-mgcv} - -**mgcv** 包 [@Wood2017] 是 R 软件内置的推荐组件，由 Simon Wood 开发和维护，历经多年，成熟稳定。函数 `bam()` 相比于函数 `gam()` 的优势是可以处理大规模的时间序列数据。对于时间序列数据预测，数万和百万级观测值都可以 [@wood2015]。 - -```{r} -air_passengers_tbl <- data.frame( - y = as.vector(AirPassengers), - year = rep(1949:1960, each = 12), - month = rep(1:12, times = 12) -) -mod1 <- gam(y ~ s(year) + s(month, bs = "cr", k = 12), - data = air_passengers_tbl, family = gaussian -) -summary(mod1) -``` - -观察年和月的趋势变化，逐年增长趋势基本是线性的，略有波动，逐月变化趋势比较复杂，不过，可以明显看出在 7-9 月是高峰期，11 月和1-3月是低谷期。 - -```{r} -#| label: fig-mgcv-trend -#| fig-cap: 年和月的趋势变化 -#| fig-showtext: true -#| fig-width: 7 -#| fig-height: 4 -#| par: true - -layout(matrix(1:2, nrow = 1)) -plot(mod1, shade = TRUE) -``` - -将拟合效果绘制出来，见下图，整体上，捕捉到了趋势和周期，不过，存在欠拟合，年周期内波动幅度随时间有变化趋势，趋势和周期存在交互作用。 - -```{r} -#| label: fig-mgcv-1 -#| fig-cap: 趋势拟合效果 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -air_passengers_ts <- ts(mod1$fitted.values, start = c(1949, 1), frequency = 12) -plot(AirPassengers) -lines(air_passengers_ts, col = "red") -``` - -整体上，乘客数逐年呈线性增长，每年不同月份呈现波动，淡季和旺季出行的流量有很大差异，近年来，这种差异的波动在扩大。为了刻画这种情况，考虑年度趋势和月度波动的交互作用。 - -```{r} -mod2 <- gam(y ~ s(year, month), data = air_passengers_tbl, family = gaussian) -summary(mod2) -``` - -可以看到，调整的 $R^2$ 明显增加，拟合效果更好，各年各月份的乘客数变化，见下图。 - -```{r} -#| label: fig-mgcv-interaction -#| fig-cap: 交互作用 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 - -op <- par(mar = c(4, 4, 2, 0)) -plot(mod2) -on.exit(par(op), add = TRUE) -``` - -上图是轮廓图，下面用透视图展示趋势拟合的效果。 - -```{r} -#| label: fig-mgcv-persp -#| fig-cap: 趋势拟合效果 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 - -op <- par(mar = c(0, 1.5, 0, 0)) -vis.gam(mod2, theta = -35, phi = 20, ticktype = "detailed", expand = .65, zlab = "") -on.exit(par(op), add = TRUE) -``` - -最后，在原始数据的基础上，添加拟合数据，得到如下拟合趋势图，与前面的拟合图比较，可以看出效果提升很明显。 - -```{r} -#| label: fig-mgcv-2 -#| fig-cap: 趋势拟合效果 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -air_passengers_ts <- ts(mod2$fitted.values, start = c(1949, 1), frequency = 12) -plot(AirPassengers) -lines(air_passengers_ts, col = "red") -``` - -### tensorflow 框架 {#sec-google-tensorflow} - -前面介绍的模型都具有非常强的可解释性，比如各个参数对模型的作用。对于复杂的时间序列数据，比较适合用复杂的模型来拟合，看重模型的泛化能力，而不那么关注模型的机理。 - -多层感知机是一种全连接层的前馈神经网络。**nnet** 包的函数 `nnet()` 实现了单隐藏层的简单前馈神经网络，可用于时间序列预测，也可用于分类数据的预测。作为对比的基础，下面先用 nnet 包训练和预测数据。 - -```{r} -# 准备数据 -air_passengers <- as.matrix(embed(AirPassengers, 4)) -colnames(air_passengers) <- c("y", "x3", "x2", "x1") -data_size <- nrow(air_passengers) -# 拆分数据集 -train_size <- floor(data_size * 0.67) -train_data <- air_passengers[1:train_size, ] -test_data <- air_passengers[train_size:data_size, ] - -# 随机数种子对结果的影响非常大 试试 set.seed(20232023) -set.seed(20222022) -# 单隐藏层 8 个神经元 -mod_nnet <- nnet::nnet( - y ~ x1 + x2 + x3, - data = air_passengers, # 数据集 - subset = 1:train_size, # 训练数据的指标向量 - linout = TRUE, size = 4, rang = 0.1, - decay = 5e-4, maxit = 400, trace = FALSE -) -# 预测 -train_pred <- predict(mod_nnet, newdata = air_passengers[1:train_size,], type = "raw") -# 训练集 RMSE -sqrt(mean((air_passengers[1:train_size, "y"] - train_pred )^2)) -# 预测 -test_pred <- predict(mod_nnet, newdata = air_passengers[-(1:train_size),], type = "raw") -# 测试集 RMSE -sqrt(mean((air_passengers[-(1:train_size), "y"] - test_pred)^2)) -``` - -下面将原观测序列，训练集和测试集上的预测序列放在一张图上展示。图中，红色曲线表示训练集上的预测结果，绿色曲线为测试集上预测结果。 - -```{r} -#| label: fig-nnet -#| fig-cap: 单层感知机预测 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -train_pred_ts <- ts(data = train_pred, start = c(1949, 3), frequency = 12) -test_pred_ts <- ts(data = test_pred, start = c(1957, 1), frequency = 12) -plot(AirPassengers) -lines(train_pred_ts, col = "red") -lines(test_pred_ts, col = "green") -``` - -由图可知，在测试集上，随着时间拉长，预测越来越不准。 - -下面使用 tensorflow 包构造**多层**感知机训练数据和预测。 - -```{r} -#| message: false - -library(tensorflow) -library(keras) -set_random_seed(20222022) -# 模型结构 -mod_mlp <- keras_model_sequential() |> - layer_dense(units = 12, activation = "relu", input_shape = c(3)) |> - layer_dense(units = 8, activation = "relu") |> - layer_dense(units = 1) -# 训练目标 -compile(mod_mlp, - loss = "mse", # 损失函数 - optimizer = "adam", # 优化器 - metrics = "mae" # 监控度量 -) -# 模型概览 -summary(mod_mlp) -``` - -输入层为 3 个节点，中间两个隐藏层，第一层为 12 个节点，第二层为 8 个节点，全连接网络，最后输出为一层单节点，意味着单个输出。每一层都有节点和权重，参数总数为 161。 - -```{r} -# 拟合模型 -fit(mod_mlp, - x = train_data[, c("x1", "x2", "x3")], - y = train_data[, "y"], - epochs = 200, - batch_size = 10, # 每次更新梯度所用的样本量 - validation_split = 0.2, # 从训练数据中拆分一部分用作验证集 - verbose = 0 # 不显示训练进度 -) -# 将测试数据代入模型，计算损失函数和监控度量 -evaluate(mod_mlp, test_data[, c("x1", "x2", "x3")], test_data[, "y"]) -# 测试集上的预测 -mlp_test_pred <- predict(mod_mlp, test_data[, c("x1", "x2", "x3")]) -mlp_train_pred <- predict(mod_mlp, train_data[, c("x1", "x2", "x3")]) -sqrt(mean((test_data[, "y"] - mlp_test_pred)^2)) # 计算均方根误差 -``` - -从 RMSE 来看，MLP（多层感知机）预测效果比单层感知机稍好些，可网络复杂度是增加很多的。 - -```{r} -#| label: fig-tensorflow-mlp -#| fig-cap: 多层感知机预测 -#| fig-showtext: true -#| fig-width: 5 -#| fig-height: 4 -#| par: true - -mlp_train_pred_ts <- ts(data = mlp_train_pred, start = c(1949, 3), frequency = 12) -mlp_test_pred_ts <- ts(data = mlp_test_pred, start = c(1957, 1), frequency = 12) -plot(AirPassengers) -lines(mlp_train_pred_ts, col = "red") -lines(mlp_test_pred_ts, col = "green") -``` - -下面用 LSTM （长短期记忆）神经网络来训练时间序列数据，预测未来一周的趋势。输出不再是一天（单点输出），而是 7 天的预测值（多点输出）。参考 **tensorflow** 包的[官网](https://tensorflow.rstudio.com/guides/keras/working_with_rnns#introduction)中 RNN 递归神经网络的介绍。 - -## 习题 - -1. 基于 R 软件内置的数据集 `sunspots` 和 `sunspot.month` 比较 INLA 和 **mgcv** 框架的预测效果。 - - ```{r} - #| label: fig-sunspots - #| fig-cap: 预测月粒度太阳黑子数量 - #| fig-width: 7 - #| fig-height: 4 - #| fig-showtext: true - #| code-fold: true - #| echo: !expr knitr::is_html_output() - - sunspots_tbl <- broom::tidy(sunspots) - sunspots_month_tbl <- broom::tidy(sunspot.month) - ggplot() + - geom_line(data = sunspots_month_tbl, aes(x = index, y = value), color = "red") + - geom_line(data = sunspots_tbl, aes(x = index, y = value)) + - theme_bw() + - labs(x = "年月", y = "数量") - ``` - - 图中黑线和红线分别表示 1749-1983 年、1984-2014 年每月太阳黑子数量。