R-统计编程和数据建模高级教程-全-

R 统计编程和数据建模高级教程（全）

原文：Advanced R Statistical Programming and Data Models

协议：CC BY-NC-SA 4.0

一、单变量数据可视化

本书其余部分讨论的大多数统计模型对数据和最佳模型做出假设。作为数据分析师，我们经常必须指定我们假设数据来自的分布。异常值，也称为极端值或异常值，也可能对许多统计模型的结果产生不适当的影响。在这一章中，我们研究了一次探索一个变量(即单变量)的分布和异常值的视觉和图形方法。本章的目标并不是专门创建漂亮的或出版物质量的图表，也不是显示结果，而是使用图表来理解变量的分布并识别异常值。本章重点关注单变量数据可视化，下一章将采用一些相同的概念，但应用于多变量分布，并涵盖如何评估变量之间的关系。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(MASS)
library(JWileymisc)
library(data.table)

options(width = 70, digits = 2)

ggplot2包[109]创建了优雅的图形，而cowplot包是一个使图形更整洁的插件[117]。MASS包提供了测试不同分布如何拟合数据的函数。JWileymisc包是由本文作者之一维护的，它提供了各种各样的功能，让我们可以专注于本章中的图形。这个data.table包将会被大量用于数据管理。

1.1 分销

可视化观察到的分布

许多统计模型要求指定变量的分布。直方图使用条形来绘制分布图，可能是最常用的显示单个变量分布的图形。虽然相对较少，但堆积点图是另一种方法，它提供了一种精确的方式来可视化显示各个数据点的数据分布。最后，密度图也很常见，它用一条线来表示在任何给定值下的近似密度或数据量。

堆积点图和直方图

点状图的工作原理是为每个观察到的数据值绘制一个点，如果两个点落在另一个点上，它们就被堆叠起来[118]。与直方图或密度图相比，点阵图的独特之处在于，它们实际绘制的是原始的单个数据点，而不是汇总或汇总它们。这使得点状图成为观察变量分布或扩散的一个很好的起点，尤其是当你的观察值相对较少的时候。

绘制单个数据点的粒度方法也有散点图的局限性。即使是中等规模的数据集(例如几百个)，绘制单个值也是不切实际的。对于数千或数百万的观察值，点状图在可视化总体分布方面甚至更不有效。

我们可以使用ggplot2轻松创建一个图，结果如图 1-1 所示。

img/439480_1_En_1_Fig1_HTML.png

图 1-1

旧车每加仑英里数的堆积点图

ggplot(mtcars, aes(mpg)) +
  geom_dotplot()

## 'stat_bindot()' using 'bins = 30'. Pick better value with 'binwidth'.

简单地说，ggplot2的大部分代码遵循以下代码片段所示的格式。在我们的例子中，我们想要一个点状图，所以几何对象，或“geom”，是一个点状图(geom_dotplot())。有许多优秀的在线教程和书籍可以学习如何使用ggplot2包来制作图形，所以我们在这里不再对ggplot2做更多的介绍。特别是，开发ggplot2的 Hadley Wickham 最近更新了关于该包的书， ggplot2:用于数据分析的优雅图形【109】，这是一个极好的指南。对于那些喜欢更少的概念背景和更多的食谱的人，我们推荐温斯顿·张的 R 图形食谱。

  ggplot(the-data, aes(variable-to-plot)) +
    geom_type-of-graph()

与绘制原始数据的点图不同，直方图是一个条形图，其中条形的高度是在条形宽度指定的范围内的值的计数。您可以改变条形的宽度，以控制在一个条形中聚合和计数的相邻值的数量。较窄的条形聚合了较少的数据点，提供了更精细的视图。较宽的条形聚集更多，并提供更宽的视图。图 1-2 显示了著名的 iris 数据集中花的萼片长度分布的直方图。

img/439480_1_En_1_Fig2_HTML.png

图 1-2

来自虹膜数据的萼片长度直方图

ggplot(iris, aes(Sepal.Length)) +
  geom_histogram()

## 'stat_bin()' using 'bins = 30'. Pick better value with 'binwidth'.

如果您知道分布的形状(例如，正态分布)，您可以检查变量的直方图是否看起来像您认识的分布的形状。在萼片长度数据的情况下，它们看起来近似正态分布，尽管它们显然不是完美的。

如果数据看起来不符合我们希望的分布(如正态分布)，通常会对原始数据进行转换。同样，直方图是检查变换后分布情况的有用方法。图 1-3 显示了一年一度的加拿大猞猁捕获的直方图。从图中我们可以看到变量是正偏的(有一个长的右尾巴)。

img/439480_1_En_1_Fig3_HTML.png

图 1-3

加拿大猞猁年度捕获直方图

ggplot(data.table(lynx = as.vector(lynx)), aes(lynx)) +
  geom_histogram()

## 'stat_bin()' using 'bins = 30'. Pick better value with 'binwidth'.

对于正偏差，平方根或对数变换有助于减少正偏差，并使变量更接近正态分布(假设没有负值)。图 1-4 显示了自然对数变换后的猞猁诱捕直方图。

img/439480_1_En_1_Fig4_HTML.png

图 1-4

自然对数变换后的加拿大猞猁年度捕获直方图

ggplot(data.table(lynx = as.vector(lynx)), aes(log(lynx))) +
  geom_histogram()

## 'stat_bin()' using 'bins = 30'. Pick better value with 'binwidth'.

密度图

将观察到的数据分布可视化的另一个常用工具是绘制经验密度图。除了用geom_density()代替geom_histogram()外，ggplot2的代码与直方图的代码相同。代码如下，结果如图 1-5 所示。

img/439480_1_En_1_Fig5_HTML.png

图 1-5

这是我们萼片长度的密度图

ggplot(iris, aes(Sepal.Length)) +
  geom_density()

经验密度图包括一定程度的平滑，因为对于连续变量，在任何特定值都不会有很多观察值(例如，可能没有观察值为 3.286，即使有值 3.281 和 3.292)。经验密度图通过应用某种程度的平滑来显示分布的总体形状。有时，调整平滑度会有助于查看更粗糙(更接近原始数据)或更平滑(更接近“分布”)的图表。使用adjust参数在ggplot2中控制平滑。我们在图 1-5 中看到的默认值是adjust = 1。小于 1 的值“更嘈杂”或平滑度较低，而大于 1 的值会增加平滑度。我们比较和对比了图 1-6 中的噪声和图 1-7 中的非常平滑。

img/439480_1_En_1_Fig7_HTML.png

图 1-7

非常平滑的密度图

img/439480_1_En_1_Fig6_HTML.png

图 1-6

噪声密度图

ggplot(iris, aes(Sepal.Length)) +
  geom_density(adjust = .5)

ggplot(iris, aes(Sepal.Length)) +
  geom_density(adjust = 5)

将观察分布与预期分布进行比较

虽然检查观察到的数据分布是有帮助的，但是我们经常检查分布，看它是否满足我们希望应用的统计分析的假设。例如，线性回归假设数据(有条件地)是正态分布的。如果经验分布非常不正态或更接近不同的分布，那么使用正态线性回归可能是不合适的。

Q-Q 图

为了评估数据是否符合或接近特定的预期分布，我们可以使用分位数-分位数或 Q-Q 图。Q-Q 图绘制了观察到的数据分位数与来自预期分布(例如，正态分布、贝塔分布等)的理论分位数之间的关系。).Q-Q 图可以用来检查数据是否来自几乎任何分布。因为正态或高斯分布是最常见的，所以ggplot2中制作 Q-Q 图的默认函数默认为正态分布。在 Q-Q 图中，如果数据完全符合预期分布，那么这些点将落在一条直线上。以下代码创建了图 1-8 。

img/439480_1_En_1_Fig8_HTML.png

图 1-8

正常数据看起来像一条直线。萼片。长度似乎相当正常

ggplot(iris, aes(sample = Sepal.Length)) +
  geom_qq()

为了更好地理解geom_qq()是如何工作的，我们可以自己做一个。R内置了许多概率分布的基本函数。这允许人们生成随机数(例如，rnorm())，获得来自给定分布的观察值落在某个值之上或之下的概率(例如，pnorm())，计算来自分布的分位数(例如，qnorm())，以及获得特定值的分布密度(例如，dnorm())。按照惯例，它们被命名为r、p、q、d，后面是发行版名称(或其缩写，如“norm”代表 normal)。应用这一知识，我们使用qnorm()获得以下分位数，其中均值= 0 且标准差为 1 的正态分布值的 10% (.10)将位于该分位数中:

qnorm(p = .1, mean = 0, sd = 1)

## [1] -1.3

如何将此应用于具有不同均值或标准差的正态分布是很简单的。假设我们有三个数据点。如果它们是正态分布的，我们可能会期望中间点以 0.5 的概率落在正态分布上，而另外两个点大约一半落在 0 和 0.5 或 0.5 和 1 之间(即 0.25 和 0.75)。我们可以很容易地获得这些概率的正态分位数。

qnorm(p = c(.25, .50, .75), mean = 0, sd = 1)

## [1] -0.67 0.00 0.67

为了帮助得出适当间隔的概率，我们可以使用ppoints()函数。

ppoints(n = 3, a = 0)

## [1] 0.25 0.50 0.75

ppoints()默认为小调整，而不是完全间隔。对于十个或十个以下的数据点，(1:N - 3/8)/(n + 1 - 2 * 3/8)，对于十个以上的数据点，(1:N - 1/2)/(n + 1 - 2 * 1/2)。无论哪种方式，想法都是一样的。

ppoints(n = 3)

## [1] 0.19 0.50 0.81

剩下的工作就是对我们的数据进行分类，并绘制出理论上的正态分位数。添加平均值和标准偏差在技术上是不必要的；它们是线性调整。无论哪种方式，这些点应该落在一条直线上，但使用它们会使理论分位数具有与我们的原始数据相同的均值和规模。

这里我们使用ggplot2中的qplot()函数来绘图。注意，qplot()中的q代表“快速”,因为它是使用用于更高级图形的ggplot()功能的较长规范的简写。所有这些都是说q与分位数无关。最后，为了帮助可视化，我们使用geom_abline()添加一条斜率为 1、截距为 0 的直线。该函数因一条直线的普通方程而得名，作为 x 的函数:

$$ b\ast x+a $$

(1.1)

其中参数名为截距(a)和斜率(b)。我们在图 1-9 中显示了结果。

img/439480_1_En_1_Fig9_HTML.png

图 1-9

在 x 轴上显示理论标准(基于平均值和标准偏差的预测)

qplot(
  x = qnorm(
    p = ppoints(length(iris$Sepal.Length)),
    mean = mean(iris$Sepal.Length),
    sd = sd(iris$Sepal.Length)),
  y = sort(iris$Sepal.Length),
  xlab = "Theoretical Normal Quantiles",
  ylab = "Sepal Length") +
  geom_abline(slope = 1, intercept = 0)

在这种情况下，我们可以看到数据呈合理的正态分布，因为所有点都非常接近法线，并且围绕该线大致对称。

虽然测试数据是否符合正态分布是常见的，但实际数据可能更接近许多其他分布。我们可以使用geom_qq()通过指定期望分布的分位数函数来绘制 Q-Q 图。例如，回到猞猁诱捕数据，图 1-10 用对数正态分布(qlnorm())评估原始猞猁数据的拟合度。

img/439480_1_En_1_Fig10_HTML.png

图 1-10

测试 lynx 数据是否符合对数正态分布

当使用不常用的分布时，有时ggplot2不知道默认情况下如何选择分布的参数。如果需要，我们可以将预期分布的参数作为命名列表传递给dparams参数。以下示例测试 lynx 数据是否符合图 1-11 中的泊松分布。

img/439480_1_En_1_Fig11_HTML.png

图 1-11

测试 lynx 数据是否符合泊松分布

ggplot(data.table(lynx = as.vector(lynx)), aes(sample = lynx)) +
  geom_qq(distribution = qlnorm)

ggplot(data.table(lynx = as.vector(lynx)), aes(sample = lynx)) +
  geom_qq(distribution = qpois, dparams = list(lambda = mean(lynx)))

密度图

检验观察分布是否与预期分布一致的另一种方法是绘制经验密度与预期分布密度的对比图。为此，我们可以使用geom_density()来绘制经验密度，然后使用stat_function()函数，这是绘制任何函数的通用方法。如果我们绘制函数dnorm()，它将绘制一个正常密度。我们只需要指定正态分布的均值和标准差应该基于我们的数据。结果如图 1-12 所示。同样，数据似乎接近正态分布，尽管并不完美。

img/439480_1_En_1_Fig12_HTML.png

图 1-12

正常曲线和我们的密度图(默认平滑度为 1)

ggplot(iris, aes(Sepal.Length)) +
  geom_density() +
  stat_function(fun = dnorm,
                args = list(
                  mean = mean(iris$Sepal.Length),
                  sd = sd(iris$Sepal.Length)),
                colour = "blue")

虽然绘制经验密度和预期密度不会提供 Q-Q 图未捕捉到的任何信息，但更直观的方法是“看到”彼此上下的分布，而不是看到彼此相对绘制的两个分布。

拟合更多分布

通过 Q-Q 图或观察到的和预期的密度图，我们可以评估许多不同的分布。然而，对于正态分布之外的分布，通常需要指定它们的参数，以获得分位数或密度。可以手动计算参数，并将其传递给适当的分位数或密度函数，但是使用MASS包中的fitdistr()函数，我们可以拟合许多分布，并让 R 通过指定分布的名称来估计参数。目前，fitdistr()支持以下发行版:

  • 贝塔

  • 柯西

  • 卡方检验

  • 指数的

  • F

  • 微克

  • 几何学的

  • 对数正态

  • 符号逻辑的

  • 负二项式

  • 标准

  • 泊松

  • t

  • （统计学家）威伯尔（或韦布尔）

尽管这远不是统计分布的详尽列表，但对于几乎所有使用的统计数据来说，这已经足够了，并且涵盖了本书讨论的统计分析中使用的所有分布。

为了了解如何使用fitdistr()，我们从 beta 发行版中虚构了一些随机数据。贝塔分布对比例很有用，因为贝塔分布以 0 和 1 为界。我们使用set.seed()使我们的例子可重复。

set.seed(1234)
y <- rbeta(150, 1, 4)
head(y)

## [1] 0.138 0.039 0.111 0.099 0.377 0.384

fitdistr()函数将数据、表示分布名称的单变量字符串和分布参数的初始值作为一个列表。

y.fit <- fitdistr(y, densfun = "beta",
                  start = list(shape1 = .5, shape2 = .5))

从fitdistr()我们可以得到分布的估计参数。我们明确地提取它们。

y.fit

##   shape1    shape2
##   1.08      4.28
##  (0.11)    (0.52)

y.fit$estimate["shape1"]

## shape1
##    1.1

y.fit$estimate["shape2"]

## shape2
##    4.3

我们还可以提取对数似然性(通常缩写为 LL ),它告诉我们数据有多大可能来自具有这些参数的分布。可能性越高，表示测试的分布和数据之间的匹配越接近。需要注意的是，除了对数似然或 LL 之外，通常还会报告–2 **LL*，通常简称为 2LL。最后，更复杂的模型通常(尽管不总是)至少能稍微更好地拟合数据。为了说明这一点，您可以评估用于给定可能性的自由度。logLik()函数提取对数似然和自由度。

logLik(y.fit)

## 'log˽Lik.' 95 (df=2)

虽然可能性值不容易单独解释，但它们对于比较非常有用。如果我们拟合两个分布，提供较高(对数)可能性的分布更适合数据。我们可以再次使用fitdistr()来拟合正态分布，然后将 beta 分布的 LL 与正态分布的 LL 进行比较。

y.fit2 <- fitdistr(y, densfun = "normal")
logLik(y.fit2)

## 'log˽Lik.' 67 (df=2)

在自由度相同的情况下，β(LL = 95.4)的 LL 高于正态分布(LL = 67.3)。这些结果表明我们应该为这些数据选择 beta 分布。

JWileymisc包提供了一种自动拟合多种分布的方法，并通过testdistr()功能自动查看密度或 Q-Q 图。对于正态分布，只需要很少的R代码就可以完成，结果如图 1-13 所示。

img/439480_1_En_1_Fig13_HTML.png

图 1-13

叠加正态分布的密度图和正态 Q-Q 图

testdistr(y)

为了比较正态分布和贝塔分布的拟合程度，我们可以拟合两者，并使用cowplot包中的plot_grid()函数将两个图形绘制成一个图形面板。图 1-14 中的结果显示了数据与贝塔分布的良好一致性(尽管这并不奇怪，因为我们是从贝塔分布中产生的数据！)以及与正常人的不匹配。请注意，来自密度函数的警告消息很常见，在这种情况下不必担心。

img/439480_1_En_1_Fig14_HTML.png

图 1-14

显示了叠加 beta 或正态分布的密度图以及 Q-Q 图拟合

test.beta <- testdistr(y, "beta",
                       starts = list(shape1 = .5, shape2 = .5),
                       varlab = "Y", plot = FALSE)

## Warning in densfun(x, parm[1], parm[2], ...): NaNs produced
## Warning in densfun(x, parm[1], parm[2], ...): NaNs produced
## Warning in densfun(x, parm[1], parm[2], ...): NaNs produced
## Warning in densfun(x, parm[1], parm[2], ...): NaNs produced

test.normal <- testdistr(y, "normal", varlab = "Y", plot = FALSE)

plot_grid(
    test.beta$DensityPlot, test.beta$QQPlot,
    test.normal$DensityPlot, test.normal$QQPlot,
    ncol = 2)

对于离散分布，如计数，testdistr()绘制了一种略有不同的图，旨在更好地显示观察到的比例与理论分布的概率质量函数。具体来说，密度值是观察到的比例，然后是给定分布中每个值的预期概率。

举例来说，首先我们模拟负二项分布的一些数据，然后在图 1-15 中绘制假设泊松分布的结果，在图 1-16 中绘制假设负二项分布的结果。这种比较显示，就对数似然性和与期望值的偏差而言，负二项式比泊松更适合数据。

img/439480_1_En_1_Fig16_HTML.png

图 1-16

观察到的离散比例，负二项分布的理论概率用蓝色标出

img/439480_1_En_1_Fig15_HTML.png

图 1-15

观察到的离散比例和泊松分布的理论概率用蓝色标出

set.seed(1234)
y <- rnbinom(500, mu = 5, size = 2)
testdistr(y, "poisson")

testdistr(y, "nbinom")

1.2 异常值

异常值是不同于其他值的值，或者在某些方面不标准或不典型。异常值通常也称为异常值或极值。很难精确定义什么是异常值，但通常它们是以某种方式与大多数人不一致的数据点，通常是以一种相对极端的方式。

对于来自正态分布的数据，异常值的常见阈值是 z 分数为 3 之外的任何值。这些阈值基于假设正态分布的概率。具体来说，如果数据呈正态分布，大约 0.10%的数据将低于 z 值 3，大约 0.10%的数据将高于 z 值+3。使用pnorm()函数，确切的概率如下。

pnorm(c(-3, 3))

## [1] 0.0013 0.9987

因为这些阈值基于正态分布，所以它们不一定有意义地应用于非正态分布的数据。虽然许多统计分析，如线性回归，假设结果是(有条件的)正态分布，很少关于预测的分布假设。然而，预测变量的异常值，特别是当它们处于极端时，会强烈影响结果。

视觉识别异常值通常比使用定量标准定义它们更容易。例如，图 1-17 显示了两个图表。两个图都有三个相对异常的点，值为 5。然而，这些点在画面 A 中可能显得更不合适，在画面 A 中，所有其他数据点形成或多或少连续的组，并且与异常点之间存在相对较大的间隙。即使图 B 中的异常点也有间隙，因为数据点中还有其他间隙，但有几个数据点与其他数据点分离并不奇怪——分离似乎是图 B 中的一种模式，而图 a 中没有。

img/439480_1_En_1_Fig17_HTML.png

图 1-17

显示带有异常值的堆积点图的面板图

set.seed(1234)
d <- data.table(
  y1 = rnorm(200, 0, 1),
  y2 = rnorm(200, 0, .2) + rep(c(-3, -1, 1, 3), each = 50))

plot_grid(
  qplot(c(d$y1, rep(5, 3)), geom = "dotplot", binwidth = .1),
  qplot(c(d$y2, rep(5, 3)), geom = "dotplot", binwidth = .1),
  ncol = 1, labels = c("A", "B"))

根据分布的形状，定义异常值也很困难。图 1-18 显示了两种分布。图 A 是伽马分布，显示了伽马分布的特征性长右尾。即使只有少数几个是相当极端的，数据中也没有明显的“间断”,这是一种典型的连续、长右尾分布类型。此外，从数据中很容易看出，有一种减少频率但相当极端的正值的模式。相反，面板 B 中的正态分布更加对称，没有证据表明存在如此长的尾巴。添加到 B 图中的一两个极端正值可能确实看起来“不正常”

img/439480_1_En_1_Fig18_HTML.png

图 1-18

面板图显示从伽玛和正态分布中随机生成的(没有添加异常值)数据

set.seed(1234)
d2 <- data.table(
  y1 = rgamma(200, 1, .1),
  y2 = rnorm(200, 10, 10))

plot_grid(
  qplot(d2$y1, geom = "dotplot", binwidth = 1),
  qplot(d2$y2, geom = "dotplot", binwidth = 1),
  ncol = 1, labels = c("A", "B"))

这些不同的例子突出了准确定义什么是或不是异常值的困难。虽然我们不能提供任何单一的规则来遵循，但是有一些额外的工具内置在testdistr()函数中来帮助做出这些判断。extremevalues参数可用于指定是否应突出显示低于或高于指定分布的经验数据或理论百分点的值。图 1-19 显示了一个示例，根据经验位置突出显示了最低的 1%和最高的 1%的点。地毯中的密度图(密度曲线下方的线条)通过将它们涂成纯黑色来突出显示。在 Q-Q 图中，极值点也是实心黑色，而不是灰色。如果没有点被涂成纯黑色，这将表明没有点落在第 1 个和第 99 个经验百分位数之外。当使用经验值时，除非有大型数据集可用，否则仔细检查顶部和底部 1%这样的值可能是合理的。然而，在可能的情况下，通常需要一个比顶部和底部 1%更极端的阈值，例如顶部和底部 0.10%，以确保这些值确实不太可能仅由于偶然因素而出现。

img/439480_1_En_1_Fig19_HTML.png

图 1-19

显示突出显示极值的图表

testdistr(d$y1, extremevalues = "empirical",
          ev.perc = .01)

除了根据经验定义极值之外，还可以根据特定的理论分布来定义极值。也就是说，我们可以查看是否有任何值超出了正态分布的底部或顶部 0.10%(图 1-20 )，或者对于相同的数据，是否有任何点是基于伽马分布的百分位数的极值(图 1-21 )。这些图表显示，对于相同的数据，如果我们预期数据遵循正态分布，则一些点可能被视为异常或异常值，但是如果我们预期数据遵循伽玛分布，则这些点可能不是异常的。在实践中，作为数据分析师，我们必须判断任何数据值在多大程度上极端或明显异常，以及如何最终对其进行分析。

img/439480_1_En_1_Fig21_HTML.png

图 1-21

基于伽马分布的理论百分位数突出显示极值的图表

img/439480_1_En_1_Fig20_HTML.png

图 1-20

基于正态分布的理论百分位数突出显示极值的图表

testdistr(d2$y1, "normal", extremevalues = "theoretical",
          ev.perc = .001)

testdistr(d2$y1, "gamma", extremevalues = "theoretical",
          ev.perc = .001)

可能有几个异常值。然而，当使用理论分布时，如果一个异常值比另一个异常值更极端，则不太极端的值可能会被“掩盖”,因为参数估计会受到更极端的值的影响。图 1-22 显示了一个例子，其中有两个异常值:100 和 1000。值 100 被值 1，000 所掩盖，因为理论正态分布的均值和方差被值 1，000 拉高了很多，以至于值 100 不再是异常的。

img/439480_1_En_1_Fig22_HTML.png

图 1-22

图表显示异常值 100 被更极端的异常值 1000 所掩盖

testdistr(c(d2$y2, 100, 1000), "normal",
          extremevalues = "theoretical",
          ev.perc = .001)

如果有多个异常值，可以使用迭代过程，处理最极端的值，然后重新检查，直到不再有异常值出现。然而，通过使用稳健的方法，可以在一定程度上简化该过程。当均值和(共)方差是感兴趣的参数时，一种这样的稳健方法是最小协方差行列式(MCD)估计器。简而言之，MCD 估计器找到原始病例的子集，该子集具有其样本协方差矩阵的最低行列式[82]。在单变量情况下，这相当于具有较低方差的原始数据情况的子集。testdistr()函数有一个可选的robust参数，可用于正态分布。当robust = TRUE时，testdistr()使用robustbase包【59】中的covMcd()函数，该函数使用【83】提出的快速算法来计算(近似)MCD。使用稳健估计器的结果如图 1-23 所示。使用稳健估计器，甚至在去除更极端的异常值之前，两个异常值都被识别。

img/439480_1_En_1_Fig23_HTML.png

图 1-23

基于稳健估计的突出显示极值的图形

testdistr(c(d2$y2, 100, 1000), "normal",
          robust = TRUE,
          extremevalues = "theoretical",
          ev.perc = .001)

最后，如果发现异常值，有几种方法可以解决它们。如果可能的话，最好先检查这些值是否准确。异常值通常是由于编码或数据输入错误引起的。如果不存在错误或者无法检查，最简单的选择是排除具有异常值的情况。当异常值的事例很少，并且在排除这些异常值后，大型数据集仍有许多事例时，排除或移除这些事例可能特别有效。在每个案例都很重要的较小数据集中，排除异常值可能会导致太多数据丢失。这也可能发生在更大的数据集中，其中更多的情况是异常的。

排除病例的另一种方法是 winsorizing，以查尔斯·温索尔命名。Winsorizing 采用异常值并用最接近的非异常值替换它们[92，第 14-20 页]。自动完成这一任务的一种方法是计算所需的经验分位数，并将这些值之外的任何值设置为计算的百分位数。即使异常值只存在于分布的一个尾部，这个过程也同样适用于较低和较高的尾部。调整两个尾部有助于确保程序本身不会使分布位置变得更低或更高。Winsorizing 很容易在R中使用JWileymisc包中的winsorizor()函数来完成。唯一需要的参数是每个尾部 winsorize 的比例。winsorizor()函数的另一个特性是，除了返回 winsorized 变量之外，它还添加了注意用于 winsorizing 的阈值和百分点的属性。

winsorizor(1:10, .1)

##  [1] 1.9 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 9.1
## attr(,"winsorizedValues")
##   low high percentile
## 1 1.9  9.1        0.1

图 1-24 比较了我们之前看到的伽马分布变量(在图 A 中)和之后(在图 B 中)的上下 1%。图 B 显示了 winsorizing 的特征“变平”,原始值现在只有 49.2，而不是 58.4。

img/439480_1_En_1_Fig24_HTML.png

图 1-24

面板图比较了(A)和(B)将(经验)底部和顶部的 1%进行 winsorizing 之前和之后的数据

plot_grid(
  testdistr(d2$y1, "gamma", extremevalues = "theoretical",
            ev.perc = .005, plot=FALSE)$QQPlot,
  testdistr(winsorizor(d2$y1, .01), "gamma", extremevalues = "theoretical",
            ev.perc = .005, plot=FALSE)$QQPlot,
  ncol = 2, labels = c("A", "B"), align = "hv")

1.3 摘要

在这一章中，我们学习了使用R可视化原始或混合格式数据的各种方法。此外，除了图形探索性数据分析，我们还学习了一些方法来量化我们的数据与各种分布的拟合。关于本章使用的关键功能的总结，请参见表 1-1 。

表 1-1

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| ggplot() | 使用 ggplot2 包创建新地块 |
| qplot() | 具有更简单(和更少细微差别)语法的“快速”绘图 |
| geom_dotplot() | 创建点状图几何对象-显示所有原始数据 |
| geom_histogram() | 创建直方图几何对象 |
| geom_density() | 创建密度分布，本质上是平滑的直方图 |
| geom_qq() | Q-Q 图将观察到的数据分位数与理论分位数进行对比 |
| testdistr() | 自动查看密度或 Q-Q 图 |
| winsorizor() | 用最接近的非异常值替换异常值 |
| plot_grid() | 将多个图放入定义的网格中 |
| stat_function() | 在当前图形的顶部绘制一个函数 |
| fitdistr() | 获取数据、分布和分布的参数 |
| logLik() | LL 是数据来自 fitdistr()的可能性，越大越好 |

二、多元数据可视化

前一章介绍了单变量数据可视化的方法。这一章延续了那个主题，但是从可视化单个变量转移到一次可视化多个变量。除了像前一章一样检查分布和异常值，我们还将讲述如何可视化变量之间的关系。可视化变量之间的关系尤其有助于更传统的统计模型，其中数据分析师必须指定函数形式(例如，线性、二次等)。).在后面的章节中，我们还将介绍机器学习模型，它采用算法来学习数据中的函数形式，而不需要分析师指定它。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(MASS)
library(mvtnorm)
library(mgcv)
library(quantreg)
library(JWileymisc)
library(data.table)

options(width = 70, digits = 2)

2.1 分销

尽管评估单变量分布相对容易，但多变量分布更具挑战性。多个个体变量的联合分布由它们的个体分布组成。因此，除了所有可能的单变量分布，单变量分布的不同组合被组合以形成正在研究的联合分布。从可视化的角度来看，也很难在通常用于绘制数据的两个维度中可视化多个维度的数据。

在本书中，我们将涉及的唯一多元分布是多元正态(MVN)分布。在实践中，这不是过分的限制，因为大多数分析一次只关注一个结果，并且只需要知道结果的分布。因子分析和结构方程模型是两种同时模拟多种结果的常见分析类型，通常假设数据是多元正态的。如果一个人可以评估数据是否是多元正态的，我们的经验涵盖了大多数做出多元分布假设的分析。

正态分布由两个参数决定，均值 μ 和标准差 σ ，分别控制分布的位置和规模。 p 维的多元正态分布由两个矩阵控制，一个是均值的 px 1 矩阵 μ ，另一个是 pxp 协方差矩阵σ。

在二元情况下，其中 p = 2，绘制多元分布图是简单的。我们使用mvtnorm()包中的rmvnorm()函数来模拟一些多元正态数据。然后可以使用geom_density2d()函数和ggplot2绘制经验密度，如图 2-1 所示。

img/439480_1_En_2_Fig1_HTML.png

图 2-1

多元正态数据的 2D 经验密度图

mu <- c(0, 0)
sigma <- matrix(c(1, .5, .5, 1), 2)

set.seed(1234)
d <- as.data.table(rmvnorm(500, mean = mu, sigma = sigma))
setnames(d, names(d), c("x", "y"))

ggplot(d, aes(x, y)) +
  geom_point(colour = "grey60") +
  geom_density2d(size = 1, colour = "black") +
  theme_cowplot()

检查经验密度是有帮助的，但是不能将它们与多元正态分布下的预期进行精确的比较。为了将获得的经验密度与多元正态分布的预期密度进行对比，我们基于数据范围生成了成对的 x 和 y 值的网格，然后使用dmvnorm()函数计算每个 x，y 对的密度。多元正态分布的参数 μ 和σ由观测数据计算得出。结果如图 2-2 所示，为了清晰起见，这次删除了原始数据点。

testd <- as.data.table(expand.grid(
  x = seq(from = min(d$x), to = max(d$x), length.out = 50),
  y = seq(from = min(d$y), to = max(d$y), length.out = 50)))
testd[, Density := dmvnorm(cbind(x, y), mean = colMeans(d), sigma = cov(d))]

ggplot(d, aes(x, y)) +
  geom_contour(aes(x, y, z = Density), data = testd,
               colour = "blue", size = 1, linetype = 2) +
  geom_density2d(size = 1, colour = "black") +
  theme_cowplot()

在图 2-2 中，经验密度和正态密度非常接近，我们可以得出结论，假设数据是多元正态是合理的。接下来，我们模拟两个非多元正态的正态分布变量。图 2-3 显示了每个变量的单变量密度图，表明它们呈正态分布。

img/439480_1_En_2_Fig3_HTML.png

图 2-3

显示模拟变量为单变量正态的单变量密度图

img/439480_1_En_2_Fig2_HTML.png

图 2-2

2D 经验密度与多元正态密度图

set.seed(1234)
d2 <- data.table(x = rnorm(500))
d2[, y := ifelse(abs(x) > 1, x, -x)]

plot_grid(
  testdistr(d2$x, plot = FALSE)$Density,
  testdistr(d2$y, plot = FALSE, varlab = "Y")$Density,
  ncol = 2)

尽管变量是单个正态的，但这并不保证它们是多元正态的。这是一个关键点，并强调了评估多元分布的重要性，如果使用一种分析技术，对多元分布作出假设(例如，验证性因素分析)。使用我们之前使用的相同代码，我们绘制了图 2-4 中的经验和多元正态密度。

testd2 <- as.data.table(expand.grid(
  x = seq(from = min(d2$x), to = max(d2$x), length.out = 50),
  y = seq(from = min(d2$y), to = max(d2$y), length.out = 50)))
testd2[, Density := dmvnorm(cbind(x, y), mean = colMeans(d2), sigma = cov(d2))]

ggplot(d2, aes(x, y)) +
  geom_contour(aes(x, y, z = Density), data = testd2,
               colour = "blue", size = 1, linetype = 2) +
  geom_density2d(size = 1, colour = "black") +
  theme_cowplot()

图 2-4 清楚地显示了这两个变量不是多元正态的。尽管这是一个极端的例子，但它强调了单变量评估可能会产生多大的误导。

img/439480_1_En_2_Fig4_HTML.png

图 2-4

显示非多元正态数据的 2D 密度图

当 p > 2 时，直接可视化一个多元正态分布是困难的。相反，我们可以利用 Mahalanobis [60]的工作，他开发了一种方法来计算数据与“中心”的距离，数据和中心可以是多维的。距离测量被命名为 Mahalanobis 距离[60]，并将其用于我们数据中的每种情况，我们可以计算其与(多变量)中心的距离。假设数据是多元正态的，这些距离将分布为具有 p 自由度的卡方变量。

我们之前看到的testdistr()函数还包括一个基于马氏距离绘制多元正态数据的选项。我们模拟的双变量正态数据的结果如图 2-5 所示，我们模拟的单变量正态而非多变量正态数据如图 2-6 所示。

img/439480_1_En_2_Fig6_HTML.png

图 2-6

叠加多元正态分布的密度图和 Q-Q 图显示非多元正态的数据

img/439480_1_En_2_Fig5_HTML.png

图 2-5

叠加多元正态分布的密度图和显示多元正态数据的 Q-Q 图

testdistr(d, "mvnorm", ncol = 2)

testdistr(d2, "mvnorm", ncol = 2)

即使当变量的数量增加时，只要数据正在进行多元正态性检验，图表也是相似的。例如，我们可以测试mtcars数据集，它包含 32 辆汽车不同方面的 11 个变量。结果如图 2-7 所示，表明数据近似为多元正态，尽管与 Q-Q 图上直线的偏差表明了一些非正态性。

img/439480_1_En_2_Fig7_HTML.png

图 2-7

mtcars 数据的密度图叠加多元正态分布和 Q-Q 图

testdistr(mtcars, "mvnorm", ncol = 2)

2.2 异常值

对于多元数据，任何给定变量的值都可能是异常的，或者在多元空间中是异常的。如果一个值是单变量反常的，它也将是多变量反常的。然而，正如我们看到的，单变量正常变量不一定是多变量正常的，同样，单变量异常值是多变量异常的，但单变量非异常值并不保证是多变量非异常的。

在下面的代码中，我们模拟了强正相关的多元正态数据，并向V3添加了两个异常值。单独检查V3(即单变量)，一个异常值清晰可见，移除后，没有其他异常值出现(图 2-8 )。

img/439480_1_En_2_Fig8_HTML.png

图 2-8

具有异常值(图 A)和移除异常值(图 B)的数据的密度图叠加正态分布

mu <- c(0, 0, 0)
sigma <- matrix(.7, 3, 3)
diag(sigma) <- 1

set.seed(12345)
d <- as.data.table(rmvnorm(200, mean = mu, sigma = sigma))[order(V1)]
d[c(1, 200), V3 := c(2.2, 50)]

plot_grid(
  testdistr(d$V3, extremevalues = "theoretical", plot=FALSE)$Density,
  testdistr(d[V3 < 40]$V3, extremevalues = "theoretical", plot=FALSE)$Density, ncol = 2, labels = c(“A”, “B”))

接下来，我们可以再次使用testdistr函数来寻找多元异常值。使用所有情况的结果如图 2-9 所示，清楚地显示了一个异常值，没有其他点出现异常。然而，在排除一个已识别的异常情况后，第二个多元异常情况出现(图 2-10 )。当更极端的值被移除时，这种额外的异常情况被揭露，导致变量V3的均值和方差减小。

img/439480_1_En_2_Fig10_HTML.png

图 2-10

移除一个极端异常值后的多元正态和(多元)异常值的图表

img/439480_1_En_2_Fig9_HTML.png

图 2-9

多元正态和(多元)异常值的图表

testdistr(d, "mvnorm", ncol = 2, extremevalues = "theoretical")

testdistr(d[V3 < 40], "mvnorm", ncol = 2, extremevalues = "theoretical")

通过使用多元正态分布参数的稳健估计器:均值和协方差矩阵，可以直接识别多个异常情况，而不是迭代地去除异常情况。当robust选项与testdistr()的mvnorm分布结合使用时，使用robustbase包中的快速最小协方差行列式(MCD)估计器【82，83】。结果如图 2-11 所示。使用多元正态分布和稳健估计量，单变量和多变量异常情况都可以在一次通过中识别。去除这些数据后，数据看起来接近多元正态分布(图 2-12 )。

img/439480_1_En_2_Fig12_HTML.png

图 2-12

移除了两个异常值的多元正态和(多元)异常值的图表

img/439480_1_En_2_Fig11_HTML.png

图 2-11

使用稳健估计量的多元正态和(多元)异常值的图表

testdistr(d, "mvnorm", ncol = 2, robust = TRUE, extremevalues = "theoretical")

testdistr(d[-c(1,200)], "mvnorm", ncol = 2, extremevalues = "theoretical")

2.3 变量之间的关系

对于连续变量，大多数模型假定某种函数形式，变量之间通常是线性关系。有许多方法来检查这一点，但一个快速的方法是将预测值 x 切割成 k 个离散的容器。如果有有意义的断点，可以使用这些断点，但通常使用五分位数、四分位数或三分位数，这取决于数据的数量。在大型数据集中，即使是细粒度的分割，如十分位数，也可能有意义。

将预测因子分成离散的组后，可以绘制箱线图或均值图来显示趋势的大致形状。在下面的代码中，我们模拟了预测值 x 和结果 y 之间的二次关系。使用%+%操作符，我们可以重复使用同一个图，并简单地更新数据以使用具有不同分界点集合(四分位数、五分位数、十分位数)的数据。结果如图 2-13 所示。尽管在具有三等分切割的面板 A 中趋势有些不清楚，但是在具有十分位数的面板 D 中，在这少量的数据中，结果变得更加嘈杂。

img/439480_1_En_2_Fig13_HTML.png

图 2-13

将连续变量切割成四分位数的箱线图，显示非线性关系

set.seed(12345)
d2 <- data.table(x = rnorm(100))
d2[, y := rnorm(100, mean = 2 + x + 2 * xˆ2, sd = 3)]

p.cut3 <- ggplot(
  data = d2[, .(y,
    xcut = cut(x, quantile(x,
      probs = seq(0, 1, by = 1/3)), include.lowest = TRUE))],
  aes(xcut, y)) +
  geom_boxplot(width=.25) +
  theme(axis.text.x = element_text(
          angle = 45, hjust = 1, vjust = 1)) +
  xlab("")

p.cut4 <- p.cut3 %+% d2[, .(y,
    xcut = cut(x, quantile(x,
      probs = seq(0, 1, by = 1/4)), include.lowest = TRUE))]

p.cut5 <- p.cut3 %+% d2[, .(y,
    xcut = cut(x, quantile(x,
      probs = seq(0, 1, by = 1/5)), include.lowest = TRUE))]

p.cut10 <- p.cut3 %+% d2[, .(y,
    xcut = cut(x, quantile(x,
      probs = seq(0, 1, by= 1/10)), include.lowest = TRUE))]

plot_grid(
  p.cut3, p.cut4,
  p.cut5, p.cut10,
  ncol = 2,
  labels = c("A", "B", "C", "D"),
  align = "hv")

确定两个变量之间关系的函数形式的另一种方法是使用局部加权回归(黄土)线[21]。黄土线背后的思想类似于拟合最佳拟合的直线，但是加权到附近的数据点。以下代码创建一个散点图，并覆盖黄土线和直线回归直线(图 2-14 )。黄土线很容易识别被直线遗漏的二次趋势。

img/439480_1_En_2_Fig14_HTML.png

图 2-14

黄土最佳拟合线呈现非线性关系

ggplot(d2, aes(x, y)) +
  geom_point(colour="grey50") +
  stat_smooth(method = "loess", colour = "black") +
  stat_smooth(method = "lm", colour = "blue", linetype = 2)

一旦我们知道了近似的函数形式，我们就可以尝试用参数函数来近似它。在下面的代码中，我们修改了线性模型 smooth，以包含一个自定义公式，该公式指示应该在 x 和x?? 2 上回归 y 。结果得到了很大的改善，显示黄土线和二次线之间非常一致(图 2-15 )。

img/439480_1_En_2_Fig15_HTML.png

图 2-15

黄土线和二次线

ggplot(d2, aes(x, y)) +
  geom_point(colour="grey50") +
  stat_smooth(method = "loess", colour = "black") +
  stat_smooth(method = "lm",
              formula = y ~ x + I(xˆ2),
              colour = "blue", linetype = 2)

尽管黄土线有其优点，但也不是绝对可靠的。一个选择是平滑度。平滑由span参数控制，该参数传递给负责估计直线的loess()函数。在下一个示例中，绘制了两条黄土线，一条跨度低，一条跨度高。跨度越大，线条越平滑。图 2-16 为跨度为 0.2 和 2.0 的两条黄土线。

img/439480_1_En_2_Fig16_HTML.png

图 2-16

平滑程度不同的黄土线

ggplot(d2, aes(x, y)) +
  geom_point(colour="grey50") +
  stat_smooth(method = "loess", span = .2,
              colour = "black") +
  stat_smooth(method = "loess", span = 2,
              colour = "black", linetype = 2)

接下来，我们将扩展到两个变量之外，并研究许多变量的可视化方式。以下代码模拟的结果是三个预测变量(两个连续预测变量和一个分类预测变量)的函数。x和y之间关系的初始双变量图表明关系相对较弱，可能有一些异常值(图 2-17 )。

img/439480_1_En_2_Fig17_HTML.png

图 2-17

多元数据中二元关系的黄土线

set.seed(1234)
d3 <- data.table(
  x = rnorm(500),
  w = rnorm(500),
  z = rbinom(500, 1, .4))
d3[, y := rnorm(500, mean = 3 +
       ifelse(x < 0 & w < 0, -2, 0) * x +
       ifelse(x < 0, 0, 2) * w * xˆ2 + 4 * z * w,
    sd = 1)]
d3[, z := factor(z)]

ggplot(d3, aes(x, y)) +
  geom_point(colour="grey50") +
  stat_smooth(method = "loess", colour = "black")

尽管对于完全连续的变量，数据可视化通常仅限于二维，但我们可以通过图形的形状、颜色和面板来添加额外的维度。下面的代码再次检查了结果y的预测值，这次使用了所有的变量。二进制的z用于给点和线着色，我们使用前面的技巧将连续的w切割成四分之一。虽然剪切w不会完美地捕捉它的连续关系，但它足以暗示正在发生什么，并表明是否有必要与w互动。图 2-17 中提到的几个相对极端的值通过 winsorizing 底部和顶部 1%的数据来解决。最终结果如图 2-18 所示。

img/439480_1_En_2_Fig18_HTML.png

图 2-18

多元数据的黄土线

ggplot(d3, aes(x, winsorizor(y, .01), colour = z)) +
  geom_point() +
  stat_smooth(method = "loess") +
  scale_colour_manual(values = c("1" = "black", "0" = "grey40")) +
  facet_wrap(~ cut(w, quantile(w), include.lowest = TRUE))

图 2-18 显示，当w为低时，对于低于 0 的x值，在y和x之间往往有一个负的、大致线性的斜率，但是当w为高时，没有关系。根据w的电平，z会向下或向上移动数值。

除黄土外，广义加性模型(gam)是另一种拟合直线的灵活方法[40]。我们将在后面讨论它们的统计性质和用途。现在的优势在于拟合灵活的非线性平滑项，包括连续变量和分类变量之间的相互作用。具体来说，我们利用了mgcv包【122】中的gam()函数。

在黄土中，我们使用span参数指定平滑程度。在 GAMs 中，我们通过k参数使用近似自由度来指定允许生产线有多灵活。目前，我们并不关注 gam 的统计属性或正式的统计推断，而是将它们作为一种工具来拟合数据并生成预测，以图形化和可视化我们数据中的(平滑)模式。te()功能用于允许x和w之间的非线性交互，并且我们还允许这些对于不同级别的z是分开的。拟合的模型存储在对象m中。接下来，我们生成一个用于预测的网格值。与密度一样，我们在x和w上为z的所有级别选择等距点。生成预测后，我们可以绘制如图 2-19 所示的结果。注意图 2-19 颜色最好看。

对于图 2-19 中的一条轮廓线，所有预测的y值都是相同的。因此，通过追踪一条线，你可以检查预测因素与结果的关系。例如，当z为 0 时(图 2-19 的左图)，对于低于 0 的x值，w是否在-3 和 0 之间移动对预测的y值影响不大。一般来说，任何平行于特定维度的等高线都表示在该维度上该点的预测变化很小。光栅背景也有助于显示预测的y值。

img/439480_1_En_2_Fig19_HTML.png

图 2-19

显示 x 和 w 的不同组合的预测 y 值的等值线图，由 z 面板显示

m <- gam(winsorizor(y, .01) ~ z + te(x, w, k = 7, by = z), data = d3)

newdat <- expand.grid(
  x = seq(min(d3$x), max(d3$x), length.out = 100),
  w = seq(min(d3$w), max(d3$w), length.out = 100),
  z = factor(0:1, levels = levels(d3$z)))

newdat$yhat <- predict(m, newdata = newdat)

ggplot(newdat, aes(x = x, y = w, z = yhat)) +
  geom_raster(aes(fill = yhat)) +
  geom_contour(colour = "white", binwidth = 1, alpha = .5) +
  facet_wrap(~ z)

评估方差的同质性

方差的同质性或同质性是指各组之间或连续预测值之间存在相同的有限方差，结果在预测值的各个级别上具有相同的残差方差。例如，在单向方差分析中，对于解释变量(通常称为自变量)的每个水平，结果的方差应该大致相等。

为了评估方差的同质性，我们为 iris 数据制作了一个数据表，并通过简单地计算物种的方差来进行第一次检查。

diris <- as.data.table(iris)
diris[, .(V = var(Sepal.Length)), by = Species]

##       Species    V
## 1:     setosa 0.12
## 2: versicolor 0.27
## 3:  virginica 0.40

可视化数据和分布也很有帮助。箱线图或盒须图可能是一种有用的方法，因为“盒”部分覆盖了四分位数之间的范围，即第 25 至 75 个百分点。这是一种稳健的分布范围测量方法。我们检查盒子的分布,以了解不同物种之间的可变性是否大致相等。箱线图也比仅仅按组计算方差更能提供信息，因为它们可以显示数据中是否有任何异常值。

即使物种间的传播是可比的，中位数或位置也可能不同，这使得比较传播更加困难。如果您不想检查位置，并且希望只关注分布，那么在制图之前确定中间值是很有用的。图 2-20 中显示了无(A 图)和有(B 图)中间居中的箱线图。

img/439480_1_En_2_Fig20_HTML.png

图 2-20

各种萼片长度的盒须图。异常值显示为点

plot_grid(
  ggplot(diris, aes(Species, Sepal.Length)) +
    geom_boxplot() +
    xlab(""),
  ggplot(diris[, .(Sepal.Length = Sepal.Length -
                              median(Sepal.Length)), by = Species],
         aes(Species, Sepal.Length)) +
    geom_boxplot() +
    xlab(""),
  ncol = 2, labels = c("A", "B"), align = "hv")

我们已经看到了密度图，并用它来评估变量的分布；如果密度图被反射形成镜像，则称为小提琴图。我们可以用geom_violin()来制作；它提供了与箱线图相似的信息。然而，violin 图提供了关于分布的更多信息，因为箱线图仅显示了中位数(第 50 个百分点)、第 25 个百分点和第 75 个百分点，以及数据的范围(如果有异常值，则略小于整个范围)。但是，由于查看中位数和四分位间距范围也很有用，因此将宽度较窄的箱线图叠加到 violin 图上会很有帮助。从小提琴图中，我们可以看到，对于具有较高分布均值(位置)的物种，图 2-21 中的扩散稳步增加。

img/439480_1_En_2_Fig21_HTML.png

图 2-21

中间有盒须图的小提琴图

ggplot(diris, aes(Species, Sepal.Length)) +
  geom_violin() +
  geom_boxplot(width = .1) +
  xlab("")

正如我们在研究变量之间的关系时所做的那样，violin 图和 box 图可以扩展到使用颜色和面板来处理多个变量。下面的代码使用我们研究变量之间关系的数据，并删除所有连续的预测因子，以便于检查预测因子水平上结果的分布和传播。结果如图 2-22 所示。请注意，我们有目的地限制了 y 轴的范围，以便更容易看到图形，并且不太强调极值。

img/439480_1_En_2_Fig22_HTML.png

图 2-22

小提琴图，中间用 x 的四分位数表示盒须图，用 z 着色

## create cuts
d3[, xquartile := cut(x, quantile(x), include.lowest = TRUE)]
d3[, wquartile := cut(w, quantile(w), include.lowest = TRUE)]
d3[, yclean := winsorizor(y, .01)]

## median center y by group to facilitate comparison
d3[, yclean := yclean - median(yclean),
   by = .(xquartile, wquartile, z)]

p <- position_dodge(.5)

ggplot(d3, aes(xquartile, yclean, colour = z)) +
  geom_violin(position = p) +
  geom_boxplot(position = p, width = .1) +
  scale_colour_manual(values = c("1" = "black", "0" = "grey40")) +
  facet_wrap(~ wquartile) +
  theme(axis.text.x = element_text(angle = 45, hjust=1, vjust=1)) +
  coord_cartesian(ylim = c(-5, 5), expand = FALSE)

到目前为止，我们已经研究了评估连续结果和离散解释变量的方差齐性，或者将连续解释变量分成离散类别。现在我们转向如何对连续变量进行可视化处理。第一步是创建一个散点图；然而，为了看到“传播”,我们需要对方差或四分位范围等进行一些连续的估计。这可以通过分位数回归来实现。我们不会在这里详细讨论这个过程，但可以说分位数回归可以估计作为一个或多个解释变量的函数的分布的分位数。我们将首先模拟一些同质和异质数据。

set.seed(1234)
d4 <- data.table(x = runif(500, 0, 5))
d4[, y1 := rnorm(500, mean = 2 + x, sd = 1)]
d4[, y2 := rnorm(500, mean = 2 + x, sd = .25 + x)]

图 A 是同质可变性的例子，图 B 是异质可变性的例子。我们在图 2-23 中展示了这两个数据集的视觉对比。分位数回归[51，50，107]。

img/439480_1_En_2_Fig23_HTML.png

图 2-23

同异方差与异方差

plot_grid(
  ggplot(d4, aes(x, y1)) +
    geom_point(colour = "grey70") +
    geom_quantile(quantiles = .5, colour = 'black') +
    geom_quantile(quantiles = c(.25, .75),
                  colour = 'blue', linetype = 2) +
    geom_quantile(quantiles = c(.05, .95),
                  colour = 'black', linetype = 3),
  ggplot(d4, aes(x, y2)) +
    geom_point(colour = "grey70") +
    geom_quantile(quantiles = .5, colour = 'black') +
    geom_quantile(quantiles = c(.25, .75),
                  colour = 'blue', linetype = 2) +
    geom_quantile(quantiles = c(.05, .95),
                  colour = 'black', linetype = 3),
  ncol = 2, labels = c("A", "B"))

## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x

2.4 总结

本章演示了可视化多元数据的技术，以了解它如何与多元正态分布进行比较(表 2-1 )。

表 2-1

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| geom_quantile() | 以给定的分位数拟合直线(默认为四分位数) |
| geom_density2d() | 为多元正态数据点创建 2D 密度等值线图 |
| geom_contour() | 创建 2D 等高线图 |
| geom_violin() | 镜像密度图 |
| stat_smooth() | 将曲线拟合到数据点 |

三、GLM 1

广义线性模型(GLMs)是一大类模型，包括回归分析和方差分析(ANOVA ),是常用于指 GLMs 的其他术语或分析。本章使用了如下所示的一些包。我们运行设置代码来加载这些数据，并以整洁的方式打印数据表。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(data.table)
library(ggplot2)
library(visreg)
library(ez)
library(emmeans)
library(rms)
library(ipw)
library(JWileymisc)
library(RcppEigen)
library(texreg)

options(
  width = 70,
  stringsAsFactors = FALSE,
  datatable.print.nrows = 20,
  datatable.print.topn = 3,
  digits = 2)

3.1 概念背景

广义线性模型提供了一个通用的框架和符号，可以适应许多特定类型的模型和分析。本章涵盖了几种特定类型的 GLMs。如果您不熟悉一些更基本的 GLMs 类型，如方差分析(ANOVA)或线性回归，并且您希望更好地了解 GLMs 的背景和概念框架，那么阅读 ANOVA 和线性回归可能是值得的。一个易于使用的免费资源是在线统计教育:一门多媒体学习课程( http://onlinestatbook.com/ ，项目负责人:莱斯大学的大卫·m·莱恩)，其中有一节是关于方差分析和回归的。关于 GLMs 的全面数理统计背景，我们推荐 McCullagh 和 Nelder 的经典著作[61]，其完整参考资料在参考资料部分。

首先，我们介绍一些统计和 GLMs 中常用的函数，包括:

  • E ( x )表示一个变量的期望值，或者它的(可能有条件的)均值。

  • Var ( x )表示一个变量的方差，或者说它的离差。

  • g ( x )表示链接函数，该函数获取原始结果变量并将其转换为由 GLM 预测的线性标度。

  • g-1(x)表示反向链接函数，它采用 GLM 预测的线性标度，并将其转换回原始标度。

  • exp ( x )表示指数函数。

  • ln ( x )表示自然对数函数。

glm 的结构是这样的，有一个结果或因变量，我们称之为 y。一个或多个预测值或解释变量存储在一个矩阵中，该矩阵有 n 行(数据点的数量)和 k 列(预测值或解释变量的数量)，我们称之为 x。回归系数，即要估计的参数，形成一个长度为 k (预测值的数量)的向量，称为 β 。结局的期望值是 E (y) = μ 。加粗的希腊文小写字母 μ 是书写预期结果值的较短方式。这些将总是在原始或原始数据范围内。线性标尺上的期望值是另一个称为 η 的向量。

有了这些约定，我们就可以像内尔德和威德伯恩的开创性文章[71]那样定义广义线性模型的构建模块。我们使用与内尔德和威德伯恩[71]稍有不同的符号来反映应用统计学中更常见的近期实践。每个 GLM 都有一个结果或因变量， y 。在线性预测因子上进行调节后，假设结果遵循来自指数族的概率分布。此外，每个 GLM 具有一组 k 预测变量，x 1 ，...，x k ，总体称为 X，以及一个期望的线性结果:

$$ \eta = X\beta $$

(3.1)

最后，每个 GLM 都有一个链接功能

$$ \eta =g\left(\mu \right)=g\left(E(y)\right) $$

(3.2)

以及类似的反向链接功能

$$ E(y)=\mu ={g}^{-1}\left(\eta \right) $$

(3.3)

因为参数 β 总是在线性预测标度 η 上估计，所以不管结果的分布如何，GLMs 的估计都是相似的。改变的是为结果和链接以及反向链接函数假设的分布。我们涵盖了三种常见类型的结果变量的分布和链接函数(以及如何分析它们):连续、二元结果和计数结果。表 3-1 显示了我们在本章中涉及的最常用的(规范的)链接函数。请注意，列出的分布并不是给定结果类型的所有可能分布。例如，对于连续结果，根据其形状或界限，有许多其他分布(例如，连续但以 0 和 1 为界限的数据的 Beta 分布)。

表 3-1

结果类型、分布和相应的链接函数

|

结果类型

|

分布

|

链接功能

|

反向链接功能

|
| --- | --- | --- | --- |
| 连续的(实数) | 正常(高斯) | =【g】()=** | =【g】-1()=** |
| 二进制(0/1) | 伯努利多项式 | $$ \eta =g\left(\mu \right)=\mathit{\ln}\left(\frac{\mu }{1-\mu}\right) $$ | $$ \mu ={g}^{-1}\Big(\eta =\frac{1}{1+\mathit{\exp}\left(-\eta \right)} $$ |
| 计数(正整数) | 泊松，负二项式 | =【g】()=(** | =【g】-1()=【exp】** |

基于结果分布，有可能写出一个似然函数。我们在本书中不涉及似然函数的细节，因为没有必要知道什么是应用数据分析的似然函数。然而，基本思想是，似然函数(取决于所选择的分布)量化了数据从具有给定参数集的分布中出现的可能性；因此，一般似然函数被写成 L (y， θ )。注意，这里我们将参数称为 θ ，因为对于许多(但不是所有)分布，必须估计回归系数之外的附加参数；具体来说，经常需要估计色散参数。例如，正态分布的参数是均值和方差或标准差。另一个注意事项是，出于实用的原因，可能性通常被报告为对数可能性。其他地方描述了进一步的细节[71，61]。

似然函数有几个有用的目的。首先，它们是最大似然估计的基础。也就是说，估计 GLM(以及许多其他模型)的参数，以最大化数据的似然函数。此外，来自给定模型的总体似然性可以与来自另一个模型的似然性进行比较，作为哪个模型提供更好的数据拟合的相对比较。接下来，我们研究如何将这个通用模型应用到具体的案例中。

3.2 分类预测器和虚拟编码

两级分类预测器

在 GLMs 中检查分类预测因子是很常见的。例如，人们可能希望测试结果中是否存在性别差异。但是，在这样做之前，需要一个系统将“女人”和“男人”转换成数值。将离散类别编码成数字的最常见系统称为虚拟编码。虚拟编码包括对代表一个特定类别的一系列二进制 0/1 变量进行编码。对于性别，我们可以编写两个虚拟变量，一个代表女性，一个代表男性。如表 3-2 所示。

表 3-2

虚拟编码性别示例

|

性

|

D1

|

D2

|
| --- | --- | --- |
| 妇女 | one | Zero |
| 男人 | Zero | one |
| 男人 | Zero | one |
| 妇女 | one | Zero |
| 妇女 | one | Zero |
| 男人 | Zero | one |

在这种情况下，伪代码 D1 和 D2 是完全负相关的，表明它们捕获相同的信息，但是被颠倒。因此，我们将只把两个伪码中的一个输入实际的 GLM。总的原则是，对于一个 k- 级变量，可以生成 k 个伪代码变量，但只包括伪代码变量的k1。省略的变量成为参考组。为了理解为什么会这样，我们可以检查一个简单的设计矩阵 X，(表 3-3 )，它对应于一个只测试性别差异的模型。作为 GLMs 的标准，我们有一个常数列，它是截距，当所有其他预测值都等于零时结果的期望值。我们还有两个虚拟编码变量之一，D2。在这种情况下，当参与者是男性时，D2 为 1，当参与者是女性时，为 0。相应的系数向量将具有两个元素，一个用于截距，一个用于伪码 D2。

表 3-3

具有截距和一个虚拟变量的性别差异设计矩阵

|

拦截

|

D2

|
| --- | --- |
| one | Zero |
| one | one |
| one | one |
| one | Zero |
| one | Zero |
| one | one |

截距系数将是女性的期望值，因为只有当参与者是女性时，所有其他变量(在这种情况下，只有 D2)才为零。D2 系数是 D2 一个单位变化结果的预期变化。因为我们用 0/1 来编码 D2，在 D2 一个单位的变化正好是从女性(0)到男性(1)的转变。因此，D2 系数可以更简单地认为是男女之间的预期差异。

三层或更多层分类预测因子

具有三个或更多级别的虚拟编码分类变量的工作方式类似于基本的两级方法。同样，我们创建一组 0/1 变量，对变量的每个特定级别进行编码。表 3-4 显示了锻炼类型的三级变量示例。

表 3-4

虚拟编码性别示例

|

锻炼

|

D1

|

D2

|

D3

|
| --- | --- | --- | --- |
| 奔跑 | one | Zero | Zero |
| 游泳 | Zero | one | Zero |
| 自行车 | Zero | Zero | one |
| 奔跑 | one | Zero | Zero |
| 自行车 | Zero | Zero | one |
| 自行车 | Zero | Zero | one |
| 奔跑 | one | Zero | Zero |
| 游泳 | Zero | one | Zero |
| 游泳 | Zero | one | Zero |

为了进行分析，我们将在 GLM 中包括任何k1 = 31 = 2 的伪码变量，同样，被排除的组将是参考组。然而，组间比较变得稍微复杂一些。假设我们忽略了 D1，运行的虚拟代码。游泳和自行车虚拟代码的系数将捕捉跑步和游泳之间以及跑步和自行车之间的预期差异。然而，没有一个系数会直接测试游泳和骑自行车之间的差异。总的原则是，对于一个k水平变量，有$$ \left(\begin{array}{l}k\ {}2\end{array}\right) $$可能的成对比较；对于三级变量，三次成对比较；对于四级变量，六次成对比较。要测试所有成对组合，有几种选择。一种选择是，尽管效率不高，但只要有伪代码变量，就运行 GLM，每次迭代只省略一个伪代码。另一种方法是使用从模型估计的系数矩阵和参数协方差矩阵来测试特定的对比。在我们的练习示例中，测试游泳与跑步的系数是否不同于自行车与跑步的系数将提供游泳与自行车是否不同的测试。

考虑如何测试变量的整体效果也很重要。对于单个连续变量或两级分类变量，单个系数反映了变量的整体效应。然而，在输入多个虚拟代码变量的三级或更多级分类变量的情况下，任何特定虚拟代码变量系数的测试都不能提供该变量显著性的整体测试。相反，我们需要一个综合测试。对于具有正态分布结果的 GLMs，这可能是一个综合 f 检验。对于无法计算自由度的其他 GLM，标准测试是基于测试所有虚拟变量系数共同为零的 Wald 测试，或似然比测试，这需要在没有问题变量的情况下重新调整 GLM，并测试最终对数似然变化的程度，最终对数似然变化将作为自由度等于排除的虚拟变量数量的 χ 2 分布。

3.3 相互作用和调节效应

当两个或多个解释变量之间的关系和结果依赖于彼此的值时，就会发生交互作用。例如，Wiley 和他的同事们[115]发现了压力源的可控程度和人们积极感受的应对方式之间的相互作用。对于人们几乎无法控制的压力源，无论人们试图积极思考如何改善问题还是避免思考问题，对他们的积极情绪水平没有影响。然而，对于可控的压力源，那些避免思考如何解决问题的人积极情绪水平较低，而那些积极思考如何解决问题的人积极情绪水平较高。

两个变量之间的相互作用称为双向相互作用。三个变量之间的相互作用称为三向相互作用，等等。交互作用可以在 GLMs 中进行测试，方法是将单个变量单独添加到模型中，并添加需要交互作用的变量的乘积项。这可以通过在原始数据集中创建新变量来实现。例如，对于 x 1 和 x 2 ,“新”交互变量将被创建为int = x1⋅x2。R和其他统计软件包还提供了指定应该在模型中测试两个(或更多)变量的交互作用的能力，在这种情况下，产品术语是自动创建的，而无需在数据集中创建额外的变量。无论哪种情况，最终结果都是一样的，表 3-5 中显示了一个设计矩阵示例。

对于两个以上变量的相互作用，还有几个附加项。如果有三个解释变量( x 1 ， x 2 ， x 3 )，则有三个双向交互(x1⋅x2，x1⋅x) x2⋅x3 以及除了三个个体变量之外可以考虑的一个三向交互(x1⋅x2⋅x3)。 即使主要关注的是三方交互，标准做法也是包括所有低阶项。因此，对于三向互动，通常所有可能的双向互动和所有单个变量也将包括在分析中。

因为相互作用涉及不止一个变量，所以总是有可能用不止一种方式来解释它们。例如，如果两个变量 a 和 b 之间存在相互作用，则每个变量与结果 y 之间的关系取决于另一个变量的水平。因此 a 和 y 之间的关系取决于 b 的级别，同样 b 和 y 之间的关系取决于 a 。这一事实改变了对单个变量回归系数的解释。查看表 3-5 ，当 x2 = 0 时，x1 的系数将被解释为 x1 一个单位变化的预期 y 变化。同样，当 x1 = 0 时，x2 的系数将被解释为 x2 变化一个单位时 y 的预期变化。最后，x1x2 的系数可以解释为(1)x2 变化一个单位时 x1 系数的预期变化，或者(2)x1 变化一个单位时 x2 系数的预期变化。

表 3-5

双向互动设计矩阵示例

|

拦截

|

x1

|

x2

|

x1x2

|
| --- | --- | --- | --- |
| one | one | Two | Two |
| one | Two | Two | four |
| one | three | one | three |
| one | three | three | nine |
| one | one | one | one |
| one | Two | Zero | Zero |

当用标准代数而不是矩阵代数写出时，这种解释更有意义，如下所示:

$$ {y}_i={b}_0+{b}_1\cdot {x}_{1i}+{b}_2\cdot {x}_{2i}+{b}_3\cdot \left({x}_{1i}\cdot {x}_{2i}\right) $$

(3.4)

这可以分解如下，以强调相互作用如何最终导致 x1 和 x2 之间的关系，其中 y 取决于相互作用中的其他变量:

$$ {\displaystyle \begin{array}{l}\kern2.78em {y}_i={b}_0+\ {}\left({b}_1+{b}_3\cdot {x}_{2i}\right)\cdot {x}_{1i}+\ {}\kern0.5em \left({b}_2+{b}_3\cdot {x}_{1i}\right)\cdot {x}_{2i}\end{array}} $$

(3.5)

类似的逻辑也适用于三方互动，只是依赖于另外两个变量。因为所有较低阶的双向交互也是标准的，所以模型的复杂性(参数的数量)急剧增加。

$$ {\displaystyle \begin{array}{l}{y}_i={b}_0\ {}\kern0.75em +{b}_1\cdot {x}_{1i}+{b}_2\cdot {x}_{2i}+{b}_3\cdot {x}_{3i}\ {}\kern0.75em +{b}_4\cdot \left({x}_{1i}\cdot {x}_{2i}\right)\ {}\kern0.75em +{b}_5\cdot \left({x}_{1i}\cdot {x}_{3i}\right)\ {}\kern0.75em +{b}_6\cdot \left({x}_{2i}\cdot {x}_{3i}\right)\ {}\kern0.75em +{b}_7\cdot \left({x}_{1i}\cdot {x}_{2i}\cdot {x}_{3i}\right)\end{array}} $$

(3.6)

这可以分解如下，以突出每个变量对其他两个变量的依赖性:

$$ {\displaystyle \begin{array}{l}{y}_i={b}_0\ {}\kern0.75em +\left({b}_1+{b}_4\cdot {x}_{2i}+{b}_5\cdot {x}_{3i}+{b}_7\cdot \left({x}_{2i}\cdot {x}_{3i}\right)\right)\cdot {x}_{1i}\ {}\kern0.75em +\left({b}_2+{b}_4\cdot {x}_{1i}+{b}_6\cdot {x}_{3i}+{b}_7\cdot \left({x}_{1i}\cdot {x}_{3i}\right)\right)\cdot {x}_{2i}\ {}\kern0.75em +\left({b}_3+{b}_5\cdot {x}_{1i}+{b}_6\cdot {x}_{3i}+{b}_7\cdot \left({x}_{1i}\cdot {x}_{2i}\right)\right)\cdot {x}_{3i}\end{array}} $$

(3.7)

3.4 公式界面

在R中，许多模型和几乎所有 glm 都是使用公式接口指定的。公式是一种指定简单到复杂模型的灵活方式，它由两部分组成，中间用波浪号(∩)隔开。左手边(LHS)位于波浪号的左侧，右手边(RHS)位于波浪号的右侧。基本形式是

outcome ∼predictor1 + predictor2.

“+”操作符将变量添加到模型中。R的公式接口是一种灵活的指定模型的方式。主要操作符有“+”、-、:、*，它们分别是加法项、-和乘法项。使用update()功能可以修改现有公式。

除了从数据中检查变量的个别影响，GLMs 通常包括两个(或更多)变量的乘积。这是一个非常常见的任务，以至于 formula 接口有一种特殊的方式来指示应该包含两个项的乘积，即“:”运算符。例如，y∾x1 + x2 + x1:x2包括x1、x2，以及它们的交互作用(乘积项)作为y的预测因子。其中一个很好的特性是它正确地处理了连续变量和分类变量。如果x1和x2是连续测度，那么x1:x2将是正则代数积。如果其中一个或两个都是虚拟代码，那么产品将针对虚拟代码进行适当扩展。

当包含交互项时，主要效应和每个变量的单独效应几乎总是包含在内。因为个体效应几乎总是包含在交互作用中，所以可以使用“*”运算符来表示两个变量的交互作用和个体效应:y∩x1 * x2扩展为y∩x1 + x2 + x1:x2。多个操作符可以链接在一起，以便y∩x1 * x2 * x3扩展为y∩x1 + x2 + x3 + x1:x2 + x1:x3 + x2:x3 + x1:x2:x3。有时，一个变量可能会调节与三个或更多其他预测因素的相互作用，但三向或四向相互作用是不可取的。括号可用于对术语集进行分组，以便将运算符分配给组中的所有术语。于是，y∾x1 * (x2 + x3)展开为y∾x1 + x2 + x3 + x1:x2 + x1:x3。

这涵盖了公式中最常用的运算符。另外两个细节有时会有所帮助，尤其是在修改现有公式时。一个点，“.”，可以作为指代一切事物的简称。最后，可以使用“-”操作符删除术语。当使用update()函数更新现有的、通常存储的公式时，这些是最常用的。update()函数将一个现有的公式对象作为其第一个参数，然后是所需的修改。以下代码显示了可能的不同类型的公式更新示例。注意，其他运算符“*”和“:”也可以与“.”一起使用。如果点被完全省略，那么旧公式的这一部分根本不会被重用。我们将在R中使用 formula 接口来构建大部分模型，因此值得花时间彻底学习。

f1 <- y ~ x1 + x2 + x1:x2

update(f1, . ~ .)

## y ~ x1 + x2 + x1:x2

update(f1, w ~ .)

## w ~ x1 + x2 + x1:x2

update(f1, . ~ . + x3)

## y ~ x1 + x2 + x3 + x1:x2

update(f1, . ~ . - x1:x2)

## y ~ x1 + x2

3.5 差异分析

概念背景

方差分析(ANOVA)是一种统计技术，用于划分不同因素导致的结果差异。ANOVAs 是 GLM 的一个特例，具有连续、正态分布的结果和离散/分类解释变量，如性别(女性、男性)或随机实验研究中的状况(如治疗 A、治疗 B 或对照)。由于这些限制，ANOVAs 可以被概念化为测试结果的平均值是否在每个组中是相等的。也就是说，ANOVAs 测试是否:

$$ {\mu}_{TreatmentA}={\mu}_{TreatmentB}={\mu}_{Control} $$

(3.8)

传统上，ANOVAs 被用作零假设统计检验(NHST)的一部分。从本质上讲，NHST 设立了零假设，并问道，假设零假设在总体中为真，在这个数据样本中获得观察结果的概率是多少？零假设的反面是替代假设。在方差分析的情况下，另一个假设是至少一个组的平均值不等于其余的平均值。例如，治疗 A 可能比治疗 B 或对照组具有更低或更高的平均值。

为了将方差分析参数化为 GLM，我们将前面的等式写成一系列的差，例如:

$$ {\displaystyle \begin{array}{l}{\mu}_{Control}-{\mu}_{TreatmentA}\ {}{\mu}_{Control}-{\mu}_{TreatmentB}\end{array}} $$

(3.9)

这些差异被编码到保存预测变量 x 的设计矩阵中。如我们之前所述，使用虚拟编码将组转换为预测变量。

默认情况下，R将使用因子的第一级作为参考组来创建虚拟代码。参考组被省略，但是设计矩阵增加了截距，截距是一个包含 1 的常数列。然后，GLM 将估计参数， β ，设计矩阵的每一列一个参数。因为截距在模型中，所以治疗 A 的系数(R标记为ConditionA)将是治疗 A 的平均值和对照组(参考水平)之间的差值。同样，治疗 B 的系数将是治疗 B 的平均值和对照组之间的差值。截距将获取对照组的平均值。

为了看到这一点，我们可以使用函数lm()估计R中的回归参数，并使用函数coef()提取系数。我们用一个公式接口:outcome predictor写出我们希望 R 拟合的模型。

set.seed(1234)
example <- data.table(
  y = rnorm(9),
  Condition = factor(rep(c("A", "B", "Control"), each = 3),
                     levels = c("Control", "A", "B")))

coef(lm(y ~ Condition, data = example))

## (Intercept)  ConditionA  ConditionB
##      -0.562       0.614       0.092

通过计算每组的平均值，很容易检查这些是否与组平均值的差异相匹配。

example[, .(M = mean(y)), by = Condition]

##    Condition      M
## 1:         A  0.052
## 2:         B -0.470
## 3:   Control -0.562

我们可以立即看到截距与对照组的平均值相同。处理 A 的系数等于对照组和处理 A 组之间的差值。平均值:0.61 = 0.05 - (-0.56).

如果我们要抑制截距，那么设计矩阵将包含每个条件的虚拟代码，回归系数将正好是组平均值，我们在下面的代码中可以看到。通过在公式中添加 0 来抑制截距。但是请注意，这通常只有在模型中包含伪代码时才有意义。在具有连续解释变量的 GLM 中，抑制截距会迫使截距精确为零，这很少是明智的。

model.matrix(~ 0 + Condition, data = example)

##   ConditionControl ConditionA ConditionB
## 1                0          1          0
## 2                0          1          0
## 3                0          1          0
## 4                0          0          1
## 5                0          0          1
## 6                0          0          1
## 7                1          0          0
## 8                1          0          0
## 9                1          0          0
## attr(,"assign")
## [1] 1 1 1
## attr(,"contrasts")
## attr(,"contrasts")$Condition
## [1] "contr.treatment"

coef(lm(y ~ 0 + Condition, data = example))

## ConditionControl       ConditionA       ConditionB
##           -0.562            0.052           -0.470

标准方差分析检验了总体结果中有多少可变性，其中有多少可变性在组均值之间，以及在考虑组均值后还有多少可变性。为了检验是否有任何差异，组均值之间的变异量与组内变异量之比(剩余方差)形成。该比率称为 F 比率，可用于获得 p 值，因为 F 分布的比例比观察到的 F 比率更极端。

F 比率基于均方比率，即平方和(SS)除以自由度(DF)。总是有两个，一个是分子(利益的影响)，一个是分母(误差或残差)，具体来说

$$ F=\frac{M{S}_{model}}{M{S}_{residual}}=\frac{S{S}_{model}/D{F}_{model}}{S{S}_{residual}/D{F}_{residual}} $$

(3.10)

自由度也用于使用pf()功能查找 F 分布的 F 比率。

pf(.72, df1 = 1, df2 = 6, lower.tail = FALSE)

## [1] 0.43

为了使 ANOVAs 中的统计检验有效，必须满足几个假设。第一，观测必须是独立的(独立性)。例如，如果对几个参与者进行重复测量，使得观察结果集中在一个人内(或在一所学校内，或任何其他分组单位内)，则违背了这一假设。第二，以解释变量为条件，结果必须是连续的和正态分布的(正态)。第三，所有解释变量的每个水平内的方差必须相等(方差齐性)。最后一个假设是必需的，因为单个剩余方差用于估计所有组的不确定性。

前面的示例在模型中使用了一个分组因子。可以同时测试多个独立变量或分组变量。包含多个解释变量也允许测试交互作用的效果——一个变量的效果是否依赖于另一个变量的水平。在某种程度上，这是对单个解释变量的巨大进步，因为变量的数量增加了一倍，增加了一个额外的交互(调节)项。然而，从 GLM 的角度来看，这是一个很小的变化。设计矩阵增加了额外的列，其中一些是伪代码的产物，而不是来自单个变量的伪代码。这些都是比较表面的区别。下面的代码修改了我们之前看到的 mtcars 数据集，将一些变量转换为因子，并为两个变量的主要影响及其相互作用创建了一个设计矩阵(如果两个变量都是连续的，则只是两个变量的乘积，如果它们是离散的，则是它们的伪码的乘积)。只有当其他两个伪码都为 1 时，交互作用(标为 vs1:am1)才为 1，它反映了当 vs = 1 和 am = 1 时，均值的差异有多大，超出了它们的平均效应预期。

mtcars <- as.data.table(mtcars)
mtcars[, ID := factor(1:.N)]
mtcars[, vs := factor(vs)]
mtcars[, am := factor(am)]

head(model.matrix(~ vs * am, data = mtcars))

##   (Intercept) vs1 am1 vs1:am1
## 1           1   0   1       0
## 2           1   0   1       0
## 3           1   1   1       1
## 4           1   1   0       0
## 5           1   0   0       0
## 6           1   1   0       0

R 中的方差分析

注意

方差分析检验正态分布结果的组均值是相等还是不同。ez包中的ezANOVA()函数可以运行独立测量、重复测量和混合模型方差分析，并提供假设测试。

为了在R中运行 ANOVA，我们使用了ez包中的ezANOVA()函数，该函数适合各种类型的 ANOVA，并提供 ANOVA 通常报告的附加信息。要使用它，我们需要为ezANOVA()添加一个 ID 变量。ezANOVA()函数接受一个数据集、结果变量(dv)、主题 ID 变量(wid)、主题变量之间的变量(between)。其余参数是可选的，它们控制组不平衡时方差的计算方式以及要打印的输出量。在接下来的代码中，我们使用我们的小型示例数据集，测试条件的整体效果。它还打印一个统计测试，无论方差齐性假设是否满足，Levene 的测试。小的 F 比率(高 p 值)表明很少有证据表明条件之间的差异显著。

example[, ID := factor(1:.N)]

print(ezANOVA(
  data = example,
  dv = y,
  wid = ID,
  between = Condition,
  type = 3,
  detailed = TRUE))

## Coefficient covariances computed by hccm()

## $ANOVA
##        Effect DFn DFd  SSn SSd    F    p p<.05   ges
## 1 (Intercept)   1   6 0.96   8 0.72 0.43       0.108
## 2   Condition   2   6 0.66   8 0.25 0.79       0.076
##
## $'Levene's Test for Homogeneity of Variance'
##   DFn DFd SSn SSd    F    p p<.05
## 1   2   6 1.5 6.1 0.73 0.52

接下来，我们使用包含交互作用的 mtcars 数据集进行方差分析。我们在 subjects 变量和 interaction 变量之间添加了一个加法，但是其余的保持不变。我们首先看到的是关于每种情况下样本大小不等的警告。当样本大小在不同组之间不平衡时，不同的平方和计算方法会产生不同的结果，这是一个有争议的问题[55]。这些结果表明相互作用项没有显著影响。vs 和 am 的两个主要效应(即其本身)在统计上是显著的，并且具有大的效应大小，表明它们与每加仑英里数有关。同样，没有证据表明违反了方差齐性假设。与 GLM 框架相比，F 比率测试对回归系数的类似影响，但方式略有不同。当一个因子有两个以上的级别时，F 比率有多个分子自由度，相当于测试多个回归系数是否同时为零，而不是一次测试一个系数。以下代码输出的最后一列ges显示了广义 eta 平方的效果大小度量。然而，除了测试是如何构建的，ANOVAs 使用的潜在线性模型是 GLMs 允许的模型的子集。

print(ezANOVA(
  data = mtcars,
  dv = mpg,
  wid = ID,
  between = vs * am,
  type = 3,
  detailed = TRUE))

## Warning: Data is unbalanced (unequal N per group). Make sure you specified a well-considered value for the type argument to ezANOVA().

## Coefficient covariances computed by hccm()

## $ANOVA
##        Effect DFn DFd   SSn SSd      F       p p<.05   ges
## 1 (Intercept)   1  28 13144 337 1090.6 5.7e-24     * 0.975
## 2          vs   1  28   382 337   31.7 4.9e-06     * 0.531
## 3          am   1  28   284 337   23.5 4.2e-05     * 0.457
## 4       vs:am   1  28    16 337    1.3 2.6e-01       0.045
##
## $'Levene's Test for Homogeneity of Variance'
##   DFn DFd SSn  SSd    F    p p<.05
## 1   3  28  15 156 0.88 0.46

我们可以使用 Tukey 的诚实显著性差异(HSD)来测试细胞之间的成对差异。下面的代码创建一个新变量，它是 vs 和 am 的组合，然后创建一个显示平均值和 95%置信区间(解释为以相同方式进行的 95%的区间将包括真实总体参数)的图形。任何共享一个字母的细胞在统计学上彼此没有显著差异。不共享一个字母的细胞在统计学上有显著差异。我们使用JWileymisc包中的TukeyHSDgg()进行绘图，调整轴标签的角度并删除 x 轴标题。图 3-1 显示了结果。

img/439480_1_En_3_Fig1_HTML.png

图 3-1

具有置信区间的单元均值图。基于 Tukey 的诚实显著差异，共享字母的细胞在统计上没有显著差异。

mtcars[, Cells := factor(sprintf("vs=%s, am=%s", vs, am))]
TukeyHSDgg("Cells", "hp", mtcars) +
  theme(axis.text.x = element_text(angle=45, hjust=1, vjust=1)) +
  xlab("")

虽然简短，但希望对方差分析的介绍有助于突出方差分析如何用于检验 R 的组均值差异，以及方差分析如何只是 GLMs 的一个特例。最终，ANOVAs 是 GLM 的一个非常有限的特例，因为它们不允许包含连续的解释变量。接下来，我们将线性回归作为 GLM 的一个更灵活的特例进行检验，该特例适用于连续正态分布的结果，同时允许离散和连续的解释变量。

3.6 线性回归

注意

线性回归是连续、正态分布结果变量的 GLM 的特例。与方差分析不同，线性回归适用于离散和连续的解释变量/预测值。rms包中的ols()函数可以运行线性回归并打印综合汇总输出信息。

概念背景

线性回归是 GLMs 的另一种特殊情况，其中链接和反向链接函数只是恒等函数，即 η = g(μ) = μ 和μ= g-1(η)=η并且结果被假设为正态分布。具体来说，分布假设写成 y ~ N ( μ ，σ)。这里的关键信息是 y 是一个向量，因为 μ 是一个常数。分布的平均值通常被称为它的位置，分散参数或标准偏差被称为它的尺度。另一类模型，位置比例模型，允许位置和比例参数作为数据的函数而变化，但对于 GLMs，我们将假设比例是恒定的。分布的另一种常见写法是残差分布，∑~N(0，σ)，其中∑= yμ。这样写强调了这样一个事实，即原始数据不需要遵循正态分布，它们只需要围绕期望值正态分布。它还强调了离差参数 σ 是残差的离差。也就是说， σ 捕捉期望值附近的离差。在最简单的 GLM 中，唯一的预测因子是一个常数项(截距)， σ 将与 y 的标准差相同，但如果回归可以解释 y 的一些或所有变化，那么 σ 将趋向于零。

基于中心极限定理，当样本大小收敛到无穷大时，回归系数与其标准误差之比的参数分布将收敛到正态分布。在线性回归中，我们可以考虑这样一个事实，即我们通常使用有限的样本来测试参数，而不是针对正态分布来测试参数(针对单个回归系数)。当有无限个自由度时，t 分布收敛到正态分布，而当有有限个自由度时，t 分布的尾部稍微重一些。在线性回归中，根据样本大小和参数个数(df=N–k参数 )计算自由度。在后面的章节中，当我们检查其他类型的广义线性模型时，自由度不能很容易地计算出来，所以个体回归系数是根据标准正态分布而不是 t 分布来测试的。

除了测试单个回归系数之外，可以使用似然比测试来测试整个模型，该测试将我们拟合的模型的似然比与仅包含截距作为预测值的零模型进行比较。可能性有用的一个原因是，它们可以很容易地进行比较和测试，从而提供对模型的多个变量或其他限制的准确测试。

在线性回归中，一个常见的效应大小是模型(或单个预测因子)解释的结果中方差的百分比。所占的百分比方差称为R?? 2。在我们能够计算出R2 之前，我们需要几个棋子。我们将偏差平方和(SS) total 定义为结果与其总体预期或均值(SSTotal)的偏差，SSRegression 定义为我们的模型预测结果与结果总体预期的偏差，SSResidual 定义为结果与我们的模型预测值之间差异的 SS。这在以下等式中更正式地示出:

$$ S{S}_{Total}=\sum \limits_{i=1}^N{\left({y}_i-E(y)\right)}² $$

(3.11)

$$ S{S}_{Regression}=\sum \limits_{i=1}^N{\left({\mu}_i-E(y)\right)}² $$

(3.12)

$$ S{S}_{Residual}=\sum \limits_{i=1}^N{\left({y}_i-{\mu}_i\right)}² $$

(3.13)

给定这些定义，对于具有正态分布结果的线性模型， R 2 可计算如下:

$$ {R}²=\frac{S{S}_{Regression}}{S{S}_{Total}}=1-\frac{S{S}_{Residual}}{S{S}_{Total}}= cor{\left(\mathrm{y},\mu \right)}² $$

(3.14)

除非存在无限的样本量，否则计算样本数据中 R 2 的公式是对总体 R 2 的有偏估计。因此，报告调整后的 R 2 也很常见，它考虑了模型自由度，以提供总体 R 2 的无偏估计。当我们训练模型并使用相同的数据对其进行测试时，对自由度的这种调整会调整人口中对方差的过于乐观的估计。当我们在R中讨论机器学习时，我们将讨论过拟合的概念以及使用单独的数据集进行模型估计和测试。在线性回归中，偏差趋于最小，因为与样本量相比，参数相对较少。随着观测值的预测值/参数数量的增加，过度拟合带来的问题和偏差变得更加棘手。 R 2 可用于估计整体模型的预测精度，但也可用于通过比较每次增加或减少一个预测器时模型 R 2 的变化量来量化单个预测器增加的量。

尽管 R 2 是迄今为止最常见的线性回归拟合或判别指数，但也存在其他指数。另一种选择是基于基尼指数的 g 指数[25]。g 指数和 R 2 的一个关键区别是，g 指数不是标准化的，所以它取决于结果的规模和预测因素。然而，与R2 一样，更高表示更好的区分度。

R 中的线性回归

随着我们转向应用和实际数据分析，我们将开始使用真实数据。在这一章中，我们将使用美国人不断变化的生活[45]研究数据。“数据设置”一节介绍了数据的读取和准备从技术上讲，数据具有采样权重，但为了简单起见，我们忽略这些权重。没有加权，分析仍然是正确的；它们只是不能反映抽样人口。

虽然不是对回归假设的直接检验，但了解结果的大致分布是有用的，即生活满意度。图 3-2 显示了正常曲线重叠的密度图。使用adjust = 2到testdistr()的参数，原始密度比默认值更加平滑。从图 3-2 我们可以看到，生活满意度近似正态分布，没有大的异常值。

img/439480_1_En_3_Fig2_HTML.png

图 3-2

正常密度覆盖(蓝线)的生活满意度密度图(黑线)

acl <- readRDS("advancedr_acl_data.RDS")

testdistr(acl$SWL_W1, "normal",
          varlab = "Satisfaction with Life", plot = FALSE,
          extremevalues = "theoretical",
          adjust = 2)$DensityPlot

R有内置函数来拟合线性回归，但是我们使用rms包中的ols()函数，因为它提供了方便的特性和更全面的默认输出。ols这个名字来源于线性回归的另一个名字:普通最小二乘法。这个名称是基于使用最小平方偏差作为估计回归系数的标准。

模型输出首先回显用于拟合模型的公式。它显示了观察值的数量、剩余标准偏差的估计值、、和整个模型的自由度。似然比检验同时提供了对所有预测值的统计显著性的检验，检验了至少一个系数显著不同于零的假设。鉴别指数包括 R 2 和调整后的 R 2 值以及 g 指数。构造残差的均值为零，但由于偏差或异常值，中值可能会有很大不同。检查最小和最大残差对于识别残差异常值也很有用。最后，表中显示了回归系数以及相应的标准误差、t 值和 p 值。

m.ols <- ols(SWL_W1 ~ Sex + AGE_W1 + SESCategory, data = acl, x = TRUE)
m.ols

## Linear Regression Model
##
##  ols(formula = SWL_W1 ~ Sex + AGE_W1 + SESCategory, data = acl,
##      x = TRUE)
##
##                  Model Likelihood    Discrimination
##                        Ratio Test           Indexes
##  Obs    3617    LR chi2    118.62    R2       0.032
##  sigma1.0355    d.f.            5    R2 adj   0.031
##  d.f.   3611    Pr(> chi2) 0.0000    g        0.213
##
##  Residuals
##
##       Min       1Q   Median       3Q      Max
##  -3.44270 -0.67206  0.01543  0.75504  2.36635
##
##
##                 Coef    S.E.   t     Pr(>|t|)
##  Intercept      -0.7057 0.0755 -9.35 <0.0001
##  Sex=(2) FEMALE  0.0308 0.0360  0.86 0.3921
##  AGE_W1          0.0103 0.0011  9.75 <0.0001
##  SESCategory=2  -0.0133 0.0447 -0.30 0.7654
##  SESCategory=3   0.2558 0.0482  5.31 <0.0001
##  SESCategory=4   0.2654 0.0635  4.18 <0.0001
##

使用texreg包，我们可以自动创建格式良好的表格。我们可以使用screenreg()函数为屏幕输出创建表格，使用htmlreg()函数为 HTML 输出创建表格，或者使用texreg()函数为 LATEX 创建表格。

下面的例子展示了如何制作 LATEX 表，在表 3-6 中给出。

表 3-6

统计模型

|   |

模型 1

|
| --- | --- |
| 拦截 | -0.71(0.08)□ |
| 性别=(2)女性 | 0.03 (0.04) |
| 年龄 _W1 | 0.01(0.00)□ |
| SESCategory=2 | −0.01 (0.04) |
| SESCategory=3 | 0.26(0.05)□ |
| SESCategory=4 | 0.27(0.06)□ |
| 编号 obs。 | Three thousand six hundred and seventeen |
| R 2 | Zero point zero three |
| 调整 R 2 | Zero point zero three |
| L.R | One hundred and eighteen point six two |

<【0.001】【t】**

texreg(m.ols, single.row = TRUE, label = "tglm1-olstex")

我们还可以研究关于模型的几个诊断。首先，我们可以通过使用方差膨胀因子(VIF)来探索任何共线性(解释变量之间的高度相关性)的影响。VIF 值接近 1 表示共线性的影响很小。非常高的 VIF 值可能表明包含高度相关的解释变量会增大参数协方差矩阵的方差，从而导致非常大的标准误差和置信区间。当包含两个非常相似的解释变量时，这种情况最常见。

vif(m.ols)

## Sex=(2) FEMALE         AGE_W1  SESCategory=2  SESCategory=3
##            1.0            1.2            1.4            1.5
##  SESCategory=4
##            1.3

接下来，我们用拟合值和残差创建一个数据表，并用它在图 3-3 中绘制残差图，以检查正态性。图 3-4 使用分位数回归【51，50，107】，正如我们在多元数据可视化章节中介绍的，通过绘制第 5、25、50、75 和 95 个百分点的分位数回归线来评估异方差性。这些线相对平坦，表明几乎没有异方差的证据。

img/439480_1_En_3_Fig4_HTML.png

图 3-4

用分位数回归检验残差与拟合值，以探索异方差性

img/439480_1_En_3_Fig3_HTML.png

图 3-3

绘制残差图以评估正态性

diagnostic.data <- data.table(
  fitted = fitted(m.ols),
  resid = residuals(m.ols))

testdistr(diagnostic.data$resid,
          "normal",
          varlab = "Satisfaction with Life Residuals", plot = FALSE,
          extremevalues = "theoretical",
          adjust = 2)$DensityPlot

ggplot(diagnostic.data, aes(fitted, resid)) +
  geom_point(alpha = .2, colour = "grey50") +
  geom_quantile(quantiles = .5, colour = 'black', size = 1) +
  geom_quantile(quantiles = c(.25, .75),
                colour = 'blue', linetype = 2, size = 1) +
  geom_quantile(quantiles = c(.05, .95),
                colour = 'black', linetype = 3, size = 1)

## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x
## Smoothing formula not specified. Using: y ~ x

我们用矩阵符号介绍了 GLM:

$$ \mu ={g}^{-1}\left(\eta \right)={g}^{-1}\left(\mathrm{X}\beta \right) $$

(3.15)

为了更好地理解如何解释系数，使用正则代数将它写出来会很有帮助。在线性回归的情况下，我们可以通过去除反向链接函数来进一步简化，因为链接和反向链接(通常)是相同的函数。还通常对每个变量使用下标 i 来编写下面的等式，以指示对第 i 个个体执行操作。我们用粗体表示变量是向量，包含多个个体的数据。

$$ \mu ={\beta}_0+{\beta}_1\mathrm{Sex}+{\beta}_2\mathrm{Age}+{\beta}_3{\mathrm{SES}}_2+{\beta}_4{\mathrm{SES}}_3+{\beta}_5{\mathrm{SES}}_4 $$

(3.16)

每个系数都反映了预测因子中一个单位变化的结果的预期变化。一个单位的含义取决于每个预测器的规模。例如，年龄是用年来编码的，所以一个单位意味着一年。性别是虚拟编码的，所以一个单位代表了男女之间的区别。社会经济地位(SES)被编码为四分位数，参考类别(省略)是 SES 的最低四分位数。因此，举例来说，年长一岁意味着对生活的满意度提高 0.01%。

我们注意到线性回归是 GLM 的特例。R有内置函数glm()，适合 GLMs。glm()功能的好处是您可以对许多特定类型的 glm 使用相同的功能。公式界面与ols()相同，但glm()允许用户指定不同的分布和链接函数。如果我们简单地打印存储的 GLM 对象，我们得到的输出很少。为了得到一个好的摘要，我们需要使用summary()函数。虽然这在计算上稍微更有效，但是根据我们的经验，大多数用户倾向于想要这个输出，所以ols()函数默认提供一个好的输出摘要是很方便的。glm()函数的另一个缺点是它不显示R2 值。这是因为方差并不适用于所有类型的 GLMs。与独立模型相比，没有对整体模型的默认测试，也没有关于每个变量缺失值数量的信息。

m.glm <- glm(SWL_W1 ~ Sex + AGE_W1 + SESCategory,
             data=acl, family = gaussian(link="identity"))
m.glm

##
## Call:  glm(formula = SWL_W1 ~ Sex + AGE_W1 + SESCategory, family = gaussian(link = "identity"),
##     data = acl)
##
## Coefficients:
##   (Intercept)  Sex(2) FEMALE         AGE_W1   SESCategory2
##       -0.7057         0.0308         0.0103        -0.0133
##  SESCategory3   SESCategory4
##        0.2558         0.2654
##
## Degrees of Freedom: 3616 Total (i.e. Null);  3611 Residual
## Null Deviance:     4000
## Residual Deviance: 3870      AIC: 10500

summary(m.glm)

##
## Call:
## glm(formula = SWL_W1 ~ Sex + AGE_W1 + SESCategory, family = gaussian(link = "identity"),
##     data = acl)
##
## Deviance Residuals:
##    Min      1Q  Median      3Q     Max
## -3.443  -0.672   0.015   0.755   2.366
##
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)   -0.70565    0.07549   -9.35  < 2e-16 ***
## Sex(2) FEMALE  0.03083    0.03602    0.86     0.39
## AGE_W1         0.01030    0.00106    9.75  < 2e-16 ***
## SESCategory2  -0.01333    0.04467   -0.30     0.77
## SESCategory3   0.25579    0.04819    5.31  1.2e-07 ***
## SESCategory4   0.26544    0.06353    4.18  3.0e-05 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## (Dispersion parameter for gaussian family taken to be 1.1)
##
##     Null deviance: 4000.7  on 3616  degrees of freedom
## Residual deviance: 3871.6  on 3611  degrees of freedom
## AIC: 10525
##
## Number of Fisher Scoring iterations: 2

输出与R的内置lm()函数非常相似，该函数专门用于线性回归模型。它确实增加了对R2 的估计，但是同样需要使用summary()并且没有显示每个变量的缺失值。

通常，会评估多个相关的模型。例如，可能有几个焦点预测值，目标是当一些额外的变量(协变量)在模型之内或之外时，检查它们的影响如何变化。其他时候，某些预测值可能会被包括在内，而其他预测值只有在它们具有统计显著性或改善模型性能时才会被包括在内。尝试其他功能形式也很常见。例如，变量可以作为线性效果输入，或者作为线性效果与相同变量的平方(即，二次)一起添加。在本章的前面，我们展示了如何更新R中的公式。update()函数也有许多模型的方法。它的工作方式与公式上的update()类似，除了改变模型公式之外，它还重新拟合模型。为了更新和查看存储在对象中的结果，我们可以将整个调用放在括号中，这将强制打印。在下面的代码中，我们更新了基本模型，并向模型中添加了雇佣状态。

(m.ols2 <- update(m.ols, . ~ . + Employment_W1))

## Linear Regression Model
##
##  ols(formula = SWL_W1 ~ Sex + AGE_W1 + SESCategory + Employment_W1,
##      data = acl, x = TRUE)
##
##                  Model Likelihood    Discrimination
##                        Ratio Test           Indexes
##  Obs    3617    LR chi2    173.43    R2       0.047
##  sigma1.0286    d.f.           12    R2 adj   0.044
##  d.f.   3604    Pr(> chi2) 0.0000    g        0.252
##
##  Residuals
##
##       Min       1Q   Median       3Q      Max
##  -3.50191 -0.66381  0.03265  0.74125  2.55188
##
##
##                             Coef    S.E.   t     Pr(>|t|)
##  Intercept                  -1.1197 0.1244 -9.00 <0.0001
##  Sex=(2) FEMALE              0.0109 0.0387  0.28 0.7776
##  AGE_W1                      0.0092 0.0013  6.83 <0.0001
##  SESCategory=2              -0.0253 0.0451 -0.56 0.5746
##  SESCategory=3               0.2179 0.0498  4.37 <0.0001
##  SESCategory=4               0.2174 0.0655  3.32 0.0009
##  Employment_W1=(2) 2500+HRS  0.5832 0.1098  5.31 <0.0001
##  Employment_W1=(3) 15002499  0.4675 0.0985  4.75 <0.0001
##  Employment_W1=(4) 500-1499  0.5497 0.1085  5.07 <0.0001
##  Employment_W1=(5) 1-499HRS  0.6135 0.1250  4.91 <0.0001
##  Employment_W1=(6) RETIRED   0.5345 0.0962  5.55 <0.0001
##  Employment_W1=(7) UNEMPLOY  0.2498 0.1233  2.03 0.0428
##  Employment_W1=(8) KEEP HS   0.6218 0.0991  6.28 <0.0001
##

为了测试 SES 或就业总体上是否重要，我们需要同时测试所有的伪代码。这可以通过比较两个模型或调用拟合模型上的anova()功能来完成。由此产生的方差分析表显示了对社会经济地位的三自由度测试和对就业的七自由度测试，两者总体上具有统计学意义。

anova(m.ols2)

##                 Analysis of Variance          Response: SWL_W1
##
##  Factor        d.f. Partial SS MS     F     P
##  Sex              1 8.4e-02     0.084  0.08 0.78
##  AGE_W1           1 4.9e+01    49.364 46.65 <.0001
##  SESCategory      3 3.8e+01    12.631 11.94 <.0001
##  Employment_W1    7 5.8e+01     8.318  7.86 <.0001
##  REGRESSION      12 1.9e+02    15.608 14.75 <.0001
##  ERROR         3604 3.8e+03     1.058

没有性别差异，所以我们可以考虑放弃性。我们还可以探索潜在的相互作用，比如年龄和社会经济地位之间的相互作用。这两者都可以在一个步骤中完成，即更新模型。我们再次使用括号强制打印。

(m.ols3 <- update(m.ols2, . ~ . + AGE_W1 * SESCategory - Sex))

## Linear Regression Model
##
##  ols(formula = SWL_W1 ~ AGE_W1 + SESCategory + Employment_W1 +
##      AGE_W1:SESCategory, data = acl, x = TRUE)
##
##                  Model Likelihood    Discrimination
##                        Ratio Test           Indexes
##  Obs    3617    LR chi2    189.72    R2       0.051
##  sigma1.0266    d.f.           14    R2 adj   0.047
##  d.f.   3602    Pr(> chi2) 0.0000    g        0.256
##
##  Residuals
##
##       Min       1Q   Median       3Q      Max
##  -3.37389 -0.65254  0.04075  0.72383  2.60671
##
##
##                             Coef    S.E.   t     Pr(>|t|)
##  Intercept                  -1.2652 0.1568 -8.07 <0.0001
##  AGE_W1                      0.0116 0.0021  5.56 <0.0001
##  SESCategory=2              -0.0495 0.1566 -0.32 0.7518
##  SESCategory=3               0.6213 0.1678  3.70 0.0002
##  SESCategory=4               0.7440 0.2128  3.50 0.0005
##  Employment_W1=(2) 2500+HRS  0.5628 0.1092  5.15 <0.0001
##  Employment_W1=(3) 15002499  0.4643 0.0984  4.72 <0.0001
##  Employment_W1=(4) 500-1499  0.5592 0.1083  5.16 <0.0001
##  Employment_W1=(5) 1-499HRS  0.6284 0.1247  5.04 <0.0001
##  Employment_W1=(6) RETIRED   0.5280 0.0961  5.50 <0.0001
##  Employment_W1=(7) UNEMPLOY  0.2812 0.1232  2.28 0.0225
##  Employment_W1=(8) KEEP HS   0.6293 0.0978  6.43 <0.0001
##  AGE_W1 * SESCategory=2      0.0009 0.0026  0.35 0.7248
##  AGE_W1 * SESCategory=3     -0.0077 0.0029 -2.62 0.0088
##  AGE_W1 * SESCategory=4     -0.0107 0.0041 -2.61 0.0090
##

年龄和社会经济地位之间似乎确实存在相互作用。对于模型中的相互作用，年龄系数是最低四分位数 SES(伪编码 SES 的参照组，因此是 SES 与年龄相互作用的参照组)的年龄和对生活满意度的斜率。相互作用的系数表明，在较高的社会经济地位类别中，年龄与生活满意度之间的关系较低。为了更好地理解这种相互作用，我们可以通过显示生活满意度的期望值如何随年龄变化来绘制图表，结果按社会经济地位类别进行分类。

在R中绘制许多回归模型结果的快速方法是使用visreg包【15】中的visreg()函数。该功能允许快速预测和置信区间的生成和图形化。它有合理的缺省值，比如保存变量，你没有在它们的中间值或连续变量和分类变量的模式中绘图。visreg()函数最少只需要两个参数。第一，模型是什么，第二，你想在 x 轴上绘制哪个变量(xvar自变量)？我们将使用它来请求 x 轴上的年龄，并扩展它来请求不同的行by SESCategory，这将制作一个交互图。

默认情况下,visreg()包括部分残差，一个地毯图，并将交互图分成单独的面板。我们使用overlay = TRUE将所有面板合并成一个图，使用partial = FALSE关闭绘制部分残差，这样我们只有预测的线，使用rug = FALSE关闭显示数据点落在 x 轴上的地毯图，使用xlab和ylab添加一些更好的 x 轴和 y 轴标签，最后，更改线型，这样当图表不以彩色打印时，通过设置line = list(lty = 1:4)仍然可以阅读。所有定制结果如图 3-5 所示。

img/439480_1_En_3_Fig5_HTML.png

图 3-5

按社会经济地位类别对各年龄段生活满意度的估计。阴影区域表示回归估计的 95%置信区间。

plot(visreg(m.ols3, xvar = "AGE_W1", by = "SESCategory",
            plot = FALSE),
     overlay = TRUE, partial = FALSE, rug = FALSE,
     xlab = "Age (years)", ylab = "Predicted Life Satisfaction",
     line = list(lty = 1:4))

由于所有置信区间重叠，该图仍然有点混乱。就个人理解而言，这些可能是有帮助的。在演示文稿中使用时，可能会很难看到线条。我们可以使用另一个参数band = FALSE来关闭置信区间。我们可以通过将图表灰度化，传递四种颜色，用于四条线中的每一条线，来进一步修改它以便发布。进一步定制的结果如图 3-6 所示。

img/439480_1_En_3_Fig6_HTML.png

图 3-6

按社会经济地位类别对各年龄段生活满意度的估计。置信区间已删除。

plot(visreg(m.ols3, xvar = "AGE_W1", by = "SESCategory",
            plot = FALSE),
     overlay = TRUE, partial = FALSE, rug = FALSE,
     xlab = "Age (years)", ylab = "Predicted Life Satisfaction",
     line = list(
       lty = 1:4,
       col = c("black", "grey75", "grey50", "grey25")),
     band = FALSE)

使用visreg()功能既快速又相对容易，所以在大多数设置中它是一个很好的选择，当然也是帮助你自己理解结果的一种方式。为了更好的控制，我们可以手动制作同样的图表。为此，我们需要获得各种年龄和社会经济地位类别的预测值。我们还需要将模型中的其他变量，就业，保持在某个值上。在R中很容易从模型中获得预测值，但是我们首先需要创建一个小型数据集，其中包含我们希望用作预测输入的所有值。这可以通过使用expand.grid()功能轻松完成。重要的是，因子具有与模型中相同的水平，这最容易通过从真实数据中的因子提取levels()来实现。

newdata <- as.data.table(expand.grid(
  AGE_W1=quantile(acl$AGE_W1, .1):quantile(acl$AGE_W1, .9),
  SESCategory = factor(1:4, levels = levels(acl$SESCategory)),
  Employment_W1 = factor("(3) 15002499",
    levels = levels(acl$Employment_W1))))
newdata

##      AGE_W1 SESCategory Employment_W1
##   1:     30           1  (3) 15002499
##   2:     31           1  (3) 15002499
##   3:     32           1  (3) 15002499
##  ---
## 186:     74           4  (3) 15002499
## 187:     75           4  (3) 15002499
## 188:     76           4  (3) 15002499

现在我们可以使用predict()函数生成预测值。我们可以只提取预测值或者每个预测值的预测值和标准误差。标准误差有助于计算每个预测的置信区间，并显示估计的不确定性。为了得到标准误差，我们指定，se.fit = TRUE。结果是一个列表，其中第一个元素包含预测值的向量，第二个元素包含标准误差的向量，我们将其存储回数据表中。

newdata[, c("SWL_W1", "SE") :=
          predict(m.ols3, newdata = newdata, se.fit = TRUE)]
newdata

##      AGE_W1 SESCategory Employment_W1 SWL_W1    SE
##   1:     30           1  (3) 15002499 -0.453 0.076
##   2:     31           1  (3) 15002499 -0.441 0.075
##   3:     32           1  (3) 15002499 -0.430 0.073
##  ---
## 186:     74           4  (3) 15002499  0.014 0.121
## 187:     75           4  (3) 15002499  0.015 0.124
## 188:     76           4  (3) 15002499  0.016 0.128

置信区间的计算方法如下

$$ Estimate\pm SEx{z}_{\alpha /2} $$

(3.17)

z 是指单位正态分布的分位数(通常称为 z 得分)。 z α/ 2 是基于期望的α水平的分位数(例如，95%置信区间为 0.05)。更准确地说，可以使用具有适当自由度的 t 分布的分位数，尽管对于如此大的样本，t 分布实际上是正态的。这可以使用qnorm()功能在R中获得。

print(qnorm(.05/2), digits = 7)

## [1] -1.959964

print(qnorm(1 - (.05/2)), digits = 7)

## [1] 1.959964

接下来，我们使用ggplot2包和来自cowplot包的主题创建一个预测值的图表。代码有点复杂qnorm()功能，但产生了如图 3-7 所示的出版物质量图。虽然这比使用visreg()有些繁琐，但它让我们可以完全控制我们正在计算的预测值，并允许我们在绘制图表或演示之前对预测进行进一步的分析或工作。

img/439480_1_En_3_Fig7_HTML.png

图 3-7

按社会经济地位类别对各年龄段生活满意度的估计。阴影区域表示回归估计的 95%置信区间。

ggplot(newdata, aes(AGE_W1, SWL_W1, linetype=SESCategory)) +
  geom_ribbon(aes(ymin = SWL_W1 + SE * qnorm(.025),
                  ymax = SWL_W1 + SE * qnorm(.975)),
              alpha = .2) +
  geom_line(size = 1) +
  scale_x_continuous("Age (years)") +
  ylab("Satisfaction with Life") +
  theme_cowplot() +
  theme(
    legend.position = c(.8, .16),
    legend.key.width = unit(2, "cm"))

因为它们依赖于回归系数和标准误差(se)，置信区间与 p 值密切相关。然而，它们是显示真实总体回归系数估计的不确定性的一种有用方法。在R中，我们可以使用confint()函数计算每个回归系数的 95%置信区间。

confint(m.ols3)

##                              2.5 %  97.5 %
## Intercept                  -1.5726 -0.9579
## AGE_W1                      0.0075  0.0157
## SESCategory=2              -0.3566  0.2575
## SESCategory=3               0.2922  0.9504
## SESCategory=4               0.3267  1.1612
## Employment_W1=(2) 2500+HRS  0.3487  0.7768
## Employment_W1=(3) 15002499  0.2714  0.6572
## Employment_W1=(4) 500-1499  0.3468  0.7715
## Employment_W1=(5) 1-499HRS  0.3839  0.8729
## Employment_W1=(6) RETIRED   0.3396  0.7163
## Employment_W1=(7) UNEMPLOY  0.0396  0.5227
## Employment_W1=(8) KEEP HS   0.4376  0.8211
## AGE_W1 * SESCategory=2     -0.0041  0.0059
## AGE_W1 * SESCategory=3     -0.0134 -0.0019
## AGE_W1 * SESCategory=4     -0.0186 -0.0027

高性能线性回归

到目前为止，我们已经关注了具有全面输出的便利功能。这大概是大多数用户大部分时间需要的。线性回归在现代计算机上是如此之快，以至于计算时间在大多数时候都不是问题。然而，在某些情况下，计算速度是一个问题。Bootstrapping 是一个过程，我们将在稍后讨论机器学习时进行更深入的讨论，但简单来说，它需要从数据集重复采样，并估计重采样数据的一些参数，以生成经验参数分布。对于自举，我们可能只想提取回归系数，这可以使用coef()函数来完成。

人们经常采取数百或数千个 bootstrap 样本。出于时间和演示的原因，我们只取 500。首先，我们创建一个仅包含我们的变量的小型数据集，因为我们使用英特尔的 MKL 线性代数库，为了获得更纯粹的时间估计，我们将其设置为仅使用一个内核。这在单核机器或不使用 MKL 的机器上可以忽略。

tmpdat <- na.omit(acl[, .(SWL_W1, AGE_W1, SESCategory, Employment_W1)])
## use if using Microsoft R Open with Intel's MKL linear algebra library
setMKLthreads(1)

我们实际的代码相当简单。我们使用system.time()函数来跟踪需要多长时间，然后使用sapply()在 1 到 500 之间循环，创建要使用的行的索引，然后拟合我们的模型并提取系数。

set.seed(12345)
t1 <- system.time(ols.boot <- sapply(1:500, function(i) {
  index <- sample(nrow(tmpdat),
                  size = nrow(tmpdat), replace = TRUE)
  coef(ols(SWL_W1 ~ AGE_W1 * SESCategory + Employment_W1,
           data = tmpdat[index]))
}))

t1

##    user  system elapsed
##    4.27    0.06    4.33

使用ols()函数，花了 4.33 秒完成——没有长到不可能，但是长到足以显著减慢交互数据分析。对于任何实际的应用，我们可能至少需要几千次引导程序重采样。时间将随着重新采样的次数以线性方式增加，因此 10，000 次采样大约需要 86.6 秒。接下来，我们使用RcppEigen包【4】中的fastLm()函数。它使用C++来实现线性模型，以便更快更有效。

set.seed(12345)
t2 <- system.time(rcpp.boot1 <- sapply(1:500, function(i) {
  index <- sample(nrow(tmpdat), size = nrow(tmpdat), replace = TRUE)
  coef(fastLm(SWL_W1 ~ AGE_W1 * SESCategory + Employment_W1, data = tmpdat[index]))
}))

t2

##    user  system elapsed
##     2.5     0.0     2.5

现在，总时间减少到 2.52 秒，因此对于 10，000 次重新采样，大约需要 50.4 秒。最后，我们使用fastLmPure()函数，也来自RcppEigen包。fastLmPure()函数并不智能，它要求用户将结果作为向量和模型矩阵传递，而不是使用公式接口。我们将结果向量和模型矩阵的显式计算包含在我们的系统计时中，然后将自举重采样指数应用于这些预先计算的矩阵。

set.seed(12345)
t3 <- system.time({
  y <- tmpdat[, SWL_W1]
  X <- model.matrix(~ AGE_W1 * SESCategory + Employment_W1, data = tmpdat)
  N <- nrow(tmpdat)
  rcpp.boot2 <- sapply(1:500, function(i) {
    index <- sample.int(N, size = N, replace = TRUE)
    fastLmPure(X = X[index, ], y = y[index])$coefficients
  })
})

t3

##    user  system elapsed
##    0.48    0.02    0.50

使用这种方法，分析只需 0.5 秒。由于它如此之快，我们可以使用 10，000 个重采样轻松地重新运行它。

set.seed(12345)
t4 <- system.time({
  y <- tmpdat[, SWL_W1]
  X <- model.matrix(~ AGE_W1 * SESCategory + Employment_W1, data = tmpdat)
  N <- nrow(tmpdat)
  rcpp.boot3 <- sapply(1:10000, function(i) {
    index <- sample.int(N, size = N, replace = TRUE)
    fastLmPure(X = X[index, ], y = y[index])$coefficients
  })
})

t4

##    user  system elapsed
##    9.95    0.21   10.15

使用 10，000 个重采样需要 10.15 秒。有了并行处理，这个数字还可以进一步降低。我们不使用fastLmPure()进行交互式数据分析，但是对于计算量很大的任务，比如 bootstrapping，或者如果您正在尝试数百种不同的模型，速度的提高是有意义的。最后，我们可以检查使用all.equal()从所有模型中我们确实得到了相同的结果。设置check.attributes = FALSE忽略名称，因为ols()对虚拟系数的命名略有不同。

all.equal(ols.boot, rcpp.boot1, check.attributes = FALSE)

## [1] TRUE

all.equal(ols.boot, rcpp.boot2, check.attributes = FALSE)

## [1] TRUE

3.7 控制混杂因素

在科学领域，GLMs 通常用于研究一个变量对另一个变量的潜在影响。例如，自我效能感是指某人认为自己有能力改变或控制自己的生活的倾向。研究表明，自我效能高的人更容易改变行为(例如，开始锻炼计划、戒烟、报名并完成大学学位)。如果你想象一个自我效能感低的人，这是有道理的:他们倾向于相信他们不会成功地做出改变，并且倾向于认为他们的行为和环境不受他们的控制(例如，受环境、强大的他人等的控制)。).不管一个人是否真的能够或不能影响自己的生活，如果他们认为他们不能，他们可能会更快地放弃，更没有动力去尝试，因此更不可能开始或维持任何行为或追求自己的目标。现在假设自我效能高的人也不太可能经历抑郁症状。我们在引言中提到的 ACL 数据包括一个捕获自我效能的变量和另一个捕获两波数据收集中的抑郁症状的变量。一个自然的起点是测试第一波的自我效能是否能预测第二波的抑郁症状。下面的代码测试了这一点，我们可以看到，确实有一个统计上显著的负相关，在第一波自我效能较高的人往往在第二波有较低的抑郁症状。结果如表 3-7 所示。

表 3-7

统计模型

|   |

模型 1

|
| --- | --- |
| 拦截 | Zero point zero two |
|   | (0.02) |
| 自我效能 _W1 | -0.36 * |
|   | (0.02) |
| 编号 obs。 | Two thousand eight hundred and sixty-seven |
| R 2 | Zero point one three |
| 调整 R 2 | Zero point one three |
| L.R | Three hundred and ninety-nine point seven one |

<【0.001】【t】**

m0 <- ols(CESD11_W2 ˜ SelfEfficacy_W1, data = acl)

texreg(m0, label = "tglm1-olsunadj")

如果这纯粹是一个预测模型，我们可能会对目前的结果感到满意。然而，从科学的角度来看，这不足以表明两个变量是相关的。关联并不意味着一个变量导致另一个变量。这是一个重要的区别。如果自我效能感导致较低的抑郁症状，那么如果我们可以干预并增加某人的自我效能感，我们会期望他们有较少的抑郁症状。然而，如果自我效能不是原因，而只是一个预测因素或与抑郁症状有关，那么改变自我效能可能对抑郁症状没有影响。

形式上，这引入了一个通常称为混杂的概念。出于多种原因，两个变量可能相互关联。关联的一个原因是一个变量导致另一个变量。然而，在一个不准确的现实模型中，你也可以找到两个变量之间的关联，因为一些第三变量导致了这两个变量。例如，假设有慢性健康问题会导致较低的自我效能和较高的抑郁症状。如果慢性健康问题的存在不能以某种方式解释，那么自我效能和抑郁症状之间似乎存在关联。然而，一旦考虑到慢性健康问题的影响，自我效能和抑郁症状可能没有关联。

表示不同可能的因果配置的一种常见方式是通过因果图。这些可以理解为代表不同变量的圆圈和指示哪个变量导致哪个变量的有向箭头。对于这种模型的温和介绍和因果推理的更深入的概述，见[81]。因果图示例如图 3-8 所示。在图 3-8 中， Z 是 X 和 Y 的共同原因。从我们的概念示例来看， Z 将是慢性病， X 将是自我效能，而 Y 将是第二波的抑郁症状。如果不考虑 Z ，将会获得对 X 和 Y 的关联的不准确的、有偏差的估计。

img/439480_1_En_3_Fig8_HTML.png

图 3-8

示例图，其中变量 Z 是 X 和 y 的共同原因。如果不考虑 Z，则 X 和 y 之间似乎存在关联。

不准确的模型还会以其他方式产生有偏差的估计。图 3-9 显示了另一个图形模型，其中 Z 现在是 X 和 Y 的共同结果，称为碰撞器变量，因为来自 X 和 Y 的路径在 Z 上碰撞。如果事实如图 3-9 所示，那么直接测试 X 和 Y 之间的关联是合适的。然而，如果我们试图将 Z 作为混杂变量进行控制，通过将 Z 添加到预测 Y 的模型中，远未减少 Z 的混杂，该模型将导致 X 和 Y 之间的虚假关联。从这两个例子中得到的教训是，如果 Z 是一个共同的原因(例如，图 3-8 ，不恰当的排除路径会导致偏差。相反，如果 Z 是碰撞体(如图 3-9 )，包含路径的不恰当会导致偏差。

img/439480_1_En_3_Fig9_HTML.png

图 3-9

示例图，其中变量 Z 是 X 和 Y 的碰撞体(常见结果)。如果在检查 X 和 Y 之间的关联时忽略 Z，则该关联将被准确估计。但是，如果碰撞器 Z 被条件化，那么它将打开 X 和 y 之间的关联。

最后一个例子如图 3-10 所示。这里的 Z 是 X 冲击 Y 的机构。换句话说， Z 将 X 的效果传递给 Y 。在这种情况下，我们可以测试 X 通过 Z 对 Y 的间接影响，但是在模型中没有 Z 的情况下，我们应该会看到 X 与 Y 的关联，但是一旦 Z 被添加到模型中， X 应该不再与 Y 直接关联，因为

img/439480_1_En_3_Fig10_HTML.png

图 3-10

示例图，其中变量 Z 是 X 和 Y 的机制(中介)。因为 Z 将 X 的影响传递到 Y，所以对 Z 的调节将消除 X 和 Y 的关联。如果在检查 X 和 Y 之间的关联时忽略 Z，则该关联将被准确估计。

这些想法中的许多，无论是横截面数据还是纵向数据，都在为边际结构模型(MSMs) [80]开发的理论中有更深入的阐述。MSM 通常使用逆概率加权估值器进行估计[80]。在离散预测器的上下文中， X ，计算第个人的逆概率权重(IPW)的基本等式是

$$ {w}_i=\frac{1}{P\left(X={x}_i|Z={z}_i\right)} $$

(3.18)

有时，这些基本权重被扩展以计算所谓的稳定权重，这些权重只是针对 X 采用任何特定值的边际概率进行调整，由以下等式给出

$$ s{w}_i=\frac{P\left(X={x}_i\right)}{P\left(X={x}_i|Z={z}_i\right)} $$

(3.19)

虽然逆概率加权(IPW)估计的使用来自于焦点预测因子是二分法处理的模型，但是 IPW 思想也很容易推广到连续预测因子。简而言之，这个想法是假设你正在研究一个焦点预测因子， X ，以及它与一些结果的关联， Y ，但是有一些已知的混杂变量， Z 。调整 Z 效果的一种方法是计算给定特定 Z 时 X 的概率。在连续的情况下，使用相同的基本思想，除了不是依赖于概率质量函数，我们必须使用概率密度函数用于一些假设的分布。此外，标准做法是使用稳定的砝码。假设我们相信 X 遵循正态分布， X ~ N ( μ，σ )，我们估计连续预测器的稳定权重为

$$ s{w}_i=\frac{f_X\left(X;{\mu}_1,{\sigma}_1\right)}{f_{X\mid Z}\left(X|Z={z}_i;{\mu}_2,{\sigma}_2\right)} $$

(3.20)

其中 f X (⋅)是正态分布的概率密度函数。本质上，通过使用基于 X 的无条件模型的概率密度函数估计，我们可以控制 X 的不同变化量。

使用 IPWs，我们可以获得我们感兴趣的模型，并使用 IPWs 对其进行估计，并且如果正确指定了用于生成权重的模型以及关联 X 和 Y 的模型，这被证明可以渐近地产生预测值 X 与结果 Y 的关联的无偏估计。权重模型(例如，未能包括所需的混杂变量，或未能指定正确的函数形式，如指定线性关联，而实际上它是二次的)或焦点模型的错误指定将导致有偏估计。在持续暴露的情况下，一个建议是缩小或调整底部和顶部 1%的权重，以减少与极端权重相关的噪声[68]。关于构建 IPWs 的更多信息可在参考文献[22]和[68]中获得。

为了在R中构造 IPWs，我们可以使用优秀的ipw包【96】。首先，我们必须决定我们希望在 IPW 调整模型中调整哪些变量。通常有几个步骤。也许作为我们的第一步，我们包括一些潜在的共同原因，我们认为(基于理论，以前的数据，希望比随机直觉稍微强一点)是自我效能和抑郁症状的潜在共同原因。性别、种族/民族和年龄可能是很好的选择，特别是因为这些都不可能是由自我效能或抑郁症状引起的。我们也可能包括一些慢性疾病。

为了计算单个时间点的 IPWs，我们使用ipw包中的ipwpoint()函数。该函数要求我们指定暴露的变量名；预期分布，在这种情况下我们假设正态分布；然后是分子和分母概率密度函数的模型。最后，当然我们必须告诉ipwpoint()使用哪个数据集。我们将结果保存为R中的变量w。可以从结果中访问 IPWs，如ipw.weights。在图 3-11 中显示了原始重量和将底部和顶部 1%百分点相加后的重量的快速分布图。

img/439480_1_En_3_Fig11_HTML.png

图 3-11

自我效能的原始和修整的反向概率权重

## weights
w <- ipwpoint(
  exposure = SelfEfficacy_W1,
  family = "gaussian",
  numerator = ~ 1,
  denominator = ~ 1 + Sex + RaceEthnicity + AGE_W1 + NChronic12_W1,
  data = acl)

plot_grid(
  testdistr(w$ipw.weights, plot = FALSE)$DensityPlot,
  testdistr(winsorizor(w$ipw.weights, .01),
            plot = FALSE)$DensityPlot,
  ncol = 1)

一旦我们有了权重，我们就可以通过将权重传递给ols()的weights参数来估计一个加权模型。使用 IPWs 将性别、种族/民族、年龄和慢性病作为潜在的混杂因素进行调整。为了进行比较，我们包括了未调整的模型，结果如表 3-8 所示。

表 3-8

统计模型

|   |

模型 1

|

模型 2

|
| --- | --- | --- |
| 拦截 | Zero point zero two | Zero point zero two |
|   | (0.02) | (0.02) |
| 自我效能 _W1 | 0.36 | 0.32 |
|   | (0.02) | (0.02) |
| 编号 obs。 | Two thousand eight hundred and sixty-seven | Two thousand eight hundred and sixty-seven |
| R 2 | Zero point one three | Zero point one one |
| 调整 R 2 | Zero point one three | Zero point one one |
| L.R | Three hundred and ninety-nine point seven one | Three hundred and twenty-five point two three |

** * * <【0.001】、**<<【0.01】、

## unweighted, unadjusted
m0 <- ols(CESD11_W2 ~ SelfEfficacy_W1, data = acl)

## weighted, adjusted
m1 <- ols(CESD11_W2 ~ SelfEfficacy_W1, data = acl,
  weights = winsorizor(w$ipw.weights, .01))

texreg(list(m0, m1),
       label = "tglm1-weight1")

作为敏感性分析，我们也可以尝试进一步调整其他因素，我们认为这些因素可能是混杂因素，也可能是传递自我效能对抑郁症状影响的介质或机制。在这种情况下，我们添加了社会经济地位类别、就业、身体质量指数、吸烟状况和身体活动类别。我们估计权重，然后使用这些新的权重重新估计模型。表 3-9 中给出了未调整模型与部分和完全调整模型的对比。

表 3-9

统计模型

|   |

模型 1

|

模型 2

|

模型 3

|
| --- | --- | --- | --- |
| 拦截 | Zero point zero two | Zero point zero two | Zero point zero two |
|   | (0.02) | (0.02) | (0.02) |
| 自我效能 _W1 | 0.36 | 0.32 | 0.29 *** |
|   | (0.02) | (0.02) | (0.02) |
| 编号 obs。 | Two thousand eight hundred and sixty-seven | Two thousand eight hundred and sixty-seven | Two thousand eight hundred and sixty-seven |
| R 2 | Zero point one three | Zero point one one | Zero point zero nine |
| 调整 R 2 | Zero point one three | Zero point one one | Zero point zero nine |
| L.R | Three hundred and ninety-nine point seven one | Three hundred and twenty-five point two three | Two hundred and sixty-one point five two |

** * * <【0.001】、**<<【0.01】、

# weighted, fully adjusted
w2 <- ipwpoint(
  exposure = SelfEfficacy_W1,
  family = "gaussian",
  numerator = ~ 1,
  denominator = ~ 1 + Sex + RaceEthnicity + AGE_W1 + NChronic12_W1 +
    SESCategory + Employment_W1 + BMI_W1 + Smoke_W1 + PhysActCat_W1,
  data = acl)

m2 <- ols(CESD11_W2 ~ SelfEfficacy_W1, data = acl,
  weights = winsorizor(w2$ipw.weights, .01))

texreg(list(m0, m1, m2),
       label = "tglm1-weight2")

调整潜在混杂因素的另一种方法是简单地将潜在混杂因素添加到模型中。以下代码显示了这样的例子，称为型号m1b和m2b,“b”表示它是 IPW“型号 1”和“型号 2”的替代产品:

m1b <- ols(CESD11_W2 ~ Sex + RaceEthnicity + AGE_W1 +
  NChronic12_W1 + SelfEfficacy_W1,
  data = acl)

m2b <- ols(CESD11_W2 ~ Sex + RaceEthnicity + AGE_W1 +
  NChronic12_W1 + SESCategory +
  Employment_W1 + BMI_W1 + Smoke_W1 + PhysActCat_W1 +
  SelfEfficacy_W1, data = acl)

最后，有些人建议使用所谓的双重稳健估计量。双重稳健估计简单地包括两个 IPW 权重，然后包括用于将权重显式构建到模型中的相同混杂。这方面的例子显示在下面的代码中，标记为m1c和m2c，因为它们是我们的两个调整模型的另一个变体。

m1c <- ols(CESD11_W2 ~ Sex + RaceEthnicity + AGE_W1 +
  NChronic12_W1 + SelfEfficacy_W1,
  data = acl,
  weights = winsorizor(w$ipw.weights, .01))

m2c <- ols(CESD11_W2 ~ Sex + RaceEthnicity + AGE_W1 +
  NChronic12_W1 + SESCategory +
  Employment_W1 + BMI_W1 + Smoke_W1 + PhysActCat_W1 +
  SelfEfficacy_W1, data = acl,
  weights = winsorizor(w2$ipw.weights, .01))

为了比较这些不同的方法，我们可以从每个模型中提取估计值和置信区间，然后绘制图表，这样我们就可以很容易地将差异可视化。这显示在下面的代码中，结果如图 3-12 所示。在这种情况下，所有的结果都非常相似。当变量只存在于一个时间点时，通常就是这种情况。然而，在特别推荐 IPWs 的边际结构模型的情况下，这些方法可能会有更大的差异。

img/439480_1_En_3_Fig12_HTML.png

图 3-12

不同模型中自我效能与抑郁症状关联的估计值和置信区间的比较。Covs =协变量调整模型。逆概率权重调整模型。Covs + IPW =在模型中再次明确包含反向概率权重和相同潜在混杂的模型。

## write an extract function
extractor <- function(obj, label) {
  b <- coef(obj)
  ci <- confint(obj)
  data.table(
    Type = label,
    B = b[["SelfEfficacy_W1"]],
    LL = ci["SelfEfficacy_W1", "2.5 %"],
    UL = ci["SelfEfficacy_W1", "97.5 %"])
}

allresults <- rbind(
  extractor(m0,  "M0: Unadjusted"),
  extractor(m1,  "M1: Partial IPW"),
  extractor(m1b, "M1: Partial Covs"),
  extractor(m1c, "M1: Partial Covs + IPW"),
  extractor(m2,  "M2: Full IPW"),
  extractor(m2b, "M2: Full Covs"),
  extractor(m2c, "M2: Full Covs + IPW"))
allresults[, Type := factor(Type, levels = Type)]

ggplot(allresults, aes(Type, y = B, ymin = LL, ymax = UL)) +
  geom_pointrange() +
  coord_flip() +
  xlab("") + ylab("Estimate + 95% CI")

3.8 案例研究:具有交互作用的多元线性回归

这个案例研究是模仿一篇期刊文章，研究人员对测试青少年睡眠和消极情绪的认知脆弱性模型感兴趣[5]。在这项研究中，大约 150 名青少年完成了负面情绪(情绪，抑郁和焦虑症状的复合物)、睡眠功能障碍信念(DBAS)、一般功能障碍态度(DAS)、学业压力(压力)和主观睡眠质量(SSQ)的测量，并佩戴了加速计来客观评估睡眠。具体来说，晚上入睡需要多少分钟(睡眠发作潜伏期；SOLacti)。测量是在学校和假期期间收集的，但这里我们关注的是假期。请注意，根据这些数据，主观睡眠质量得分越高，表明睡眠质量越差。

使用 Bei 及其同事[5]的表 2 中的标准化回归系数以及同一篇文章的表 1 中的平均值和标准差，我们可以模拟一个与该文章中使用的数据大致相似的数据集。

set.seed(12345)
adosleep <- data.table(
  SOLacti = rnorm(150, 4.4, 1.3)²,
  DBAS = rnorm(150, 72, 26),
  DAS = rnorm(150, 125, 32),
  Female = rbinom(150, 1, .53),
  Stress = rnorm(150, 32, 11))
adosleep[, SSQ := rnorm(150,
             (.36 * 3 / 12.5) * SOLacti +
             (.16 * 3 / 26) * DBAS +
             (.18 * 3 / .5) * Female +
             (.20 * 3 / 11) * Stress, 2.6)]
adosleep[, MOOD := rnorm(150,
             (-.07 / 12.5) * SOLacti +
             (.29  / 3) * SSQ +
             (.14  / 26) * DBAS +
             (.21  / 32) * DAS +
             (.12  / 32) * SSQ * (DAS-50) +
             (.44  / .5) * Female +
             (.28 / 11) * Stress, 2)]
adosleep[, Female := factor(Female, levels = 0:1,
                            labels = c("Males", "Females"))]

作为一个更大模型的一部分，研究人员假设主观睡眠质量与消极情绪有关，但这种关系会受到一般功能失调态度的调节。特别是，功能失调的态度被认为是一种弱点，因此，功能失调态度高的青少年也认为睡眠质量差，他们更容易受到负面情绪的影响。相反，对于那些功能失调态度水平较低的人，即使主观睡眠质量较差，他们也可能不太容易受到主观睡眠质量和消极情绪之间的影响(关系较弱)。通过活动描记法(一种客观测量)评估的睡眠开始潜伏期、压力、性别和对睡眠的功能障碍信念也包括在分析中。

首先，我们检查核心变量，以检查它们的分布并寻找任何异常值(图 3-13 )。

img/439480_1_En_3_Fig13_HTML.png

图 3-13

案例研究变量的分布

plot_grid(
  testdistr(adosleep$MOOD, extremevalues = "theoretical",
            plot=FALSE, varlab = "MOOD")$Density,
  testdistr(adosleep$SSQ, extremevalues = "theoretical",
            plot=FALSE, varlab = "SSQ")$Density,
  testdistr(adosleep$SOLacti, extremevalues = "theoretical",
            plot=FALSE, varlab = "SOLacti")$Density,
  testdistr(adosleep$DAS, extremevalues = "theoretical",
            plot=FALSE, varlab = "DAS")$Density,
  ncol = 2)

接下来，我们检查(连续)研究变量之间的二元相关性(图 3-14 )。

img/439480_1_En_3_Fig14_HTML.png

图 3-14

研究变量之间相关性的热图

plot(SEMSummary(
  ~ MOOD + SOLacti + DBAS + DAS + Stress + SSQ,
  data = adosleep), plot = "cor") +
  theme(axis.text.x = element_text(
          angle = 45, hjust = 1, vjust = 1))

接下来，我们为这项研究制作一个描述性统计表。尽管非常基本，但在大多数结果展示中，研究变量的描述性统计表格或图表是标准做法，以使读者更好地理解每个被测试变量的分布和范围。这里，我们利用JWileymisc包中的egltable()函数来计算和显示连续变量的平均值和标准偏差，以及离散变量的 N 和百分比(这里只是阴性)。

egltable(c("SOLacti", "SSQ", "MOOD", "Stress",
           "DBAS", "DAS", "Female"),
         data = as.data.frame(adosleep))

##                M (SD)/N (%)
## 1:   SOLacti  23.33 (13.60)
## 2:       SSQ    6.18 (3.00)
## 3:      MOOD    4.53 (2.49)
## 4:    Stress  32.84 (10.92)
## 5:      DBAS  72.10 (23.88)
## 6:       DAS 130.57 (30.45)
## 7:    Female
## 8:     Males      67 (44.7)
## 9:   Females      83 (55.3)

为了得到 Bei 及其同事论文[5]中的标准化估计值，我们可以标准化预测值。

adosleep[, zMOOD := as.vector(scale(MOOD))]
adosleep[, zDBAS := as.vector(scale(DBAS))]
adosleep[, zDAS := as.vector(scale(DAS))]
adosleep[, zSSQ := as.vector(scale(SSQ))]
adosleep[, zSOLacti := as.vector(scale(SOLacti))]
adosleep[, zStress := as.vector(scale(Stress))]

接下来，我们拟合三个不同的模型进行比较。首先我们从所有协变量开始。第二，我们添加没有交互作用的感兴趣的主要结构。第三，我们添加了主观睡眠质量和全球功能失调信念之间的假设相互作用。最后，我们使用screenreg()函数将所有结果放在一个表中。在这种情况下，screenreg()输出圆括号中的系数和标准误差，p 值阈值用星号表示。这种布局使得比较系数如何根据模型中的其他因素而变化变得非常容易。

m.adosleep1 <- ols(zMOOD ~ zSOLacti + zDBAS + Female + zStress,
                   data = adosleep)
m.adosleep2 <- update(m.adosleep1, . ~ . + zSSQ + zDAS)
m.adosleep3 <- update(m.adosleep2, . ~ . + zSSQ:zDAS)

screenreg(list(m.adosleep1, m.adosleep2, m.adosleep3))

##
## ==================================================
##                 Model 1     Model 2     Model 3
## --------------------------------------------------
## Intercept        -0.24 *     -0.28 **    -0.28 **
##                  (0.11)      (0.09)      (0.09)
## zSOLacti          0.17 *      0.04        0.03
##                  (0.08)      (0.07)      (0.07)
## zDBAS             0.14        0.07        0.08
##                  (0.08)      (0.06)      (0.06)
## Female=Females    0.44 **     0.50 ***    0.50 ***
##                  (0.15)      (0.13)      (0.13)
## zStress           0.26 ***    0.19 **     0.20 **
##                  (0.08)      (0.07)      (0.07)
## zSSQ                          0.34 ***    0.34 ***
##                              (0.07)      (0.07)
## zDAS                          0.41 ***    0.44 ***
##                              (0.06)      (0.06)
## zSSQ * zDAS                               0.14 *
##                                          (0.07)
## --------------------------------------------------
## Num. obs.       150         150         150
## R²               0.18        0.43        0.45
## Adj. R²          0.16        0.41        0.42
## L.R.             29.54       85.59       89.91
## ==================================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

回想一下，主观睡眠质量得分越高，表明睡眠质量越差，模型 2 显示，总体睡眠质量差和总体功能失调的态度与更多的负面情绪显著相关(p < .001)。转到模型 3，睡眠质量和功能失调态度之间的相互作用是积极而显著的，表明青少年的功能失调态度越多，主观睡眠质量差和消极情绪之间的关系就越强。

为了确保模型看起来合适，我们可以检查方差膨胀因子和残差的分布。合理的起点是最复杂的模型，因为它具有最多的变量，其中一些变量最有可能是共线的。

vif(m.adosleep3)

##       zSOLacti          zDBAS Female=Females        zStress
##            1.2            1.1            1.0            1.1
##           zSSQ           zDAS    zSSQ * zDAS
##            1.3            1.1            1.1

testdistr(resid(m.adosleep3), plot=FALSE, varlab = "Residuals")$QQPlot

没有一个方差膨胀因子特别高，残差呈现正态分布(图 3-15 )，所以我们继续。

img/439480_1_En_3_Fig15_HTML.png

图 3-15

模型残差的分布

为了解开交互，创建一个图是有帮助的。出于图示的目的，如果测量的尺度有意义(例如，以年为单位的年龄)，或者该测量常用于读者可能熟悉的原始尺度，则通常使用变量的原始尺度。我们还创建了一个新的数据集来生成图表预测。我们持有的所有协变量的均值或众数。作为“低”和“高”功能失调态度的示例值，我们使用平均值-一个标准偏差和平均值+一个标准偏差。

## refit model on raw data
m.adosleep.raw <- ols(MOOD ~ SOLacti + DBAS + Female +
                        Stress + SSQ * DAS,
                      data = adosleep)

## create a dataset
adosleep.newdat <- as.data.table(with(adosleep, expand.grid(
  SOLacti = mean(SOLacti),
  DBAS = mean(DBAS),
  Female = factor("Females", levels(Female)),
  Stress = mean(Stress),
  SSQ = seq(from = min(SSQ), to = max(SSQ), length.out = 100),
  DAS = mean(DAS) + c(1, -1) * sd(DAS))))

adosleep.newdat$MOOD <- predict(m.adosleep.raw,
                                newdata = adosleep.newdat,
                                se.fit = FALSE)

adosleep.newdat[, DAS := factor(round(DAS),
  levels = c(100, 161),
  labels = c("M - 1 SD", "M + 1 SD"))]

图 3-16 显示了主观睡眠质量和消极情绪之间的关系如何在低水平和高水平的功能失调态度中变化，对于具有较高水平功能失调态度的脆弱青少年，不良睡眠质量和消极情绪之间的关系被夸大了。

img/439480_1_En_3_Fig16_HTML.png

图 3-16

主观睡眠质量和预测消极情绪的整体功能失调信念之间的相互作用

ggplot(adosleep.newdat, aes(SSQ, MOOD, linetype=DAS)) +
  geom_line(size = 2) +
  scale_x_continuous("Subjective sleep quality\n(higher is worse)") +
  ylab("Negative Mood") +
  theme_cowplot() +
  theme(
    legend.position = c(.85, .15),
    legend.key.width = unit(2, "cm"))

总的来说，这为我们从这个案例研究开始的问题提供了一个相当彻底的检查。关于呈现结果的其他方式以及更详细的解释可能是什么样的想法，我们请读者参考在线免费提供的原始文章[5]:doi . org/10 . 5665/sleep . 4508。

3.9 摘要

本章介绍了广义线性模型(GLM)的概念背景，以及这个广泛的框架如何将许多常见的统计模型作为特例。还介绍了 GLM 的两个具体特例:方差分析和线性回归，当焦点结果或因变量是连续的且呈正态分布时，这两种方法是合适的。表 3-10 总结了本章介绍的一些主要建模功能。下一章将继续 GLM 主题，但重点是不遵循正态分布的结果的 GLMs，如二进制和计数数据。

表 3-10

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| model.matrix() | 采用描述解释性预测变量的公式，并生成设计矩阵以适应 GLMs。 |
| update() | 便于更新现有公式或模型对象，以添加或删除变量。 |
| ezANOVA() | 来自ez包的函数，该包提供了一个框架，用于拟合多种类型的方差分析模型以及拟合指数和诊断。 |
| anova() | 拟合方差分析模型的内置函数。也用于从 GLM 模型中获取方差分析汇总表。 |
| ols() | 符合线性回归模型的rms包中的函数，以及全面的默认输出和诊断信息。 |
| glm() | 用于拟合广义线性模型的内置R函数，包括线性回归等等。 |
| summary() | 经常对拟合 GLM 的结果调用该函数，以产生额外的汇总信息。 |
| coef() | 从线性回归或其他拟合 GLMs 中提取回归系数的函数。 |
| vif() | 计算线性回归模型中每个预测值的方差膨胀因子的函数，用于确定由于模型中存在共线解释变量而导致参数协方差矩阵膨胀的程度。 |
| predict() | 一种使用现有拟合模型对新数据生成预测值的功能。也可用于从模型生成交互图或预测图。 |
| ipwpoint() | 计算离散或连续预测值/暴露变量在一个时间点的逆概率权重的函数。适用于计算边际结构模型和尝试说明潜在的混淆因素。 |
| texreg() | 从各种模型制作表格的功能。也可以在一个表格中包含多个型号，以便于比较。 |****

四、GLM 2

广义线性模型(GLMs)也可以适应非连续和正态分布的结果。事实上，GLMs 的一大优势是它们提供了一个统一的框架来理解应用于假设来自各种分布的变量的回归模型。对于这一章，我们将主要依靠一个优秀的R包VGAM,，它为向量广义线性模型(VGLMs)和向量广义加法模型(VGAMs)提供了实用程序【125】。VGLMs 和 VGAMs 是一类更加灵活的模型，其中可能有多个响应。然而，除了提供多参数的灵活性，VGAM包实现了超过 20 个链接函数，超过 50 个不同的模型/假设分布。在这一章中，我们将只触及VGAM包功能的表面，但是它的巨大灵活性意味着我们将不需要引入许多不同的包，也不需要许多不同的功能。如果您想更深入地了解 VGLMs 和 VGAMs，我们推荐一本由VGAM软件包[125]的作者撰写的优秀书籍。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(data.table)
library(ggplot2)
library(ggthemes)
library(scales)
library(viridis)
library(VGAM)
library(ipw)
library(JWileymisc)
library(xtable)
library(texreg)

options(
  width = 70,
  stringsAsFactors = FALSE,
  datatable.print.nrows = 20,
  datatable.print.topn = 3,
  digits = 2)

4.1 概念背景

本章涵盖了几种特定类型的 GLMs，它们共同构成了除最常见的线性模型之外的大多数其他常用 GLMs。

逻辑回归

离散数据的三种 GLMs 是二元、有序和多项式逻辑回归。它们共享规范链接函数 logit，其一般形式为:

$$ {\log}_e\left(\frac{p}{1-p}\right) $$

(4.1)

其中 p 是某个概率。对于二元和多元逻辑回归，我们可以将概率写成

$$ {\log}_e\left(\frac{P\left(Y=j|X\right)}{P\left(Y=M+1|X\right)}\right) $$

(4.2)

对于j1、...，M 这里有 M + 1 个离散层次的结果。在二元的情况下，有两个级别的结果， M = 1 和 M + 1 = 2，因为我们知道属于任何给定组(结果级别)的概率之和必须是 1:

$$ \sum \limits_{j=1}^{M+1}P\left(Y=j|X\right)=1 $$

(4.3)

那么二元结果的 logit 表达式简化为

$$ {\log}_e\left(\frac{P\left(Y=1|X\right)}{1-P\left(Y=1|X\right)}\right) $$

(4.4)

对于有序逻辑回归情况，标准做法是使用累积逻辑，其形式为

$$ {\log}_e\left(\frac{P\left(Y\le j|X\right)}{1-P\left(Y\le j|X\right)}\right) $$

(4.5)

概率的比率被称为几率:

$$ Odds=\frac{P\left(Y=1|X\right)}{1-P\left(Y=1|X\right)} $$

(4.6)

例如，假设给定一些预测值和模型，P(Y= 1 |X)= 0.75，那么

$$ Odds=\frac{.75}{1-.75}=\frac{.75}{.25}=3 $$

(4.7)

如果赔率 = 3被解释为具有该组特定预测值的某人预期发生该事件( Y = 1)的可能性是不发生该事件( Y = 0)的三倍。logit 是概率的对数，确保至少在理论上有可能从∞到+∞。

回归系数也基于赔率。以具有单个预测器的模型的最简单情况为例， x 1 该模型将为

$$ {\log}_e\left(\frac{P\left({Y}_i=1|X={x}_{1i}\right)}{1-P\left({Y}_i=1|X={x}_{1i}\right)}\right)={\beta}_0+{\beta}_1\ast {x}_{1i} $$

(4.8)

系数 β 1 则定义为

$$ {\beta}_1={\log}_e\left(\frac{P\left({Y}_i=1|X={x}_{1i}+1\right)}{P\left({Y}_i=1|X={x}_{1i}\right)}\right) $$

(4.9)

这是给定的赔率比的自然对数xI1vsxI1+1。通常的做法是报告比值比而不是对数比值比，这是通过对系数求幂来实现的。

$$ OddsRatio= OR={e}^{\beta_1} $$

(4.10)

假设β1= 0.5，那么e0。 5 = 1.65，我们将此解释为表明 x 1 中的一个单位变化与发生该事件的 1.65 倍几率相关。与具有相当自然的解释的优势相比，优势比在某种程度上更难解释，因为它们代表了优势的倍增变化，但没有告诉我们优势从何开始。为了说明这一点，2 的优势比同样可以从. 02/.01 和 2/1 中产生。在这两种情况下，赔率都是 2，但即使确实有人有两倍的赔率，在绝对基础上，赔率仍然很小，0.02，在另一种情况下，新的赔率表明某人发生该事件的可能性是不发生该事件的两倍。

计数回归

我们将在本章介绍的其他类型的 GLMs 是为计数数据设计的模型。计数数据是离散的，类似于逻辑回归中使用的结果，但与逻辑回归不同，计数结果可以采用许多值，并且是有序的。形式上，计数结果的范围是 0∞中的整数。计数结果出现在各种情况下。例如，在医疗环境中，特别是随着人口老龄化，越来越常见的是考虑共病的计数。在保险行业，建立一个人会遭遇多少次事故的模型是可取的。很多人可能是零事故，但有的会有一次，有的两次，更少的三次，四次等。在生产中，故障率和失败率很重要。如果一条生产线或一家工厂有大量不合格产品，这对于减少错误、降低成本和提高质量控制来说是非常有价值的信息。

计数数据的两种最常见的 GLMs 类型是泊松回归和负二项式回归。泊松分布只有一个参数，即比率或平均值，通常表示为 λ 。给定该参数，泊松的概率质量函数为

$$ P\left(Y=y;\lambda \right)=\frac{e^{-\lambda }{\lambda}^y}{y!} $$

(4.11)

泊松分布的均值和方差都是 λ 。为了比较，这里有两个不同比率的泊松分布，如图 4-1 所示。注意，当我们有预先计算的值并且想要一个条形图时，我们使用geom_col()而不是geom_bar()。

img/439480_1_En_4_Fig1_HTML.png

图 4-1

λ= 2 和λ= 6 的泊松分布的密度

dpoisson <- data.table(X = 0:20)
dpoisson[, Lambda2 := dpois(X, lambda = 2)]
dpoisson[, Lambda6 := dpois(X, lambda = 6)]

ggplot(melt(dpoisson, id.vars = "X"),
       aes(X, value, fill = variable)) +
  geom_col(position = "dodge") +
  scale_fill_viridis(discrete = TRUE) +
  theme(legend.position = c(.7, .8)) +
  xlab("Y Score") + ylab("Poisson Density")

泊松回归和负二项式回归的标准关联函数都是自然对数。因此，泊松和负二项式回归的标准模型是

$$ {\log}_e\left({Y}_i\right)={\beta}_0+{\beta}_1\ast {x}_1+\cdots +{\beta}_k\ast {x}_k $$

(4.12)

这给了他们的系数一个方便的解释。例如， β 1 将是 x 1 中的一个单位变化事件预计会发生多少次。

负二项式回归与泊松回归非常相似。唯一的变化是负二项分布包括一个额外的参数，允许方差不同于均值。负二项分布的概率质量函数比泊松分布的更复杂:

$$ P\left(Y=y;\lambda, v\right)=\left(\begin{array}{c}y+v-1\ {}y\end{array}\right){\left(\frac{\lambda }{\lambda +v}\right)}y{\left(\frac{v}{v+\lambda}\right)}v $$

(4.13)

负二项分布的均值仍然是 λ 。然而，方差现在由$$ \lambda +\frac{\lambda²}{v}.{v}^{-1} $$给出，它被称为尺度或分散参数，有时也被称为辅助参数。随着 v 的增加，负二项分布变得越来越接近泊松，这样负二项 limv→∞就是泊松。

在许多应用案例中，负二项式是比泊松更好的选择，因为它只是稍微复杂一些，而且往往是更真实的数据匹配，因为泊松分布要求的均值和方差相同的假设经常被违反。

负二项式回归的解释或多或少与泊松回归相同，所以不需要额外的努力。

4.2 R示例

对于本章中的例子，我们将再次使用美国人的改变生活[45]研究数据。“简介”中标有“数据设置”的部分介绍了数据的读取和准备从技术上讲，数据具有采样权重，但为了简单起见，我们忽略这些权重。没有加权，分析仍然是正确的；它们只是不能反映抽样人口。

acl <- readRDS("advancedr_acl_data.RDS")

二元逻辑回归

要尝试二元逻辑回归模型，我们需要一个二元结果变量。我们通过将吸烟状态转换为当前吸烟者与非吸烟者(以前或从不吸烟)的二元关系来实现这一点。然后，我们使用带有family = binomialff()和 logit 链接的vglm()函数来运行我们的逻辑回归模型。与其他模型一样，summary()函数提供了模型和系数的摘要。

acl$CurSmoke <- as.integer(acl$Smoke_W1 == "(1) Cur Smok")

m.lr <- vglm(CurSmoke ~ Sex,
             family = binomialff(link = "logit"),
             data = acl, model = TRUE)
summary(m.lr)

##
## Call:
## vglm(formula = CurSmoke ~ Sex, family = binomialff(link = "logit"),
##     data = acl, model = TRUE)
##
##
## Pearson residuals:
##                Min   1Q Median  3Q Max
## logit(prob) -0.712 -0.603 -0.603 1.4 1.66
##
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)
## (Intercept)    -0.6788     0.0574  -11.82  < 2e-16 ***
## Sex(2) FEMALE  -0.3314     0.0746  -4.44   8.8e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Number of linear predictors: 1
##
## Name of linear predictor: logit(prob)
##
## Residual deviance: 4356 on 3615 degrees of freedom
##
## Log-likelihood: -2178 on 3615 degrees of freedom
##
## Number of iterations: 4
##
## No Hauck-Donner effect found in any of the estimates

在这个简单的例子中，有一个二元结果和一个二元预测值，我们可以很容易地使用频率直接计算优势比。在 2×2 频率表中，比值比是比值比，逻辑回归报告的系数是比值比的自然对数。具体来说，使用表 4-1 中所示的表格，

优势比定义为

$$ \frac{\frac{a}{c}}{\frac{b}{d}} $$

表 4-1

假设频率表

|

预言者

|

没有烟

|

烟

|
| --- | --- | --- |
| 男性的 | A | B |
| 女性的 | C | D |

对于我们的数据，实际频率表在表 4-2 中:

表 4-2

观察频率表

|   |

Zero

|

one

|
| --- | --- | --- |
| (1)男性 | Nine hundred and one | Four hundred and fifty-seven |
| (2)女性 | One thousand six hundred and fifty-six | Six hundred and three |

or.tab <- xtabs(~ Sex + CurSmoke, data = acl)
or.tab.res <- (or.tab[1,1]/or.tab[2,1])/(or.tab[1,2]/or.tab[2,2])
xtable(or.tab, caption = "Observed frequency table",
       label = "tglm2-obsfreq")

由此产生的优势比可以计算为

$$ \frac{\frac{901}{1656}}{\frac{457}{603}}=0.72 $$

几率的自然对数是-0.33，这与我们的逻辑回归模型的系数-0.33 相同。

理解比值比是如何计算的，有助于理解如何解释它们。2 x 2 频率表中比值比的简单公式

$$ \frac{\frac{a}{c}}{\frac{b}{d}} $$

也解释了逻辑回归的要求，即不能有任何零单元格。如果任何单元格为零，如果 c 、 b 或 d 为零，则结果是未定义的(除以零)，或者如果 a 为零，则结果正好为零，并且零的对数是负无穷大，这意味着逻辑回归的系数将是负无穷大，这也是有问题的。

尽管能够阅读方程来计算比值比或对数比值比，但对大多数人来说，这不是一个直观的值来解释。许多人发现概率尺度更容易解释。例如，我们可以找到男性和女性吸烟的概率(比例或百分比)。回到 4-1，男性吸烟概率的等式是

$$ \frac{b}{a+b} $$

女性吸烟概率的等式是

$$ \frac{d}{c+d} $$

我们还可以报告两种概率的差异，以量化男性和女性吸烟的概率有多大差异。获得概率的最简单和最通用的方法是基于数据和我们的模型来预测它们。我们可以使用predict()函数。为了在概率尺度上而不是在对数概率尺度上获得预测，我们使用可选参数type = "response"，以便将结果转换回原始尺度，如图 4-2 所示。

img/439480_1_En_4_Fig2_HTML.png

图 4-2

按性别显示吸烟概率的图表

preddat <- data.table(Sex = levels(acl$Sex))
preddat$yhat <- predict(m.lr, newdata = preddat,
        type = "response")

ggplot(preddat, aes(Sex, yhat)) +
  geom_bar(stat = "identity") +
  scale_y_continuous("Smoking Probability", labels = percent) +
  theme_tufte()

我们可以使用xtable函数制作一个漂亮的结果表，结果如表 4-3 所示。

表 4-3

逻辑回归模型的总结，包括系数、标准误差和 p 值

|   |

估计

|

Std。错误

|

z 值

|

公关（>|z|）

|
| --- | --- | --- | --- | --- |
| (截取) | −0.68 | Zero point zero six | −11.82 | Zero |
| 性别(2)女性 | −0.33 | Zero point zero seven | −4.44 | Zero |

xtable(coef(summary(m.lr)), digits = 2,
       caption = paste(
  "Summary of logistic regression model",
  "including coefficients, standard errors",
  "and p-values."), label = "tglm2-orsimple")

我们可以把这个结果解释为女性吸烟的几率比男性低 0.33 倍。我们也可以用比值比来解释这个结果。在这种情况下，我们可以说女性吸烟的几率是男性的 0.72 倍。

作为另一个例子，我们回到上一章所做的检查自我效能。一些潜在的混杂因素是性别、种族/民族和年龄。我们可以计算逆概率权重，并使用这些来调整我们的自我效能和吸烟模型。

## unadjusted model
m0.lr <- vglm(CurSmoke ~ SelfEfficacy_W1,
             family = binomialff(link = "logit"),
             data = acl, model = TRUE)

## estimate IPWs
w <- ipwpoint(
  exposure = SelfEfficacy_W1,
  family = "gaussian",
  numerator = ~ 1,
  denominator = ~ 1 + Sex + RaceEthnicity + AGE_W1,
  data = acl)

## adjusted logistic regression model
m1.lr <- vglm(CurSmoke ~ SelfEfficacy_W1,
             family = binomialff(link = "logit"),
             data = acl, model = TRUE,
             weights = winsorizor(w$ipw.weights, .01))

然后我们可以使用xtable()函数制作一个表格，比较原始模型和调整后模型的估计值，如表 4-4 所示。在这种情况下，在对性别、种族和年龄进行调整后，结果实际上稍微强一些。

表 4-4

未调整(原始)和调整回归模型的比较

|   |

类型

|

估计

|

Std。错误

|

z 值

|

公关（>|z|）

|
| --- | --- | --- | --- | --- | --- |
| one | 生的 | −0.88 | Zero point zero four | −24.13 | Zero |
| Two | 生的 | −0.06 | Zero point zero three | −1.71 | Zero point zero nine |
| three | 形容词 | −0.88 | Zero point zero four | −24.12 | Zero |
| four | 形容词 | −0.08 | Zero point zero three | −2.36 | Zero point zero two |

xtable(rbind(
  data.table(Type = "Raw", coef(summary(m0.lr))),
  data.table(Type = "Adj", coef(summary(m1.lr)))),
  digits = 2,
  caption = paste("Comparison of unadjusted (raw)",
    "and adjusted regression models"),
  label = "tglm2-lrcompare")

我们可以将结果解释为表明自我效能增加一个单位与吸烟的对数几率降低-0.08 相关。我们也可以用比值比来解释这个结果。在这种情况下，我们会说，自我效能感每增加一个单位，吸烟的几率就会增加 0.92 倍。

通常，因为比值比没有绝对的解释，所以用绝对概率来表示结果是有帮助的。我们可以再次依赖于predict()函数来生成特定的预测概率并绘制它们。为了做到这一点，我们可能会产生一系列自我效能值的预测。图 4-3 中的结果显示，随着自我效能感的提高，当前吸烟者的概率下降。在这种情况下，即使在概率尺度上，它也是近似线性的，因为没有概率接近 0 或 1。

img/439480_1_En_4_Fig3_HTML.png

图 4-3

根据自我效能显示吸烟概率的图表

preddat2 <- data.table(SelfEfficacy_W1 =
  seq(from = min(acl$SelfEfficacy_W1, na.rm = TRUE),
      to = max(acl$SelfEfficacy_W1, na.rm = TRUE),
      length.out = 1000))
preddat2$yhat <- predict(m1.lr, newdata = preddat2,
                        type = "response")

ggplot(preddat2, aes(SelfEfficacy_W1, yhat)) +
  geom_line() +
  scale_x_continuous("Self-Efficacy") +
  scale_y_continuous("Smoking Probability", label = percent) +
  theme_tufte() + coord_cartesian(ylim = c(.25, .40))

最后，有时人们会根据数据集计算概率的平均变化。因为在概率尺度上，结果不是线性的(尽管在图 4-3 中它们是近似线性的)，与自我效能感变化相关的概率变化取决于一个人的初始自我效能感水平。此外，如果模型中有其他变量，变化也将取决于这些其他变量。处理这个问题的一种方法是使用实际数据集生成预测概率，然后使用实际数据集，但稍微增加每个人的自我效能。在这种情况下，我们不必对人们的自我效能或其他预测分数做出任何不切实际的假设，我们使用他们的实际分数。然后我们可以找到每个人吸烟概率的预测变化，最后对所有这些进行平均，得到概率的平均边际变化。

## delta value for change in self efficacy
delta <- .01

## create a copy of the dataset
## where we increase everyone's self-efficacy by delta
aclalt <- copy(acl)
aclalt$SelfEfficacy_W1 <- aclalt$SelfEfficacy_W1 + delta

## calculate predicted probabilities
p1 <- predict(m1.lr, newdata = acl, type = "response")
p2 <- predict(m1.lr, newdata = aclalt, type = "response")

## calculate the average, marginal change in probabilities
## per unit change in self efficacy
## in percents and rounded
round(mean((p2 - p1) / delta) * 100, 1)

## [1] -1.7

代码显示，在这个样本中，平均边际效应是这样的，自我效能增加一个单位，预计会导致当前吸烟的机会降低 1.7%。

有序逻辑回归

当一个结果是离散的和分类的时，有序逻辑回归是有用的，但在分类有一个自然的顺序时也是有用的。在 ACL 数据集中，身体活动分为五类，从最不活跃到最活跃。

acl$PhysActCat_W2 <- factor(acl$PhysActCat_W2, ordered = TRUE)

## adjusted ordered logistic regression model
m0.or <- vglm(PhysActCat_W2 ~ SelfEfficacy_W1,
              family = propodds(),
              data = acl)

## estimate IPWs
w <- ipwpoint(
  exposure = SelfEfficacy_W1,
  family = "gaussian",
  numerator = ~ 1,
  denominator = ~ 1 + Sex + RaceEthnicity + AGE_W1,
  data = acl)

## adjusted ordered logistic regression model
m1.or <- vglm(PhysActCat_W2 ~ SelfEfficacy_W1,
             family = propodds(),
             data = acl, model = TRUE,
             weights = winsorizor(w$ipw.weights, .01))

在有序逻辑回归模型中，有多个截距，比结果中唯一级别的数量少一个。因为我们使用了比例优势模型，假设自我效能与结果的关联在所有水平上都是成比例的，所以自我效能只估计了一个系数。表 4-5 显示了原始模型、未调整模型和调整模型的比较。

表 4-5

未调整(原始)和调整有序逻辑回归模型的比较

|   |

类型

|

标签

|

估计

|

Std。错误

|

z 值

|

公关（>|z|）

|
| --- | --- | --- | --- | --- | --- | --- |
| one | 生的 | (截距):1 | Zero point eight | Zero point zero four | Nineteen point seven | Zero |
| Two | 生的 | (截距):2 | Zero point zero eight | Zero point zero four | Two point zero three | Zero point zero four |
| three | 生的 | (截距):3 | −1.14 | Zero point zero four | −26.11 | Zero |
| four | 生的 | (截距):4 | −1.88 | Zero point zero six | −34.20 | Zero |
| five | 生的 | 自我效能 _W1 | Zero point two two | Zero point zero three | Six point six | Zero |
| six | 形容词 | (截距):1 | Zero point seven nine | Zero point zero four | Nineteen point five six | Zero |
| seven | 形容词 | (截距):2 | Zero point zero seven | Zero point zero four | One point nine three | Zero point zero five |
| eight | 形容词 | (截距):3 | −1.14 | Zero point zero four | −26.15 | Zero |
| nine | 形容词 | (截距):4 | −1.89 | Zero point zero six | −34.22 | Zero |
| Ten | 形容词 | 自我效能 _W1 | Zero point one nine | Zero point zero three | Five point eight seven | Zero |

xtable(rbind(
  data.table(Type = "Raw",
             Labels = rownames(coef(summary(m0.or))),
             coef(summary(m0.or))),
  data.table(Type = "Adj",
             Labels = rownames(coef(summary(m1.or))),
             coef(summary(m1.or)))),
  digits = 2,
  caption = paste("Comparison of unadjusted (raw) and",
   "adjusted ordered logistic regression models"),
  label = "tglm2-orcompare")

与二元逻辑回归一样，绘制预测概率有助于提供更直接的数据解释视图。因为有多个类别，所以我们最终得到多个概率，然后使用melt()函数将它们合并成一个长数据集。结果图如图 4-4 所示。我们可以看到，随着自我效能的提高，成为前四类成员的概率有适度的增加，但被成为最低类成员的概率的急剧下降所抵消。

img/439480_1_En_4_Fig4_HTML.png

图 4-4

图表按自我效能显示不同身体活动类别的概率

preddat3 <- data.table(SelfEfficacy_W1 =
  seq(from = min(acl$SelfEfficacy_W1, na.rm = TRUE),
      to = max(acl$SelfEfficacy_W1, na.rm = TRUE),
      length.out = 1000))
preddat3 <- cbind(preddat3,
  predict(m1.or, newdata = preddat3,
          type = "response"))
preddat3 <- melt(preddat3, id.vars = "SelfEfficacy_W1")

ggplot(preddat3, aes(SelfEfficacy_W1, value,
                     colour = variable, linetype = variable)) +
  geom_line(size = 2) +
  scale_color_viridis(discrete = TRUE) +
  scale_x_continuous("Self-Efficacy") +
  scale_y_continuous("Activity Probability", label = percent) +
  coord_cartesian(ylim = c(0, .6), expand = FALSE) +
  theme_tufte() +
  theme(legend.position = c(.7, .8),
        legend.key.width = unit(2, "cm"))

与二元逻辑回归一样，我们可以计算自我效能单位变化的预测概率的平均边际变化。对于多个类别，我们得到每个类别的平均边际变化。

## delta value for change in self efficacy
delta <- .01

## create a copy of the dataset
## where we increase everyone's self-efficacy by delta
aclalt <- copy(acl)
aclalt$SelfEfficacy_W1 <- aclalt$SelfEfficacy_W1 + delta

## calculate predicted probabilities
p1 <- predict(m1.or, newdata = acl, type = "response")
p2 <- predict(m1.or, newdata = aclalt, type = "response")

## average marginal change in probability of
## membership in each category
round(colMeans((p2 - p1) / delta) * 100, 1)

## (1) Low_5th (2) 2Low_5th (3) 3Low_5th (4) 4Low_5th (5) Hi_5th
##        -4.2         -0.6          1.3          1.3        2.2

多项式逻辑回归

多项逻辑回归类似于有序逻辑回归，因为它适用于结果变量有两个以上的水平。然而，与假设比例优势的有序逻辑回归不同，多项逻辑回归模型不假设任何比例效应或水平排序。然而，这种灵活性是以大量参数和解释结果的复杂性增加为代价的。

为此，我们将查看 ACL 数据中的雇佣信息。ACL 根据员工的工作时数对他们进行编码。为简单起见，我们将把它归为一个单独的就业类别。

acl[, EmployG_W2 := as.character(Employment_W2)]
acl[EmployG_W2 %in% c(
  "(2) 2500+HRS", "(3) 15002499",
  "(4) 500-1499", "(5) 1-499HRS"),
  EmployG_W2 := "(2) EMPLOYED"]
acl[, EmployG_W2 := factor(EmployG_W2)]

重新编码后，得到的频率表如表 4-6 所示。

表 4-6

就业频率表

|   |

Var1

|

频率

|
| --- | --- | --- |
| one | (1)残疾人 | One hundred and twenty-two |
| Two | (2)就业 | One thousand four hundred and seventy-six |
| three | (6)退休 | Seven hundred and twenty-four |
| four | (7)失业 | Eighty-six |
| five | (8)保持 HS | Four hundred and fifty-nine |

xtable(as.data.frame(table(acl$EmployG_W2)),
       caption = "Frequency table of employment",
       label = "tglm2-freqtab")

接下来，我们可以像以前一样使用vglm()函数来估计多项式逻辑回归模型。唯一的变化是我们指定了参数family = multinomial()。正如我们前面的例子一样，我们可以估计未调整和调整后的模型，其中调整后的模型使用 IPWs 来解释性别、种族/民族和年龄的混杂。

## unadjusted multinomial logistic regression model

m0.mr <- vglm(EmployG_W2 ~ SelfEfficacy_W1,
              family = multinomial(),
              data = acl, model = TRUE)

## estimate IPWs
w <- ipwpoint(
  exposure = SelfEfficacy_W1,
  family = "gaussian",
  numerator = ~ 1,
  denominator = ~ 1 + Sex + RaceEthnicity + AGE_W1,
  data = acl)

## adjusted multinomial logistic regression model

m1.mr <- vglm(EmployG_W2 ~ SelfEfficacy_W1,

              family = multinomial(),
             data = acl, model = TRUE,
             weights = winsorizor(w$ipw.weights, .01))

接下来，我们可以制作一个表格，比较未调整(原始)模型和调整模型的估计值和系数。在多项逻辑回归中，没有假设预测因子的效果在不同的结果水平上是相等的。取而代之的是，k–1 个独立的参数被估计用于每个预测器，其中 k 是结果的唯一级别的数量。考虑多项逻辑回归的另一种方式是，如果选择一个水平的结果作为参考组，那么实际上运行一系列的k–1 二元逻辑回归。唯一真正的变化是，还有一个约束，即属于任何一个群体的概率总和必须为 1，这反映了人们只能属于一个群体，而每个人都必须属于某个群体的现实。来自vglm()的系数用数字标注，这些系数基于因子等级的顺序。结果如表 4-7 所示。

表 4-7

未调整(原始)和调整的多项式逻辑回归模型的比较

|   |

类型

|

标签

|

估计

|

Std。错误

|

z 值

|

Pr( > z)

|
| --- | --- | --- | --- | --- | --- | --- |
| one | 生的 | (截距):1 | −1.44 | Zero point one one | −12.98 | Zero |
| Two | 生的 | (截距):2 | One point one eight | Zero point zero five | Twenty-one point eight three | Zero |
| three | 生的 | (截距):3 | Zero point four six | Zero point zero six | Seven point seven three | Zero |
| four | 生的 | (截距):4 | −1.72 | Zero point one two | −14.00 | Zero |
| five | 生的 | 自我效能 _W1:1 | −0.33 | Zero point zero nine | −3.70 | Zero |
| six | 生的 | 自我效能 _W1:2 | Zero point two two | Zero point zero five | Four point two eight | Zero |
| seven | 生的 | 自我效能 _W1:3 | Zero point two three | Zero point zero six | Three point nine one | Zero |
| eight | 生的 | 自我效能 _W1:4 | −0.17 | Zero point one one | −1.66 | Zero point one |
| nine | 形容词 | (截距):1 | −1.44 | Zero point one one | −13.01 | Zero |
| Ten | 形容词 | (截距):2 | One point one seven | Zero point zero five | Twenty-one point eight | Zero |
| Eleven | 形容词 | (截距):3 | Zero point four six | Zero point zero six | Seven point six five | Zero |
| Twelve | 形容词 | (截距):4 | −1.73 | Zero point one two | −14.07 | Zero |
| Thirteen | 形容词 | 自我效能 _W1:1 | −0.40 | Zero point zero nine | −4.50 | Zero |
| Fourteen | 形容词 | 自我效能 _W1:2 | Zero point one five | Zero point zero five | Two point nine six | Zero |
| Fifteen | 形容词 | 自我效能 _W1:3 | Zero point one seven | Zero point zero six | Two point eight two | Zero |
| Sixteen | 形容词 | 自我效能 _W1:4 | −0.23 | Zero point one | −2.21 | Zero point zero three |

xtable(rbind(
  data.table(Type = "Raw",
             Labels = rownames(coef(summary(m0.mr))),
             coef(summary(m0.mr))),
  data.table(Type = "Adj",
             Labels = rownames(coef(summary(m1.mr))),
             coef(summary(m1.mr)))),
  digits = 2,
  caption = paste("Comparison of unadjusted (raw) and",
   "adjusted multinomial logistic regression models"),
  label = "tglm2-mrcompare")

我们可以画一个图来显示，在任何特定的就业类别中，预测的概率如何随着自我效能的函数而变化。结果如图 4-5 所示。这个数字告诉我们，随着自我效能的提高，人们不太可能残疾，更有可能就业或退休。它还强调了在这些模型中，随着时间的推移并不总是线性变化的。失能的可能性从自我效能的-4 到-2 迅速下降，然后在自我效能较高的时候下降得更慢。

img/439480_1_En_4_Fig5_HTML.png

图 4-5

图表按自我效能显示不同就业类别的概率

preddat4 <- data.table(SelfEfficacy_W1 =
  seq(from = min(acl$SelfEfficacy_W1, na.rm = TRUE),
      to = max(acl$SelfEfficacy_W1, na.rm = TRUE),
      length.out = 1000))
preddat4 <- cbind(preddat4,
  predict(m1.mr, newdata = preddat4,
          type = "response"))
preddat4 <- melt(preddat4, id.vars = "SelfEfficacy_W1")

ggplot(preddat4, aes(
  SelfEfficacy_W1, value,
  colour = variable, linetype = variable)) +
  geom_line(size = 2) +
  scale_color_viridis(discrete = TRUE) +
  scale_x_continuous("Self-Efficacy") +
  scale_y_continuous("Probability", label = percent) +
  coord_cartesian(ylim = c(0, .65), expand = FALSE) +
  theme_tufte() +
  theme(legend.position = c(.18, .82),
        legend.key.width = unit(2, "cm"))

最后，我们可以计算自我效能的单位变化的预测概率的平均边际变化。对于多个类别，我们得到每个类别的平均边际变化。这些结果表明，平均而言，自我效能感每增加一个单位，就业变化最大(平均增加 2.9%)，其次是残疾(平均减少 2.1%)，其他类别的变化较小。

## delta value for change in self efficacy
delta <- .01

## create a copy of the dataset
## where we increase everyone's self-efficacy by delta
aclalt <- copy(acl)

aclalt$SelfEfficacy_W1 <- aclalt$SelfEfficacy_W1 + delta

## calculate predicted probabilities
p1 <- predict(m1.mr, newdata = acl, type = "response")
p2 <- predict(m1.mr, newdata = aclalt, type = "response")

## average marginal change in probability of
## membership in each category
round(colMeans((p2 - p1) / delta) * 100, 1)

## (1) DISABLED (2) EMPLOYED (6) RETIRED (7) UNEMPLOY (8) KEEP HS
##         -2.1          2.9         1.7         -1.0        -1.5

泊松和负二项式回归

对于计数结果，我们可以使用泊松回归。在 ACL 数据中，一个变量是过去 12 个月中经历的慢性疾病的计数。这种变量可能很适合泊松回归。

我们可能做的第一件事是查看分布，并获得一些基本的描述性统计数据。对于计数结果，平均值和标准偏差可能没有意义，因此中值和四分位间距通常是更好的总结。我们可以使用egltable()函数快速汇总中位数和四分位间距，如下所示。

egltable(c("NChronic12_W1", "NChronic12_W2"),
         data = acl, parametric = FALSE)

##                    Mdn (IQR)
## 1: NChronic12_W1 1.00 (2.00)
## 2: NChronic12_W2 1.00 (2.00)

我们可以使用ggplot()功能来绘制每种慢性疾病的频率柱状图，以更广泛地了解每种波的分布情况。结果如图 4-6 所示。

img/439480_1_En_4_Fig6_HTML.png

图 4-6

图表显示了 ACL 数据中每个波的各种慢性疾病的频率

plot_grid(
  ggplot(acl, aes(NChronic12_W1)) +
  geom_bar() + theme_tufte(),
  ggplot(acl, aes(NChronic12_W2)) +
  geom_bar() + theme_tufte(),
  ncol = 1,
  labels = c("Wave 1", "Wave 2"),
  label_x = .8)

## Warning: Removed 750 rows containing non-finite values (stat_count).

接下来，我们可以使用vglm()函数来估计泊松回归模型。对于泊松回归，我们将族参数指定为family = poissonff()。对summary()的调用提供了模型结果和估计的快速总结。

## unadjusted poisson regression model

m0.pr <- vglm(NChronic12_W2 ~ SelfEfficacy_W1,
              family = poissonff(),
              data = acl, model = TRUE)

summary(m0.pr)

##
## Call:
## vglm(formula = NChronic12_W2 ~ SelfEfficacy_W1, family = poissonff(),
##     data = acl, model = TRUE)
##
##
## Pearson residuals:
##                Min    1Q Median    3Q  Max
## loge(lambda) -1.34 -1.01 -0.117 0.811 5.67
##
## Coefficients:
##                 Estimate Std. Error z value Pr(>|z|)
## (Intercept)       0.0954     0.0179    5.33  9.8e-08 ***
## SelfEfficacy_W1  -0.1347     0.0165   -8.16  3.3e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Number of linear predictors: 1
##
## Name of linear predictor: loge(lambda)
##
## Residual deviance: 4075 on 2865 degrees of freedom
##
## Log-likelihood: -4126 on 2865 degrees of freedom
##
## Number of iterations: 5
##
## No Hauck-Donner effect found in any of the estimates

但是，在继续之前，最好检查一下泊松回归模型的假设是否合理。也就是说，经常会出现过度离差，方差与均值相同的假设被违反。要检验这一假设，最简单的方法是也拟合负二项式回归模型，然后比较两个模型的相对拟合度，以确定负二项式是否提高了拟合度。

为了比较泊松和负二项式结果，我们首先需要拟合负二项式回归模型。唯一需要的改变是将family = poissonff()改为family = negbinomial()。然后，我们可以使用AIC()和BIC返回基于模型似然性的 Akaike 信息标准(AIC)和贝叶斯信息标准(BIC ),这些标准因参数数量而受到惩罚。较低的 AIC 和 BIC 分数表明更好的拟合，即使在考虑模型的复杂性之后。使用 AIC 和 BIC 比使用简单的模型拟合度量更可取，因为通常更复杂的模型提供更好的拟合。我们想知道的是，合身性的提高是否值得增加复杂性；因此，一些参数的惩罚项是需要的，AIC 和 BIC 都包括。

比较 AIC 和 BIC 发现，负二项式回归模型具有较低的 AIC 和较低的 BIC，表明对于这些数据，负二项式模型优于泊松模型。

## unadjusted negative binomial regression model
m0.nbr <- vglm(NChronic12_W2 ~ SelfEfficacy_W1,
              family = negbinomial(),
              data = acl, model = TRUE)

AIC(m0.nbr) - AIC(m0.pr)

## [1] -97

BIC(m0.nbr) - BIC(m0.pr)

## [1] -91

另一个有用的健全性检查是检查模型的模拟值是否与真实的观察数据一致。我们可以使用内置在VGAM包中的simulate()函数轻松实现这一点。它只需要一个模型，但我们也可以指定要生成的模拟的数量，我们只需要一个，并设置随机种子，这样结果是可重复的。接下来，我们使用真实结果分数、泊松模拟和负二项式模型模拟构建一个数据集。最后，我们将所有这些绘制在图 4-7 中。该图告诉我们，我们的两个模型都不能完美地再现真实的分布。然而，我们也可以看到，负二项式模型的模拟比泊松模型的模拟更接近事实。如图 4-7 所示的曲线图对于比较模型和评估模型是否是观测数据的合理近似非常有用。有时候“最好”的模型可能仍然是一个糟糕的模型，我们想要提前知道。

img/439480_1_En_4_Fig7_HTML.png

图 4-7

图表显示了基于真实数据、负二项式模型模拟和泊松回归模型模拟的各种慢性疾病的频率。

test.pr <- simulate(m0.pr, nsim = 1, seed = 1234)$sim_1
test.nbr <- simulate(m0.nbr, nsim = 1, seed = 1234)$sim_1
test.all <- data.table(
  Type = rep(c("Truth", "Poisson", "Negative\nBinomial"),
             times = c(
               nrow(model.frame(m0.pr)),
               length(test.pr),
               length(test.nbr))),
  Score = c(
    model.frame(m0.pr)$NChronic12_W2,
    test.pr,
    test.nbr))

ggplot(test.all, aes(Score, fill = Type)) +
  geom_bar(position = "dodge") +
  scale_fill_viridis(discrete = TRUE) +
  theme_tufte() +
  theme(legend.position = c(.8, .8))

在这一点上，通过比较 AIC 和 BIC 的得分，以及通过可视化泊松和负二项式回归模型的模拟值，很明显我们应该继续使用负二项式模型。如果我们想比较未调整和调整后的结果，我们可以计算 IPWs 并使用这些来估计调整后的模型，考虑性别、种族/民族和年龄的影响。

## estimate IPWs
w <- ipwpoint(
  exposure = SelfEfficacy_W1,
  family = "gaussian",
  numerator = ~ 1,
  denominator = ~ 1 + Sex + RaceEthnicity + AGE_W1,
  data = acl)

## adjusted negative binomial regression model
m1.nbr <- vglm(NChronic12_W2 ~ SelfEfficacy_W1,
              family = negbinomial(),
             data = acl, model = TRUE,
             weights = winsorizor(w$ipw.weights, .01))

接下来，我们可以制作一个表格，比较未调整(原始)模型和调整模型的估计值和系数。负二项式回归模型包括两个截距，一个是位置截距，称为 μ ，另一个是过度分散参数截距，称为大小参数。对于慢性病平均数的模型，只有第一个截距是相关的。结果如表 4-8 所示。

表 4-8

未经调整(原始)和经过调整的负二项式回归模型的比较

|   |

类型

|

标签

|

估计

|

Std。错误

|

z 值

|

公关（>|z|）

|
| --- | --- | --- | --- | --- | --- | --- |
| one | 生的 | (截距):1 | Zero point one | Zero point zero two | Four point six five | Zero |
| Two | 生的 | (截距):2 | One point two three | Zero point one two | Ten point four one | Zero |
| three | 生的 | 自我效能 _W1 | −0.13 | Zero point zero two | −6.98 | Zero |
| four | 形容词 | (截距):1 | Zero point one | Zero point zero two | Four point seven three | Zero |
| five | 形容词 | (截距):2 | One point two three | Zero point one two | Ten point four one | Zero |
| six | 形容词 | 自我效能 _W1 | −0.13 | Zero point zero two | −6.69 | Zero |

xtable(rbind(
  data.table(Type = "Raw",
             Labels = rownames(coef(summary(m0.nbr))),
             coef(summary(m0.nbr))),
  data.table(Type = "Adj",
             Labels = rownames(coef(summary(m1.nbr))),
             coef(summary(m1.nbr)))),
  digits = 2,
  caption = paste("Comparison of unadjusted (raw) and",
   "adjusted negative binomial regression models"),
  label = "tglm2-nbrcompare")

因为泊松和负二项式回归模型都使用自然对数关联函数，所以系数是对数尺度的。如果我们查看表 4-8 中未调整的结果，自我效能系数表明，自我效能增加一个单位与慢性疾病数量变化-0.13 个对数单位相关。或者，我们可以指数化该系数，在这种情况下，解释是自我效能增加一个单位与 0.87 倍的慢性疾病相关。

img/439480_1_En_4_Fig8_HTML.png

图 4-8

图表显示慢性疾病的预测数量作为自我效能的函数

如果我们愿意，我们也可以将预测的平均条件数绘制成自我效能的函数。当生成预测时，与逻辑回归一样，我们指定type = "response"来表示我们希望在原始尺度上进行预测，而不是在链接尺度上，这里是对数变换尺度。结果如图 4-8 所示。这个数字向我们表明，随着自我效能的提高，平均而言，人们预期会有更少的慢性疾病。

preddat5 <- data.table(SelfEfficacy_W1 =
  seq(from = min(acl$SelfEfficacy_W1, na.rm = TRUE),
      to = max(acl$SelfEfficacy_W1, na.rm = TRUE),
      length.out = 1000))
preddat5$yhat <- predict(m1.nbr, newdata = preddat5,
          type = "response")

ggplot(preddat5, aes(SelfEfficacy_W1, yhat)) +
  geom_line() +
  scale_x_continuous("Self-Efficacy") +
  scale_y_continuous("Expected Number Conditions") +
  theme_tufte()

4.3 案例研究:多项逻辑回归

默认情况下，在多项逻辑回归中，参数(例如，优势比)是相对于参照组计算的。虽然这足以说明模型，但在实践中应用多项逻辑回归来考虑所有(或至少关键的)组间成对比较是常见的[14，87]。例如，仅仅知道 B 组和 C 组与 A 组显著不同并不能告诉你 B 组和 C 组是否彼此不同。

同时评估几个预测因子的影响也很常见(例如[14，87])，这需要与评估单个预测因子稍有不同的处理。在本案例研究中，我们将构建一个从提问到最终呈现结果和解释的完整示例。

ACL 数据集包括第一波和第二波的吸烟状态。除了观察一波的吸烟状况，一个有趣的问题是谁随着时间的推移改变了(开始或停止)吸烟，以及哪些因素可能预测这种变化。首先，我们需要为吸烟创造一个新的变量，表明随着时间的变化或稳定。我们如下进行重新编码。结果频率表如表 4-9 所示。

表 4-9

一段时间内吸烟频率表

|   |

Var1

|

频率

|
| --- | --- | --- |
| one | 稳定从不吸烟 | One thousand two hundred and ninety-two |
| Two | 稳定的前吸烟者 | Seven hundred and five |
| three | 稳定电流吸烟者 | Six hundred and forty-one |
| four | 最近戒烟 | One hundred and sixty-seven |
| five | 新烟民 | Sixty-two |

acl[, Smoke_W2W1 := NA_character_]
acl[Smoke_W1 == "(3) Nevr Smo" &
    Smoke_W2 == "(3) W2 Never Smoker",
    Smoke_W2W1 := "Stable Never Smoker"]
acl[Smoke_W1 == "(2) Past Smo" &
    Smoke_W2 == "(2) W2 Former Smoker",
    Smoke_W2W1 := "Stable Former Smoker"]
acl[Smoke_W1 == "(1) Cur Smok" &
    Smoke_W2 == "(1) W2 Current Smoker",
    Smoke_W2W1 := "Stable Current Smoker"]
acl[Smoke_W1 %in% c("(2) Past Smo", "(3) Nevr Smo") &
    Smoke_W2 == "(1) W2 Current Smoker",
    Smoke_W2W1 := "New Smoker"]
acl[Smoke_W1 == "(1) Cur Smok" &
    Smoke_W2 == "(2) W2 Former Smoker",
    Smoke_W2W1 := "Recently Quit Smoker"]

acl[, Smoke_W2W1 := factor(Smoke_W2W1,
  levels = c("Stable Never Smoker", "Stable Former Smoker",
             "Stable Current Smoker", "Recently Quit Smoker",
             "New Smoker"))]

xtable(as.data.frame(table(acl$Smoke_W2W1)),
       caption = "Frequency table of smoking over time",
       label = "tglm2-freqtab-smoke")

在本章的前面，我们只关注了一个预测因子。在现实环境中，我们可能对几个潜在的预测因素感兴趣。一个有趣的问题是，随着时间的推移，社会人口统计学、心理社会或健康类型变量是否是吸烟的更好预测因素。我们将像之前一样使用vglm()函数和family = multinomial()来估计模型，以获得多项式结果。

acl[, SES := as.numeric(SESCategory)]

mr.ses <- vglm(Smoke_W2W1 ~ Sex + SES + AGE_W1,
  family = multinomial(),
  data = acl, model = TRUE)

mr.psych <- vglm(Smoke_W2W1 ~ SWL_W1 + InformalSI_W1 +
  FormalSI_W1 + SelfEfficacy_W1 + CESD11_W1,
  family = multinomial(),
  data = acl, model = TRUE)

mr.health <- vglm(Smoke_W2W1 ~ PhysActCat_W1 +
  BMI_W1 + NChronic12_W1,
  family = multinomial(),
  data = acl, model = TRUE)

我们可以比较每个模型的相对性能，使用 AIC 和 BIC 来惩罚复杂性，如表 4-10 所示。结果表明，社会人口因素是吸烟状况和随时间变化的最佳预测因素。

表 4-10

模型比较

|   |

模型

|

美国化学师学会(American Institute of Chemists)

|

比克

|
| --- | --- | --- | --- |
| one | 社会人口统计 | Seven thousand and fifty-six point three four | Seven thousand one hundred and fifty-one point seven two |
| Two | 社会心理的 | Seven thousand two hundred and three point seven three | Seven thousand three hundred and forty-six point seven nine |
| three | 健康 | Seven thousand three hundred and forty point five four | Seven thousand five hundred and seven point four five |

xtable(
  data.table(
  Model = c("Sociodemographics", "Psychosocial", "Health"),
  AIC = c(AIC(mr.ses), AIC(mr.psych), AIC(mr.health)),
  BIC = c(BIC(mr.ses), BIC(mr.psych), BIC(mr.health))),
  caption = "Model Comparisons",
  label = "tglm2-modelcomparisons")

我们可以使用summary()函数检查社会人口统计模型中的各个系数。然而，默认情况下，这些只是与参考水平的比较，默认情况下，VGAM包中的参考水平是最后一个水平，对我们来说是“新烟民”

summary(mr.ses)

##
## Call:
## vglm(formula = Smoke_W2W1 ~ Sex + SES + AGE_W1, family = multinomial(), ##     data = acl, model = TRUE)
##
##
## Pearson residuals:
##                      Min     1Q Median    3Q  Max
## log(mu[,1]/mu[,5]) -7.39 -0.744 -0.412 0.811 1.97
## log(mu[,2]/mu[,5]) -6.95 -0.441 -0.306 -0.186 2.98
## log(mu[,3]/mu[,5]) -6.33 -0.420 -0.289 -0.184 3.58
## log(mu[,4]/mu[,5]) -5.88 -0.202 -0.155 -0.118 4.82
##
## Coefficients:
##                 Estimate Std. Error z value Pr(>|z|)
## (Intercept):1   -0.79722    0.61458   -1.30  0.19457
## (Intercept):2   -1.16638    0.62965   -1.85  0.06397 .
## (Intercept):3    1.41356    0.61771    2.29  0.02212 *
## (Intercept):4   -1.18639    0.70648   -1.68  0.09309 .
## Sex(2) FEMALE:1  0.76073    0.27200    2.80  0.00516 **
## Sex(2) FEMALE:2 -0.46076    0.27545   -1.67  0.09437 .
## Sex(2) FEMALE:3 -0.04184    0.27459   -0.15  0.87888
## Sex(2) FEMALE:4  0.02589    0.30782    0.08  0.93297
## SES:1            0.51292    0.14821    3.46  0.00054 ***
## SES:2            0.50412    0.15079    3.34  0.00083 ***
## SES:3            0.20550    0.15032    1.37  0.17159
## SES:4            0.39726    0.16691    2.38  0.01731 *
## AGE_W1:1         0.04439    0.00858    5.18  2.3e-07 ***
## AGE_W1:2         0.05430    0.00877    6.19  5.9e-10 ***
## AGE_W1:3         0.01111    0.00871    1.28  0.20181
## AGE_W1:4         0.02732    0.00971    2.82  0.00487 **
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Number of linear predictors:  4
##
## Names of linear predictors:
## log(mu[,1]/mu[,5]), log(mu[,2]/mu[,5]), log(mu[,3]/mu[,5]), log(mu[,4]/mu[,5])
##
## Residual deviance: 7024 on 11452 degrees of freedom
##
## Log-likelihood: -3512 on 11452 degrees of freedom
##
## Number of iterations: 6
##
## No Hauck-Donner effect found in any of the estimates
##
## Reference group is level 5 of the response

在观察这些结果时，我们可以注意到的另一件事是，尽管它在统计上是显著的，但年龄的系数相当小，因为年龄的 1 岁变化是相对较小的变化。我们可以考虑将年龄转换成十岁，这样一个单位的差异更有意义。

acl[, AGE_W1 := AGE_W1 / 10]

如果我们想要明确地导出其他类别之间的对比，我们可以更改参考级别。这可以作为multinomial()函数的选项参数来完成。例如，设置refLevel = 1将使第一个类别成为参考，在我们的例子中是“稳定的从不吸烟者”我们也可以重新运行“稳定的前吸烟者”级别 2 和“稳定的当前吸烟者”级别 3。请注意，从数学上讲，所有这些模型都是相同的，不同的是结果中的默认比较。当重新运行时，我们不需要重新指定整个模型，我们可以使用update()功能简单地更新一个现有的模型。

mr.ses1 <- vglm(Smoke_W2W1 ~ Sex + SES + AGE_W1,
              family = multinomial(refLevel = 1),
              data = acl, model = TRUE)
mr.ses2 <- update(mr.ses1,
                  family = multinomial(refLevel = 2))
mr.ses3 <- update(mr.ses1,
                  family = multinomial(refLevel = 3))

接下来，通常报告比值比而不是对数比值，这是默认输出。报告置信区间也很常见，我们可以使用confint()函数来计算置信区间。我们可以通过组合系数和置信区间来创建一个结果表，在对它们求幂之后，我们就有了比值比和比值比的置信区间。

例如，如果我们观察参照组为“稳定的从不吸烟者”时AGE_W1:1的比值比，它告诉我们，年龄增加 10 岁，成为“稳定的前吸烟者”的几率是“稳定的从不吸烟者”的 1.1 倍

如果我们观察参照组是“稳定的从不吸烟者”时AGE_W1:2的比值比，它告诉我们，年龄增加 10 岁，成为“稳定的当前吸烟者”的几率是“稳定的从不吸烟者”的 0.72 倍

相比之下，如果我们观察参照组是“稳定的当前吸烟者”时AGE_W1:2的比值比，它告诉我们，年龄增加 10 岁，是“稳定的前吸烟者”成为“稳定的当前吸烟者”的 1.54 倍

最后，如果我们观察参照组是“稳定的当前吸烟者”时AGE_W1:3的比值比，它告诉我们年龄增加 10 岁与“最近戒烟者”是“稳定的当前吸烟者”的 1.18 倍相关

data.table(
  Ref = "Stable Never Smoker",
  Term = names(coef(mr.ses1)),
  OR = exp(coef(mr.ses1)),
  exp(confint(mr.ses1)))

##                    Ref            Term   OR 2.5 % 97.5 %
## 1: Stable Never Smoker   (Intercept):1 0.69  0.42   1.15
## 2: Stable Never Smoker   (Intercept):2 9.12  5.55  14.98
## 3: Stable Never Smoker   (Intercept):3 0.68  0.30   1.54
## 4: Stable Never Smoker   (Intercept):4 2.22  0.67   7.40
## 5: Stable Never Smoker Sex(2) FEMALE:1 0.29  0.24   0.36
## 6: Stable Never Smoker Sex(2) FEMALE:2 0.45  0.36   0.55
## 7: Stable Never Smoker Sex(2) FEMALE:3 0.48  0.34   0.67
## 8: Stable Never Smoker Sex(2) FEMALE:4 0.47  0.27   0.80
## 9: Stable Never Smoker           SES:1 0.99  0.90   1.10
## 10: Stable Never Smoker          SES:2 0.74  0.66   0.82
## 11: Stable Never Smoker          SES:3 0.89  0.75   1.06
## 12: Stable Never Smoker          SES:4 0.60  0.45   0.80
## 13: Stable Never Smoker       AGE_W1:1 1.10  1.04   1.17
## 14: Stable Never Smoker       AGE_W1:2 0.72  0.67   0.76
## 15: Stable Never Smoker       AGE_W1:3 0.84  0.76   0.94
## 16: Stable Never Smoker       AGE_W1:4 0.64  0.54   0.76

data.table(
  Ref = "Stable Current Smoker",
  Term = names(coef(mr.ses3)),
  OR = exp(coef(mr.ses3)),
  exp(confint(mr.ses3)))

##                      Ref            Term    OR  2.5 % 97.5 %
## 1: Stable Current Smoker   (Intercept):1 0.110  0.067  0.18
## 2: Stable Current Smoker   (Intercept):2 0.076  0.043  0.13
## 3: Stable Current Smoker   (Intercept):3 0.074  0.032  0.17
## 4: Stable Current Smoker   (Intercept):4 0.243  0.072  0.82
## 5: Stable Current Smoker Sex(2) FEMALE:1 2.231  1.811  2.75
## 6: Stable Current Smoker Sex(2) FEMALE:2 0.658  0.525  0.82
## 7: Stable Current Smoker Sex(2) FEMALE:3 1.070  0.752  1.52
## 8: Stable Current Smoker Sex(2) FEMALE:4 1.043  0.609  1.79
## 9: Stable Current Smoker           SES:1 1.360  1.221  1.51
## 10: Stable Current Smoker          SES:2 1.348  1.195  1.52
## 11: Stable Current Smoker          SES:3 1.211  1.006  1.46
## 12: Stable Current Smoker          SES:4 0.814  0.606  1.09
## 13: Stable Current Smoker       AGE_W1:1 1.395  1.309  1.49
## 14: Stable Current Smoker       AGE_W1:2 1.540  1.432  1.66
## 15: Stable Current Smoker       AGE_W1:3 1.176  1.054  1.31
## 16: Stable Current Smoker       AGE_W1:4 0.895  0.754  1.06

呈现结果的另一种方式是计算预测概率。然而，当有多个预测因子时，这就变得更复杂了，因为我们把其他预测因子放在哪里会影响结果。相反，对于多个预测因子，计算平均边际概率可能是最明智的，它将预测因子保持在它们的观察值，并且一次改变一个预测因子。

## delta value for change in age and SES
delta <- .01

## create a copy of the dataset
## where we increase everyone's age by delta
aclage <- copy(acl)
aclage[, AGE_W1 := AGE_W1 + delta]

## create a copy of the dataset
## where we increase everyone's SES by delta
aclses <- copy(acl)
aclses[, SES := SES + delta]

## create two copies of the data
## one where we set everyone to "female" and another to "male"
aclfemale <- copy(acl)
aclfemale[, Sex := factor("(2) FEMALE",
                          levels = levels(acl$Sex))]

aclmale <- copy(acl)
aclmale[, Sex := factor("(1) MALE",
                        levels = levels(acl$Sex))]

## calculate predicted probabilities
p.ref <- predict(mr.ses1, newdata = acl,
                 type = "response")
p.age <- predict(mr.ses1, newdata = aclage,
                 type = "response")
p.ses <- predict(mr.ses1, newdata = aclses,
                 type = "response")
p.female <- predict(mr.ses1, newdata = aclfemale,
                    type = "response")
p.male <- predict(mr.ses1, newdata = aclmale,
                    type = "response")

最后，我们可以计算预测概率的所有平均边际变化，并将它们放在一个表格中，以便于展示。最终结果如表 4-11 所示。这突出了性的强大影响，女性更有可能是稳定的从不吸烟者。我们还可以看到年龄较大和社会经济地位较高如何与成为稳定的当前吸烟者的概率降低约 5%相关联。

表 4-11

预测概率的平均边际变化

|   |

水平

|

年龄

|

(美)工程科学学会(Society of Engineering Science)

|

女性的

|
| --- | --- | --- | --- | --- |
| one | 稳定从不吸烟 | Two point eight three | Three point six six | Twenty-three point three four |
| Two | 稳定的前吸烟者 | Three point nine four | One point eight five | −16.96 |
| three | 稳定电流吸烟者 | −5.46 | −4.52 | −5.06 |
| four | 最近戒烟 | −0.55 | −0.12 | −0.93 |
| five | 新烟民 | −0.76 | −0.87 | −0.39 |

xtable(
data.table(
  Level = colnames(p.ref),
  Age = colMeans((p.age - p.ref) / delta) * 100,
  SES = colMeans((p.ses - p.ref) / delta) * 100,
  Female = colMeans(p.female - p.male) * 100),
  digits = 2,
  caption = "Average marginal change in predicted probability",
  label = "tglm2-margprobs")

虽然这需要一些额外的工作，但创建这样一个表来显示关键预测者的预测概率的平均边际变化，是一种非常有用的方式，可以用比优势比更直观的格式呈现结果。结合优势比和置信区间来估计不确定性，这提供了一个相对全面的结果介绍。

4.4 总结

本章展示了如何使用广义线性模型(GLMs)来构建离散结果的回归模型，包括二分结果、有序和无序分类结果，以及事件计数或数量结果。虽然这些结果是 GLMs 的一些最常见的用途，但 GLMs 可以适应许多其他类型的结果变量和许多其他分布，而不是这里介绍的分布。优秀的VGAM包支持常见和不常见的分布类型，因此如果您的数据看起来不是正态分布，也不是本章介绍的任何分布，很可能仍然可以使用不同分布的vglm()进行建模。关于VGAM软件包特性的更多细节和报道，请参阅其作者的书。

本章还介绍了一些工具和函数，通过生成预测或在更直接可解释的尺度(如概率)上获得效果来帮助我们解释 GLMs。虽然这样的代码严格来说不是 GLMs 的一部分，但它通常可以使结果更清晰，并帮助分析师和读者理解模型的含义。表 4-12 总结了引入的主要功能及其作用。

表 4-12

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| vglm() | 灵活的函数通过“系列”函数拟合多种类型的特定广义线性模型，提供数百种分布和链接函数组合。 |
| binomialff() | VGAM 家族函数将 GLMs 拟合到二项式、离散/分类结果(如吸烟或不吸烟)。 |
| propodds() | VGAM 家族函数将 GLMs 拟合到有序、离散/分类结果(例如，身体活动水平)。 |
| multinomial() | VGAM 家族函数将 GLMs 拟合到离散/分类结果，没有任何内在顺序的假设(例如，随着时间的推移，不同的预测因子可能对特定结果有或多或少的影响)。 |
| poissonff() | VGAM 家族函数将 GLMs 拟合到泊松结果(如慢性疾病)。 |
| negbinomial() | VGAM 家族函数拟合 GLMs 来计算方差超过均值的数据(广义泊松)。 |
| summary() | 打印对象概要的通用功能，包括vglm型号。 |
| coef() | 从模型中提取系数的通用函数，包括vglm模型。 |
| confint() | 计算模型置信区间的通用函数，包括vglm模型。 |
| update() | 更新现有模型，无需重写未更改的部分(例如，更改吸烟水平的默认参考)。 |
| ipwpoint() | 估计逆概率权重。 |
| xtable() | 将表格很好地导出到 LATEXor HTML。 |
| winsorizor() | 在指定的百分位裁剪异常值。 |
| predict() | 采用新的数据预测值，对其应用模型以估计最可能的响应结果，当与type = "response",一起使用时，转换回原始数据的规模。 |
| simulate() | 从模型中生成模拟数据，可用于比较vglm模型的模型和原始数据分布。 |
| AIC() | 返回基于 Akaike 信息标准的模型似然性(由参数计数决定)。 |
| BIC() | 返回基于贝叶斯信息标准的模型似然性(由参数计数决定)。 |

五、通用代数建模系统

广义可加模型(gam)是我们在前面章节中讨论的广义线性模型(glm)的扩展。像 GLMs 一样，gam 适应连续和离散的结果。然而，与完全参数模型的 glm 不同，gam 是半参数模型。GAMs 允许在结果和预测之间混合参数和非参数的关联。对于这一章，我们将主要依靠一个优秀的R包VGAM,，它为向量广义线性模型(VGLMs)和向量广义加法模型(VGAMs)提供了实用程序【125】。VGAMs 是比 gam 更灵活的一类模型，gam 可能有多个响应。然而，除了提供多参数的灵活性，VGAM包实现了超过 20 个链接函数，超过 50 个不同的模型/假设分布。在这一章中，我们将只触及VGAM包功能的表面，但是它的巨大灵活性意味着我们将不需要引入许多不同的包，也不需要许多不同的功能。如果你想更深入地了解 VGAMs，我们推荐一本由VGAM软件包[125]的作者写的优秀书籍。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(data.table)
library(ggplot2)
library(ggthemes)
library(scales)
library(viridis)
library(car)
library(mgcv)
library(VGAM)
library(ipw)
library(JWileymisc)
library(xtable)

options(
  width = 70,
  stringsAsFactors = FALSE,
  datatable.print.nrows = 20,
  datatable.print.topn = 3,
  digits = 2)

5.1 概念概述

广义加性模型(gam)是半参数加性模型，它使用非参数平滑函数放松了广义线性模型(GLMs)的线性假设[40]。非参数平滑函数的使用为 gam 提供了极大的灵活性，允许他们对预测值和结果之间的关联进行建模，即使函数形式未知，也不需要函数形式的(正确)规范。这种灵活性使得 gam 被多个学科采用，包括心理学[53]和医学[75]。

下一节介绍平滑样条的概念，这是 gam 的基础。如果你对R中关于现代游戏的优秀、全面的介绍感兴趣，请看【122】。要阅读关于 gam 的估计和推断的基础细节，请参见[57，121，123]。在本章的范围之外，gam 还被扩展到不仅模拟位置，还模拟分布的规模和形状。有关更多信息，请参见描述理论方面的优秀论文[78]和[88]，有关R中的实践方面，请参见GAMLSS包[88]。

平滑样条

gam 背后的一个关键概念是平滑样条，它允许 gam 模拟未知的函数形式。平滑样条部分依赖于多项式。可以证明，一个足够高阶的多项式可以逼近任何函数。然而，通常适当的近似可以采用非常高阶的多项式。虽然理论上是正确的，但实际上通常很难建立一个足够高阶的多项式来近似观察到的数据。特别是，通常情况下，多项式在任一极端都提供非常差的近似。图 5-1 显示了 ACL 数据中年龄与抑郁症状之间关系的单截距、线性、二次、三次、四次和十次多项式示例。与高阶多项式相比，低阶多项式在其极值处产生更适度的预测。即使是二次多项式也会对最年轻和最年长的参与者产生相对极端的预测(图 5-1 )。

img/439480_1_En_5_Fig1_HTML.png

图 5-1

显示仅截距(扁平线)和渐进高阶多项式的图形

acl <- readRDS("advancedr_acl_data.RDS")

ggplot(acl, aes(AGE_W1, CESD11_W1)) +
  stat_smooth(method = "lm", formula = y ˜ 1,
    colour = viridis(6)[1], linetype = 1, se = FALSE) +
  stat_smooth(method = "lm", formula = y ˜ x,
    colour = viridis(6)[2], linetype = 4, se = FALSE) +
  stat_smooth(method = "lm", formula = y ˜ poly(x, 2),
    colour = viridis(6)[3], linetype = 2, se = FALSE) +
  stat_smooth(method = "lm", formula = y ˜ poly(x, 3),
    colour = viridis(6)[4], linetype = 3, se = FALSE) +
  stat_smooth(method = "lm", formula = y ˜ poly(x, 4),
    colour = viridis(6)[5], linetype = 1, se = FALSE) +
  stat_smooth(method = "lm", formula = y ˜ poly(x, 10),
    colour = viridis(6)[6], linetype = 5, se = FALSE)

回归样条试图解决需要非常高阶的多项式来适应不同的函数形式的问题，以及在分布的下端和上端的极端预测的问题。样条最初并不用于统计学。样条最初指的是薄木片，弯曲后在节之间形成平滑的曲线。回归样条使用这种思想，因为它们本质上是分段模型，其中每一段都是多项式模型，并且它们在每一段的边缘(节点)处平滑连接。最简单的样条模型是阶跃函数。为了创建这个步骤，我们用边界点定义逻辑语句，在本例中:x>42和 x* ≤ 65 和 x > 65 和 x ≤ 96。为了在R中达到这些界限，我们使用了一个扩展的逻辑操作符:%gle%。左边应该是一些向量。右边应该是一个长度为 2 的向量，如果左边的数字或向量大于最小值并且小于或等于右边的最大值，它将返回TRUE或FALSE。下面的简单示例演示了这些功能。*

## > and <
1:5 %gl% c(2, 4)

## [1] FALSE FALSE  TRUE FALSE FALSE

## > and <=
1:5 %gle% c(2, 4)

## [1] FALSE FALSE  TRUE  TRUE FALSE

## >= and <
1:5 %gel% c(2, 4)

## [1] FALSE  TRUE  TRUE FALSE FALSE

## >= and <=
1:5 %gele% c(2, 4)

## [1] FALSE  TRUE  TRUE  TRUE FALSE

随着多项式次数的增加，每个结之间会出现线性和二次趋势。图 5-2 显示了两个内部节点和阶跃、线性、二次和三次多项式的结果。

img/439480_1_En_5_Fig2_HTML.png

图 5-2

显示阶跃函数样条、线性样条和二次样条的图形，所有样条都有两个内部节点

ggplot(acl, aes(AGE_W1, CESD11_W1)) +
  stat_smooth(method = "lm",
    formula = y ∼ 1 +
      ifelse(x %gle% c(42, 65), 1, 0) +
      ifelse(x %gle% c(65, 96), 1, 0),
    colour = viridis(6)[1], linetype = 1, se = FALSE) +
  stat_smooth(method = "lm",
    formula = y ∼ bs(x, df = 3, degree = 1L),
    colour = viridis(6)[2], linetype = 2, se = FALSE) +
  stat_smooth(method = "lm",
    formula = y ∼ bs(x, df = 4, degree = 2L),
    colour = viridis(6)[3], linetype = 3, se = FALSE) +
  stat_smooth(method = "lm",
    formula = y ∼ bs(x, df = 5, degree = 3L),
    colour = viridis(6)[4], linetype = 4, se = FALSE)

用于基础的 b 样条或基础样条试图通过在给定区域的基础函数中具有相对小的重叠来工作，这有助于它们在计算上更加稳定，并且有助于它们成为非常受欢迎的样条类型。以下代码通过显示具有固定结的 B 样条曲线的基函数来帮助可视化重叠。因为这些图是相同的，只是它们基于不同的数据集，并且具有不同的标题，我们没有重复代码来绘制这些图(这相当长)，而是将结果存储在一个R对象中，p1。然后我们使用%+%操作符用一个新的数据集替换原始数据。结果如图 5-3 所示。

img/439480_1_En_5_Fig3_HTML.png

图 5-3

显示 B 样条(基本样条)的图形

knots <- c(33, 42, 57, 65, 72)
x <- seq(from = min(acl$AGE_W1),
         to = max(acl$AGE_W1), by = .01)

p1 <- ggplot(melt(bs(x, degree = 1,
          knots = knots, intercept = TRUE)),
          aes(Var1, value, colour = factor(Var2))) +
  geom_line() +
  scale_color_viridis("Basis", discrete = TRUE) +
  theme_tufte()

plot_grid(
  p1 +
    ggtitle("5 Knots, Degree = 1"),
  p1 %+% melt(bs(x, degree = 2,
          knots = knots, intercept = TRUE)) +
    ggtitle("5 Knots, Degree = 2"),
  p1 %+% melt(bs(x, degree = 3,
          knots = knots, intercept = TRUE)) +
    ggtitle("5 Knots, Degree = 3"),
  p1 %+% melt(bs(x, degree = 4,
          knots = knots, intercept = TRUE)) +
    ggtitle("5 Knots, Degree = 4"),
  ncol = 2)

样条的延伸称为光滑样条。平滑样条的基本思想是，我们可以自动学习适当的平滑度，而不是直接指定节点和多项式次数，这需要事先知道需要什么。

自动学习适当平滑度的过程通常通过允许许多结和高度灵活性，并基于某些标准使用惩罚来降低灵活性(施加平滑度)来进行。平滑样条的一种常用方法是广义交叉验证(GCV)标准，或者，如果尺度是已知的(通常是未知的)，本质上是 Akaike 信息标准(AIC)的一种变体，称为无偏风险估计(UBRE)。关于 GCV 的详细情况，见[104]。最后一个选择是使用受限最大似然(REML ),其中平滑分量被视为随机效应，每个平滑有一个“方差分量”。

关于光滑样条的最后一点说明是，通常希望有一些方法来量化它们有多光滑或灵活。这样的值在描述上是有用的，并且在计算值(如模型 AIC)时也起作用，在这种情况下，可能性会受到复杂性的影响。一般的解决方案是使用“有效自由度”或 EDF。根据 EDF 的计算是否包括截距(常数)项，1 或 2 的 EDF 可能对应于线性函数。有时报告 EDF 计算截距，在这种情况下，EDF = 2 对应于线性趋势。然而，如果不计算截距，截距有时被称为有效非线性自由度(ENDF)，则 ENDF = 1 对应于线性趋势。随着 EDF/ENDF 的增加，拟合的灵活性同样增加。关于回归中样条和平滑的更多细节，见[39]。

出于本章的目的，对样条的粗略理解为广义可加模型(gam)提供了基础。gam 通过允许参数(例如，假设一个预测器的线性关联)和非参数(例如，对另一个使用平滑样条)的混合来扩展 GLMs。随着每一项的增加，gam 仍然是可加的，它们的一般形式如下:

$$ g(y)=\eta ={b}_0+{f}_1\left({x}_1\right)+{f}_2\left({x}_2\right)+\cdots +{f}_k\left({x}_k\right) $$

(5.1)

在这个参数化中，我们有熟悉的截距；然而，代替每个预测值的回归系数，我们有函数， f 1 等。这些函数可以预先指定，例如，iff1(x1)=b1∑x1，或者这些函数可以是平滑样条函数，其中平滑度是基于某种标准从数据中学习的，例如 GCV 或 UBRE。要成为 GAM，通常必须至少有一个平滑项。然而，像 GLMs 一样，gam 在理论上适应许多平滑项和许多常规参数项。混合光滑项和非光滑项的能力使 GAMs 成为一类高度灵活的模型，可以应用于许多环境。例如，平滑项可能具有实质性的意义，如按年龄划分的儿童体重增长图，其中增长通常是非线性的，但函数形式未知。然而，GAMs 也可以应用于其他情况。例如，一个实质性问题可能涉及一个已知或假定参数形式的变量的影响。然而，可能存在关于混杂的担忧，并且混杂的影响具有未知的函数形式。在这种情况下，混杂变量的任何参数本质上都是有害参数，因为唯一的目标是充分模拟它们的(未知)函数形式。没有兴趣真正理解它们的功能形式。在这种情况下,“假设检验”可能是针对具有预先指定的参数形式的变量，从而避免过度拟合的风险，但混杂变量可以使用平滑项稳健地捕获，因为关于它们的统计推断没有什么意义。

除了使用平滑样条，gam 本质上与其他 glm 功能相同。因此，分布假设和可以使用的不同分布族是可以比较的。诚然，由于确定样条适当平滑度的数据驱动性质，自由度和标准误差的计算往往是不同的，可能更接近 gam。下一节将介绍R中的 gam，包括如何估计它们，绘制结果，以及呈现或使用估计的模型。

5.2 游戏在R

高斯结果

基本游戏

gam 可以使用vgam()函数来拟合高斯结果，该函数的设置与我们在前面章节中熟悉的vglm()函数几乎相同。主要区别是平滑样条的使用，使用另一个函数s()将平滑样条添加到模型中。s()函数采用参数df,，该参数控制变量的平滑样条的最大灵活性。下面的例子用两个预测值拟合 GAM:性别和年龄的平滑样条。summary()函数主要提供平滑项的汇总，p 值测试参数是否与线性趋势有显著差异。请注意，uninormal()系列可以模拟正态分布的位置和比例，尽管默认情况下所有预测值都只针对比例。因此有两个截距，一个是位置截距，GLMs 和 gam 共有的“通常”截距，另一个是分布的标度，它基于方差的自然对数。其原因是VGAM软件包正准备允许预测分布的位置和规模，尽管“经典”的焦点只是预测分布的位置。

mgam <- vgam(CESD11_W1 ∼ Sex + s(AGE_W1, df = 3), data = acl,
        family = uninormal(), model = TRUE)

summary(mgam)

##
## Call:
## vgam(formula = CESD11_W1 ∼ Sex + s(AGE_W1, df = 3), family = uninormal(),
##    data = acl, model = TRUE)
##
##
## Number of linear predictors:     2
##
## Names of linear predictors: mean, loge(sd)
##
## Dispersion Parameter for uninormal family:   1
##
## Log-likelihood: -5290 on 7228 degrees of freedom
##
## Number of iterations:  4
##
## DF for Terms and Approximate Chi-squares for Nonparametric Effects
##
##                   Df Npar Df Npar Chisq P(Chi)
## (Intercept):1      1
## (Intercept):2      1
## Sex                1
## s(AGE_W1, df = 3)  1       2         20      0

使用coef()功能可以查看 GAM 的系数。然而，平滑项的系数不容易解释。但是参数项的系数，在这个模型中只有性别，就像常规的 GLMs 一样可以解释，除了性别的影响控制着年龄的平滑样条函数，而不仅仅是年龄的线性趋势。

coef(mgam)

##     (Intercept):1    (Intercept):2    Sex(2) FEMALE
##            0.2158           0.0435           0.2393
## s(AGE_W1, df = 3)
##           -0.0047

我们可以使用car包中的linearHypothesis()函数得到参数系数的假设检验。

## test parametric coefficient for sex
linearHypothesis(mgam, "Sex(2) FEMALE",
  coef. = coef(mgam), vcov = vcov(mgam))

## Linear hypothesis test
##
## Hypothesis:
## Sex(2) FEMALE = 0
##
## Model 1: restricted model
## Model 2: CESD11_W1 ∼ Sex + s(AGE_W1, df = 3)
##
## Note: Coefficient covariance matrix supplied.
##
##   Res.Df Df Chisq Pr(>Chisq)
## 1   7229
## 2   7228  1  44.1    3.2e-11 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1

可以使用linearHypothesis()来测试参数系数的更复杂的线性假设。例如，我们可以测试截距和性别系数是否同时等于零。

## test parametric coefficient for
## intercept and sex simultaneously
linearHypothesis(mgam,
  c("(Intercept):1", "Sex(2) FEMALE"),
  coef. = coef(mgam), vcov = vcov(mgam))

## Linear hypothesis test
##
## Hypothesis:
## (Intercept):1 = 0
## Sex(2) FEMALE = 0
##
## Model 1: restricted model
## Model 2: CESD11_W1 ∼ Sex + s(AGE_W1, df = 3)
##
## Note: Coefficient covariance matrix supplied.
##
##   Res.Df Df Chisq Pr(>Chisq)
## 1   7230
## 2   7228  2  79.1     <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1

我们可以基于 2 se 以 95%的置信区间来可视化结果。这些应被视为大约 95%的置信区间，因为自由度不是直接估计的，因此依赖于中心极限定理，并且由于平滑样条，标准误差(se)的估计是近似的。使用包含VGAM对象方法的plot()函数可以很容易地绘制图形。结果如图 5-4 所示，显示了性别和年龄平滑项的参数效应。默认情况下会添加地毯图，这对于性别来说不是很有用，但有助于显示年龄数据的分布。颜色来自viridis()调色板。

img/439480_1_En_5_Fig4_HTML.png

图 5-4

将性别作为参数项，年龄作为平滑样条的广义加性模型的模型结果图

par(mfrow = c(1, 2))
plot(mgam, se = TRUE,
     lcol = viridis(4)[1], scol = viridis(4)[2])

将我们 GAM 的结果与更熟悉的替代方案进行比较会有所帮助。为此，我们将安装两个常规 glm。第一个包括年龄的线性项，第二个包括年龄的二次项，使用poly()函数生成二次多项式。

mlin <- vglm(CESD11_W1 ∼ Sex + AGE_W1, data = acl,
        family = uninormal(), model = TRUE)
mquad <- vglm(CESD11_W1 ∼ Sex + poly(AGE_W1, 2), data = acl,
        family = uninormal(), model = TRUE)

为了将这些 glm 与我们的 GAM 进行比较，我们可以制作一个由两个图组成的面板，如图 5-5 所示。深紫色是 GAM 拟合，左边是叠加的线性拟合，右边是施加的二次多项式拟合。显然，线性拟合与 GAM 拟合有很大不同。二次拟合(在图 5-5 的右边板上)相对接近 GAM，除了在最右边的尾部。GAM 在尾部开始变平，而二次趋势继续快速增长。

img/439480_1_En_5_Fig5_HTML.png

图 5-5

双面板图显示了根据广义相加模型预测的抑郁症症状水平，左侧为线性拟合，右侧为二次拟合。

par(mfrow = c(1, 2))
plot(mgam, se = TRUE, which.term = 2,
     lcol = viridis(4)[1], scol = viridis(4)[1])
plot(as(mlin, "vgam"), se = TRUE, which.term = 2,
     lcol = viridis(4)[2], scol = viridis(4)[2],
     overlay = TRUE, add = TRUE)

plot(mgam, se = TRUE, which.term = 2,
     lcol = viridis(4)[1], scol = viridis(4)[1])
plot(as(mquad, "vgam"), se = TRUE, which.term = 2,
     lcol = viridis(4)[3], scol = viridis(4)[3],
     overlay = TRUE, add = TRUE)

有时，gam 可用于选择更简单的趋势函数。例如，我们可以根据图表决定年龄的二次多项式就足够了，并切换到多项式模型。然而，如果结果不能被任何简单的多项式很好地近似，我们可能希望保持 GAM 作为我们的最终模型。在这种情况下，从游戏中得到一些推论是有帮助的。

首先，让我们看看另一个游戏玩家的例子。在这里，我们从性别预测第二波的抑郁症状，第一波的抑郁症状的平滑样条和第一波的年龄的平滑样条。在这个新模型中，我们看到summary()表明年龄的非线性在统计上不显著。

mgam2 <- vgam(CESD11_W2 ∼ Sex +
               s(CESD11_W1, df = 3) +
               s(AGE_W1, df = 3), data = acl,
       family = uninormal(), model = TRUE)

summary(mgam2)

##
## Call:
## vgam(formula = CESD11_W2 ∼ Sex + s(CESD11_W1, df = 3) + s(AGE_W1,
##     df = 3), family = uninormal(), data = acl, model = TRUE)
##
##
## Number of linear predictors:    2
##
## Names of linear predictors: mean, loge(sd)
##
## Dispersion Parameter for uninormal family:  1
##
## Log-likelihood: -3657 on 5725 degrees of freedom
##
## Number of iterations:  5
##
## DF for Terms and Approximate Chi-squares for Nonparametric Effects
##
##                      Df Npar Df Npar Chisq P(Chi)
## (Intercept):1         1
## (Intercept):2         1
## Sex                   1
## s(CESD11_W1, df = 3)  1       2         31    0.0
## s(AGE_W1, df = 3)     1       2          4    0.1

如果其中一个平滑样条与一个线性项没有明显的不同，我们可以考虑回退到该项的线性拟合，如下面的代码所示。

mgam3 <- vgam(CESD11_W2 ∼ Sex +
               s(CESD11_W1, df = 3) +
               AGE_W1, data = acl,
        family = uninormal(), model = TRUE)

summary(mgam3)

##
## Call:
## vgam(formula = CESD11_W2 ∼ Sex + s(CESD11_W1, df = 3) + AGE_W1,
##     family = uninormal(), data = acl, model = TRUE)
##
##
## Number of linear predictors:    2
##
## Names of linear predictors: mean, loge(sd)
##
## Dispersion Parameter for uninormal family:  1
##
## Log-likelihood: -3659 on 5727 degrees of freedom
##
## Number of iterations:  5
##
## DF for Terms and Approximate Chi-squares for Nonparametric Effects
##
##                      Df Npar Df Npar Chisq P(Chi)
## (Intercept):1         1
## (Intercept):2         1
## Sex                   1
## s(CESD11_W1, df = 3)  1       2         31  2e-07
## AGE_W1                1

我们已经看到了如何使用linearHypothesis()函数测试参数项的统计显著性。现在我们可以用它来测试年龄和性别。我们可以使用names()函数和coef()函数来获取每个参数的名称，以便通过测试。

names(coef(mgam3))

## [1] "(Intercept):1"      "(Intercept):2"
## [3] "Sex(2) FEMALE"      "s(CESD11_W1, df = 3)"
## [5] "AGE_W1"

linearHypothesis(mgam3,
  "Sex(2) FEMALE",
  coef. = coef(mgam3), vcov = vcov(mgam3))

## Linear hypothesis test
##
## Hypothesis:
## Sex(2) FEMALE = 0
##
## Model 1: restricted model
## Model 2: CESD11_W2 ∼ Sex + s(CESD11_W1, df = 3) + AGE_W1
##
## Note: Coefficient covariance matrix supplied.
##
##   Res.Df Df Chisq Pr(>Chisq)
## 1   5728
## 2   5727  1  4.09      0.043 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1

linearHypothesis(mgam3,
  "AGE_W1",
  coef. = coef(mgam3), vcov = vcov(mgam3))

## Linear hypothesis test
##
## Hypothesis:
## AGE_W1 = 0
##
## Model 1: restricted model
## Model 2: CESD11_W2 ∼ Sex + s(CESD11_W1, df = 3) + AGE_W1
##
## Note: Coefficient covariance matrix supplied.
##
##   Res.Df Df Chisq Pr(>Chisq)
## 1   5728
## 2   5727  1  3.56      0.059 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1

我们在图 5-6 中展示了最终模型的结果。这里我们可以看到，对于在第一波低于约 2 的抑郁症状水平，较高的抑郁症状预示着在第二波较高的抑郁症状。然而，对于高于约 2 分的抑郁症状，没有太多的关联，这由预测值的变平来证明。

par(mfrow = c(2, 2))
plot(mgam3, se = TRUE,
     lcol = viridis(4)[1],
     scol = viridis(4)[2])

在其他情况下，我们可以为游戏生成预测。因为不可能用语言来描述平滑样条，所以如果对平滑样条的结果感兴趣，那么用图形来表示 gam 是标准的。首先，我们为预测建立一个新的数据集。我们得到了因子变量的所有级别，Sex，第一波的抑郁症状序列，从最低分到最高分，具有 1000 个点的均匀间隔网格，以及第一波的年龄的五个数字摘要。在R中，预测和往常一样使用predict()函数，该函数为VGAM包中的模型准备了方法。

img/439480_1_En_5_Fig6_HTML.png

图 5-6

将性别和年龄作为参数项，将第一波抑郁症状作为平滑样条的广义加性模型的模型结果图

## generate new data for prediction
## use the whole range of sex and depression symptoms
## and a five number summary of age
## (min, 25th 50th 75th percentiles and max)
newdat <- as.data.table(expand.grid(
  Sex = levels(acl$Sex),
  CESD11_W1 = seq(
    from = min(acl$CESD11_W1, na.rm=TRUE),
    to = max(acl$CESD11_W1, na.rm=TRUE),
    length.out = 1000),
  AGE_W1 = fivenum(acl$AGE_W1)))

newdat$yhat <- predict(mgam3, newdata = newdat)

## Warning in `<-.data.table`(x, j = name, value = value): 2 column matrix RHS of := will be treated

## Warning in `[<-.data.table`(x, j = name, value = value): Supplied 20000 items to be assigned to 10000

一旦我们有了一个预测数据集，我们就可以使用ggplot()来制作最终的图表。结果如图 [5-7 所示。该图清楚地强调了后续抑郁症状的最强预测因素是先前的抑郁症状。虽然不同年龄和性别之间有一些微小的差异，但相比之下这些都是小巫见大巫。

img/439480_1_En_5_Fig7_HTML.png

图 5-7

预测不同年龄和性别的第一波抑郁症状水平的第二波抑郁症状

ggplot(newdat,
       aes(CESD11_W1, yhat,
           colour = factor(AGE_W1),
           linetype = factor(AGE_W1))) +
  geom_line() +
  scale_color_viridis("Age", discrete = TRUE) +
  scale_linetype_discrete("Age") +
  facet_wrap(∼ Sex) +
  theme(legend.position = c(.75, .2),
        legend.key.width = unit(1.5, "cm")) +
  xlab("Depression Symptoms (Wave 1)") +
  ylab("Depression Symptoms (Wave 2)")

最后，尽管VGAM包具有广泛的功能，并且是矢量游戏的唯一选择之一，但对于我们在这里展示的单结果游戏，还有一些游戏的特性尚未实现。GAMs 理论和实现的领导者之一 Simon Wood 编写的mgcv包具有一些有用的附加特性。我们将在这里简要概述一下mgcv包的使用，但是更多的细节可以在西蒙·伍德的关于 GAMs 的书中找到。

在我们使用mgcv包之前，我们必须处理一些冲突。具体来说，VGAM和mgcv包都实现了一个名为s()的平滑样条函数，但它们不是同一个函数。加载了两个包后，最后加载的包“屏蔽”了前面包的功能，这意味着当我们在R控制台中键入s()时，我们会从最后加载的包中得到结果，而不一定是我们想要的包。在我们的例子中，解决这个问题最简单的方法是分离不想要的包，并确保加载了想要的包。我们使用下面的代码来实现。请注意，运行后，您将无法使用vgam()功能，直到您重新加载VGAM包。

detach("package:VGAM")
library(mgcv)

现在我们可以使用mgcv包中的gam()函数来拟合一个 GAM。我们再次使用s()函数表示平滑样条，但是注意对于mgcv，控制最大灵活性的参数是k而不是df。适当的家庭功能还有gaussian()。尽管代码的其余部分可能看起来相似，但在默认情况下使用的平滑样条和估计类型方面还是有一些差异。具体来说，mgcv软件包默认使用薄板回归样条和 GCV 准则来学习适当的灵活性程度。

mgam4 <- gam(CESD11_W2 ∼ Sex +
               s(CESD11_W1, k = 3) +
               s(AGE_W1, k = 3), data = acl,
        family = gaussian())

使用gam()功能的一个好处是，默认摘要包括各种有用的信息。具体来说，它自动计算参数项的统计推断，并为平滑项提供近似的显著性测试。请注意，与测试平滑项是否显著不同于线性趋势的vgam()不同，gam()测试平滑项的总体显著性(即，它包括线性趋势以及任何非线性)。

summary(mgam4)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ∼ Sex + s(CESD11_W1, k = 3) + s(AGE_W1, k = 3)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0202     0.0272   -0.74    0.457
## Sex(2) FEMALE   0.0681     0.0342    1.99    0.046 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##               edf Ref.df      F p-value
## s(CESD11_W1) 1.95   2.00 514.03  <2e-16 ***
## s(AGE_W1)    1.63   1.86   2.04   0.085 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.271   Deviance explained = 27.2%
## GCV = 0.75609  Scale est. = 0.75461   n = 2867

还因为mgcv提供了对估计自由度的快速访问，更容易检查我们是否应该允许更大的灵活性。例如，如果我们将k = 3增加到k = 4并改装模型，我们可以看到，估计的自由度随年龄变化很小，但随抑郁症状增加。

mgam5 <- gam(CESD11_W2 ∼ Sex +
               s(CESD11_W1, k = 4) +
               s(AGE_W1, k = 4), data = acl,
        family = gaussian())

summary(mgam5)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ∼ Sex + s(CESD11_W1, k = 4) + s(AGE_W1, k = 4)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0207     0.0272   -0.76    0.447
## Sex(2) FEMALE   0.0688     0.0342    2.01    0.044 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##               edf Ref.df      F p-value
## s(CESD11_W1) 2.86   2.99 344.7   <2e-16 ***
## s(AGE_W1)    1.78   2.16   2.4    0.076 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.272   Deviance explained = 27.3%
## GCV = 0.75508  Scale est. = 0.75333   n = 2867

我们在图 5-8 中并排绘制了这两个模型。结果显示，在第一波中，抑郁症状的趋势有细微的差异，在我们设定的 GAM 中有更明显的平台期k = 4.

img/439480_1_En_5_Fig8_HTML.png

图 5-8

改变光滑样条最大柔度的两个广义加法模型的模型结果图

par(mfrow = c(2, 2))
plot(mgam4, se = TRUE, scale = 0, main = "k = 3")
plot(mgam5, se = TRUE, scale = 0, main = "k = 4")

互动游戏

另一个在mgcv包中可用但在VGAM包中还不可用的特性是包含交互平滑样条的能力。例如，假设我们认为抑郁症状或年龄的影响可能因性别而异。我们可以相对容易地实现这一点，方法是将参数by = Sex添加到我们认为可能因性别而异的s()函数中。这一总结并没有显示出很大的差异，尽管在性别上有一些差异，但看起来相似的曲线证明了这一点(图 5-9 )。

img/439480_1_En_5_Fig9_HTML.png

图 5-9

允许样条随性别变化的广义可加模型的模型结果图

mgam6 <- gam(CESD11_W2 ∼ Sex +
              s(CESD11_W1, k = 4, by = Sex) +
              s(AGE_W1, k = 4, by = Sex),
             data = acl,
        family = gaussian())

summary(mgam6)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ∼ Sex + s(CESD11_W1, k = 4, by = Sex) + s(AGE_W1, k = 4,
##     by = Sex)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0218     0.0276   -0.79    0.428
## Sex(2) FEMALE   0.0693     0.0343    2.02    0.044 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##                             edf Ref.df      F p-value
## s(CESD11_W1):Sex(1) MALE   2.52   2.83 119.68  <2e-16 ***
## s(CESD11_W1):Sex(2) FEMALE 2.76   2.96 234.18  <2e-16 ***
## s(AGE_W1):Sex(1) MALE      1.80   2.17   1.58     0.2
## s(AGE_W1):Sex(2) FEMALE    1.00   1.00   2.68     0.1
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.272   Deviance explained = 27.4%
## GCV = 0.75643  Scale est. = 0.75377   n = 2867

par(mfrow = c(2, 2))
plot(mgam6, ask = FALSE, scale = 0)

我们可以使用 Akaike 信息标准或贝叶斯信息标准作为比较两个模型之间结果的快速方法。在这种情况下，两个指数都指向没有性别交互的模型，作为平衡适合度和节俭度的高级模型。

AIC(mgam5, mgam6)

##         df   AIC
## mgam5  7.6  7333
## mgam6 11.1  7338

BIC(mgam5, mgam6)

##         df   BIC
## mgam5  7.6  7378
## mgam6 11.1  7404

两个连续变量相互作用的光滑样条变得更加复杂。然而，mgcv包允许通过张量积平滑。张量积平滑背后的细节不容易理解，但大致可以认为是取每个变量，通过纽结将其分离并拟合多项式(就像常规样条一样)。这些被假定为乘积项，尽管在整个数据范围内这可能是不现实的，但希望它提供一个合理的近似值，因为可能的空间被两个变量上的结所分解。从实际角度来看，想象一个未知的三维表面，其中深度和宽度由两个预测变量定义，高度是结果的级别。然后想象在顶部覆盖一层厚布。厚重的材料会提供一定程度的“光滑度”，但形状会随着你向任何方向移动而灵活变化，如果不指明另一个变量的水平，你就不能谈论一个变量的“效果”。另一个实际注意事项是张量积平滑对计算要求更高，因此拟合速度较慢。

在下面的代码中，我们拟合了一个 GAM，其中性别作为参数项，张量积在第一波的抑郁症状和自尊之间平滑，预测第二波的抑郁症状。

mgam7 <- gam(CESD11_W2 ∼ Sex +
               te(CESD11_W1, SelfEsteem_W1, k = 4ˆ2),
             data = acl,
        family = gaussian())

summary(mgam7)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ∼ Sex + te(CESD11_W1, SelfEsteem_W1, k = 4ˆ2)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0226     0.0268   -0.84    0.400
## Sex(2) FEMALE   0.0718     0.0337    2.13    0.033 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##                              edf Ref.df    F p-value
## te(CESD11_W1,SelfEsteem_W1) 12.1   14.5 77.4  <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.286   Deviance explained = 28.9%
## GCV = 0.74276  Scale est. = 0.7391    n = 2867

总结表明，总体而言，张量积平滑在统计上是显著的，尽管它没有说明哪个变量的贡献最大。这种交互的另一个挑战是它们更加难以可视化。现在我们使用vis.gam()功能，它可以制作 3D 透视图或等高线图。首先，我们将在一组图表中从几个不同的角度绘制 3D 透视图。我们还缩小了默认的利润率。结果如图 5-10 所示。

img/439480_1_En_5_Fig10_HTML.png

图 5-10

3D 透视图显示了第 1 波抑郁症状和自尊之间的张量积平滑结果，预测了第 2 波的抑郁

par(mfrow = c(2, 2), mar = c(.1, .1, .1, .1))
vis.gam(mgam7,
  view = c("CESD11_W1", "SelfEsteem_W1"),
  theta = 210, phi = 40,
  color = "topo",
  plot.type = "persp")
vis.gam(mgam7,
  view = c("CESD11_W1", "SelfEsteem_W1"),
  theta = 150, phi = 40,
  color = "topo",
  plot.type = "persp")
vis.gam(mgam7,
  view = c("CESD11_W1", "SelfEsteem_W1"),
  theta = 60, phi = 40,
  color = "topo",
  plot.type = "persp")
vis.gam(mgam7,
  view = c("CESD11_W1", "SelfEsteem_W1"),
  theta = 10, phi = 40,
  color = "topo",
  plot.type = "persp")

在二维空间中更容易可视化的图是等高线图。等值线图在 x 轴和 y 轴上显示预测值，但使用线条和颜色显示第三维。每条线或等高线代表相同的预测值，曲线展示了如何通过改变两个预测值的组合来实现相同的预测值。图 5-11 中显示了一个等高线图示例。

img/439480_1_En_5_Fig11_HTML.png

图 5-11

显示在第 1 波抑郁症状和自尊之间的张量积平滑结果的等高线图预测在第 2 波的抑郁。

par(mfrow = c(1, 1), mar = c(5.1, 4.1, 4.1, 2.1))
vis.gam(mgam7,
  view = c("CESD11_W1", "SelfEsteem_W1"),
  color = "topo",
  plot.type = "contour")

如果我们想要尝试方差的粗略分解，我们可以使用张量积相互作用，使用ti()函数。结果显示在下面的代码中，它们表明抑郁症状和自尊之间的相互作用并没有在抑郁症状和自尊的平滑项之间提供多少附加值。

mgam8 <- gam(CESD11_W2 ∼ Sex +
               ti(CESD11_W1, k = 4) +
               ti(SelfEsteem_W1, k = 4) +
               ti(CESD11_W1, SelfEsteem_W1, k = 4ˆ2),
             data = acl,
        family = gaussian())

summary(mgam8)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ∼ Sex + ti(CESD11_W1, k = 4) + ti(SelfEsteem_W1, k = 4) +
##     ti(CESD11_W1, SelfEsteem_W1, k = 4ˆ2)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0156     0.0281   -0.55    0.579
## Sex(2) FEMALE   0.0681     0.0338    2.02    0.044 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##                               edf Ref.df      F p-value
## ti(CESD11_W1)                1.72   2.08 260.86 < 2e-16 ***
## ti(SelfEsteem_W1)            1.00   1.00  22.77 1.9e-06 ***
## ti(CESD11_W1,SelfEsteem_W1) 21.77  31.08   1.03    0.43
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.284   Deviance explained =   29%
## GCV = 0.74778  Scale est. = 0.74087   n = 2867

我们将检查的mgcv包的最后一个附加特性是运行一些快速检查最大允许平滑度是否受限的能力。虽然平滑度是已知的，但参数 k 控制允许的最大值。通常，如果估计的自由度比k–1 低得多，增加 k 不太可能有任何好处，因为模型已经确定简单的结构就足够了。然而，这并不总是正确的，特别是如果估计的自由度接近于k–1，这可能表明施加的人为限制导致了过度约束的模型，如果我们增加 k 我们可能会得到一组不同的结果。为了检验这一点，我们将回到我们早期的模型，在没有任何交互作用的情况下，检验抑郁症状和预测随后抑郁的年龄。为了方便起见，我们在这里复制了这个模型。请注意，抑郁症症状的估计自由度接近于k–1 = 4–1 = 3，这表明可能存在一些问题。

mgam5 <- gam(CESD11_W2 ∼ Sex +
               s(CESD11_W1, k = 4) +
               s(AGE_W1, k = 4), data = acl,
        family = gaussian())

summary(mgam5)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ∼ Sex + s(CESD11_W1, k = 4) + s(AGE_W1, k = 4)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0207     0.0272   -0.76    0.447
## Sex(2) FEMALE   0.0688     0.0342    2.01    0.044 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##               edf Ref.df     F p-value
## s(CESD11_W1) 2.86   2.99 344.7  <2e-16 ***
## s(AGE_W1)    1.78   2.16   2.4   0.076 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.272   Deviance explained = 27.3%
## GCV = 0.75508  Scale est. = 0.75333   n = 2867

为了检查我们是否想要增加 k ，我们可以使用gam.check()函数。它需要的只是一个合适的游戏。因为gam.check()依赖于一些模拟，它可以根据随机种子而变化。为了确保再现性，设置随机种子，就像我们接下来使用set.seed()所做的那样。打印结果，并绘制一些图，如图 5-12 所示。结果表明，对于第一波的抑郁症状来说，k可能还不够高。一般来说，由于平滑，不需要猜测 k 完全正确，但它需要足够大，以使函数形式不会受到不适当的限制。

img/439480_1_En_5_Fig12_HTML.png

图 5-12

广义加性模型的诊断图

par(mfrow = c(2, 2))
set.seed(12345)
gam.check(mgam5)

##
## Method: GCV   Optimizer: magic
## Smoothing parameter selection converged after 9 iterations.
## The RMS GCV score gradient at convergence was 6.7e-07 .
## The Hessian was positive definite.
## Model rank = 8 / 8
##
## Basis dimension (k) checking results. Low p-value (k-index<1) may
## indicate that k is too low, especially if edf is close to k'.
##
##                k'  edf k-index p-value
## s(CESD11_W1) 3.00 2.86    0.97   0.025 *
## s(AGE_W1)    3.00 1.78    0.99   0.230
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1

根据来自gam.check()的信息，我们可能会重新调整我们的模型，增加抑郁症状的 k 。我们选择一个新的值， k = 20。现在结果显示估计的自由度远低于k–1 = 20–1 = 19。虽然我们不需要这样做，但是我们也增加了年龄的 k 来演示改变参数的影响。

mgam5b <- gam(CESD11_W2 ˜ Sex +
               s(CESD11_W1, k = 20) +
               s(AGE_W1, k = 20), data = acl,
        family = gaussian())

summary(mgam5b)

##
## Family: gaussian
## Link function: identity
##
## Formula:
## CESD11_W2 ˜ Sex + s(CESD11_W1, k = 20) + s(AGE_W1, k = 20)
##
## Parametric coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)    -0.0202     0.0271   -0.75    0.456
## Sex(2) FEMALE   0.0680     0.0341    2.00    0.046 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##                edf Ref.df     F p-value
## s(CESD11_W1) 11.68  13.99 76.43    <2e-16 ***
## s(AGE_W1)     1.69   2.13  1.87      0.14
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.278   Deviance explained = 28.2%
## GCV = 0.7508  Scale est. = 0.74678   n = 2867

我们将结果绘制在图 5-13 中，图中显示了抑郁症状趋势比之前包含的更大的灵活性。还要注意，尽管增加了 k ，年龄的趋势并没有发生有意义的变化。这发生在更简单的拟合已经足够的时候；因此，增加 k 对结果几乎没有影响，因为额外的灵活性已经被抵消了。

par(mfrow = c(1, 2))
plot(mgam5b, se = TRUE, scale = 0)

尽管很简短，但本节涵盖了 gam 对于连续的、正态分布的数据的许多基本用途和特性。接下来的部分利用相同的想法，但是应用于其他类型的结果数据，并假设不同的分布。然而，模型拟合、模型比较和可视化的基本步骤往往是相似的。

img/439480_1_En_5_Fig13_HTML.png

图 5-13

增加抑郁症状的 k 值后，广义加法模型的模型结果图

二元结果

二元结果已经在讨论 GLMs 的章节中介绍过了。二元结果的 gam 依赖于与 GLMs 相同的理论，并使用相同的家族(伯努利/二项式)。二元结果 GAMs 的新颖之处在于使用了平滑样条，其功能与连续、正态分布的结果相同，只是平滑样条是在链接尺度上，在二元结果的情况下通常是 logit(对数概率)。

为了检验 gam 的二元结果，我们将使用吸烟作为结果，将当前吸烟者(1)与以前或从不吸烟者(0)进行比较。我们从年龄开始预测。该总结表明，年龄与吸烟状况之间存在某种非线性关系。

library(VGAM)

##
## Attaching package: 'VGAM'

## The following object is masked from 'package:car':
##
##     logit

## The following objects are masked from 'package:rms':
##
##     calibrate, lrtest

## The following object is masked from 'package:mgcv':
##
##     s

## The following objects are masked from 'package:boot':
##
##     logit, simplex

acl$CurSmoke <- as.integer(acl$Smoke_W1 == "(1) Cur Smok")

mgam.lr1 <- vgam(CurSmoke ˜ s(AGE_W1, df = 3),
             family = binomialff(link = "logit"),
             data = acl, model = TRUE)

summary(mgam.lr1)

##
## Call:
## vgam(formula = CurSmoke ˜ s(AGE_W1, df = 3), family = binomialff(link = "logit"),
##     data = acl, model = TRUE)
##
##
## Number of linear predictors:    1
##
## Name of linear predictor: logit(prob)
##
## (Default) Dispersion Parameter for binomialff family:    1
##
## Residual deviance:  4173 on 3613 degrees of freedom
##
## Log-likelihood: -2087 on 3613 degrees of freedom
##
## Number of iterations:  5
##
## DF for Terms and Approximate Chi-squares for Nonparametric Effects
##
##                   Df Npar Df Npar Chisq P(Chi)
## (Intercept)        1
## s(AGE_W1, df = 3)  1        2          44  2e-10

为了更好地理解结果，我们可以绘制平滑样条曲线。

img/439480_1_En_5_Fig14_HTML.png

图 5-14

年龄和当前吸烟状况的广义相加模型

par(mfrow = c(1, 1))
plot(mgam.lr1, se = TRUE,
     lcol = viridis(4)[1],
     scol = viridis(4)[2])

这表明在较年轻的年龄阶段变化不大，但在 60 岁左右急剧下降。然而，目前，该图处于链接比例。我们可以得到概率尺度上的预测，以便用更直观的度量来绘图。

## generate new data for prediction
## use the whole range of age
newdat <- as.data.table(expand.grid(
  AGE_W1 = seq(
    from = min(acl$AGE_W1, na.rm=TRUE),
    to = max(acl$AGE_W1, na.rm=TRUE),
    length.out = 1000)))

newdat$yhat <- predict(mgam.lr1,
                       newdata = newdat,
                       type = "response")

一旦我们有了一个预测数据集，我们就可以使用ggplot()来制作最终的图表。结果如图 5-15 所示。该图显示了在这种情况下与链路规模上的结果类似的图片。然而，转换后的结果更容易解释。

img/439480_1_En_5_Fig15_HTML.png

图 5-15

各年龄段吸烟的预测概率

ggplot(newdat, aes(AGE_W1, yhat)) +
  geom_line() +
  scale_y_continuous(labels = percent) +
  xlab("Age (years)") +
  ylab("Probability of Smoking") +
  coord_cartesian(xlim = range(acl$AGE_W1),
                  ylim = c(0, .4),
                  expand = FALSE)

一个限制是，没有一种内置的方法来获得来自VGAM包的新数据的 GAM 预测的置信区间。生成置信区间的一种方法是使用自举。有了这样一个简单的模型，这并不需要太多时间。我们还可以利用并行处理来加速它，特别是对于更复杂的模型，或者如果我们要进行大量的 bootstrap 重采样。

nboot <- 500

out <- matrix(NA_real_, ncol = nboot, nrow = nrow(newdat))

start.time <- proc.time()
set.seed(12345)
for (i in 1:500) {
  tmp <- vgam(CurSmoke ˜ s(AGE_W1, df = 3),
             family = binomialff(link = "logit"),
             data = acl[sample(nrow(acl), replace = TRUE)], model = TRUE)
  out[, i] <- predict(tmp,
                      newdata = newdat,
                      type = "response")
}
stop.time <- proc.time()

## time to bootstrap 500 times
stop.time - start.time
##    user  system elapsed
##   19.12    0.03   19.21

现在，我们可以从自举预测中生成一些摘要。首先，有时人们会将 bootstrap 预测的平均值与实际模型进行比较，以查看是否存在系统偏差。下面的代码只是一个计算平均绝对差的快速检查。在这种情况下，它非常小。

mean(abs(newdat$yhat - rowMeans(out)))

## [1] 0.00031

接下来，我们可以计算置信区间，但是要取 bootstrap 样本的百分位数。

newdat$LL <- apply(out, 1, quantile,
  probs = .025, na.rm = TRUE)

newdat$UL <- apply(out, 1, quantile,
  probs = .975, na.rm = TRUE)

最后，我们可以重新制作我们的预测概率图，但现在增加了置信区间。结果如图 5-16 所示。由于抽取的 bootstrap 样本数量相对较少，置信区间略有起伏。基于分位数的置信区间往往会随着样本数量的增加而变得平滑，但即使如此，它们也提供了一个相对快速且非常有用的补充，即通过年龄的平滑样条来指示吸烟预测概率的不确定性程度。

img/439480_1_En_5_Fig16_HTML.png

图 5-16

各年龄段吸烟的预测概率

ggplot(newdat, aes(AGE_W1, yhat)) +
  geom_ribbon(aes(ymin = LL, ymax = UL), fill = "grey80") +
  geom_line(size = 2) +
  scale_y_continuous(labels = percent) +
  xlab("Age (years)") +
  ylab("Probability of Smoking") +
  theme_tufte() +
  coord_cartesian(xlim = range(acl$AGE_W1),
                  ylim = c(0, .5),
                  expand = FALSE)

在关于 GLMs 的一章中，我们引入了一个测量方法，即预测概率的平均边际变化，作为当结果是分类的时，对预测值的更直观的总结。虽然这可以处理由于链接函数引起的非线性，但是在平滑样条的情况下，产生这样的测量通常是没有意义的，因为它不仅包含由于开始概率引起的差异，而且包含预测器的效果是非线性的事实。因此，我们在图 5-16 中产生的具有置信区间的数字通常是二元结果博弈的最终结果。

无序的结果

在关于 GLMs 的章节中，我们看到了超过两个水平的无序分类结果的多项逻辑回归模型。对于具有无序分类结果的 gam，过程是相似的。我们首先做一些数据管理，以生成第二波的崩溃就业变量，然后拟合一个 GAM，从年龄的平滑样条预测这一点。该总结揭示了几种对比的显著非线性的证据。一个有趣的特性是，现在不是对平滑项中是否存在非线性进行单一测试，而是进行k–1 次测试，其中 k 是结果中类别的数量。在我们的例子中，我们有五个类别；一个用作参考，因此有四个非线性测试。

acl[, EmployG_W2 := as.character(Employment_W2)]
acl[EmployG_W2 %in% c(
  "(2) 2500+HRS", "(3) 15002499",
  "(4) 500-1499", "(5) 1-499HRS"),
  EmployG_W2 := "(2) EMPLOYED"]
acl[, EmployG_W2 := factor(EmployG_W2)]

mgam.mr1 <- vgam(EmployG_W2 ˜ s(AGE_W1, k = 5),
               family = multinomial(),
               data = acl, model = TRUE)

summary(mgam.mr1)

##
## Call:
## vgam(formula = EmployG_W2 ˜ s(AGE_W1, k = 5), family = multinomial(),
##     data = acl, model = TRUE)
##
##
## Number of linear predictors:    4
##
## Names of linear predictors:
## log(mu[,1]/mu[,5]), log(mu[,2]/mu[,5]), log(mu[,3]/mu[,5]), log(mu[,4]/mu[,5])
##
## Dispersion Parameter for multinomial family:    1
##
## Residual deviance:  5261 on 11450 degrees of freedom
##
## Log-likelihood: -2631 on 11450 degrees of freedom
##
## Number of iterations:  8
##
## DF for Terms and Approximate Chi-squares for Nonparametric Effects
##
##                    Df  Npar  Df  Npar  Chisq  P(Chi)
## (Intercept):1       1
## (Intercept):2       1
## (Intercept):3       1
## (Intercept):4       1
## s(AGE_W1, k = 5):1  1         3           16    0.0
## s(AGE_W1, k = 5):2  1         2           83    0.0
## s(AGE_W1, k = 5):3  1         2           71    0.0
## s(AGE_W1, k = 5):4  1         2            5    0.1

我们可以再次绘制结果，默认情况下是在链接范围内，我们现在再次得到四个图，而不是一个，因为我们对分类结果的每个级别都有一个图。结果如图 5-17 所示。一些比较显示出比其他比较更大程度的非线性，并且趋势明显不同。多项式逻辑回归的 gam 允许平滑样条的形状和灵活性在结果的所有级别上变化。

img/439480_1_En_5_Fig17_HTML.png

图 5-17

年龄和就业状况的广义相加模型是一个五级无序分类结果，导致四种不同的年龄效应

par(mfrow = c(2, 2))
plot(mgam.mr1, se = TRUE,
     lcol = viridis(4)[1],
     scol = viridis(4)[2])

同样，我们可能更喜欢生成预测概率，而不是逻辑图。我们照常生成预测。这里，我们使用cbind()函数将预测概率与我们的数据集相结合，因为不是预测概率的一个向量，而是返回一个矩阵，因为在结果的每个级别中都有一个隶属概率。然后，我们将数据融合成一个长数据集，用于绘图。新的数据集有三个变量，一个是年龄，另一个是结果的水平，第三个是实际预测的概率。

## generate new data for prediction
## use the whole range of age
newdat <- as.data.table(expand.grid(
  AGE_W1 = seq(
    from = min(acl$AGE_W1, na.rm=TRUE),
    to = max(acl$AGE_W1, na.rm=TRUE),
    length.out = 1000)))

newdat <- cbind(newdat, predict(mgam.mr1,
                newdata = newdat,
                type = "response"))

newdatlong <- melt(newdat, id.vars = "AGE_W1")

summary(newdatlong)

##      AGE_W1           variable       value
## Min.    :24  (1)  DISABLED:1000  Min.   :0.00
## 1st Qu. :42  (2)  EMPLOYED:1000  1st Qu.:0.03
## Median  :60  (6)  RETIRED :1000  Median :0.08
## Mean    :60  (7)  UNEMPLOY:1000  Mean   :0.20
## 3rd Qu. :78  (8)  KEEP HS :1000  3rd Qu.:0.28
## Max.    :96                      Max.   :0.84

最后，我们可以使用ggplot()绘制结果图。结果如图 5-18 所示。这些发现强调了一个众所周知但不一定被线性模型很好地捕捉到的东西:人们倾向于在 60 岁后退休。因为当许多人(不是所有人，而是许多人)退休时，有一个相对狭窄的年龄窗口，这些模型显然不是线性的。相反，它们相对平坦，短暂地大幅变化，然后又回到相对平坦的状态。鉴于我们对退休年龄的了解，我们可能会考虑围绕该年龄增加更多的灵活性或有目的的分段模型，因为平滑样条仍将试图平滑事实上可能是相对离散的过程。尽管如此，即使没有这样的额外努力，我们也可以看到 GAM 在相对较好地捕捉这种快速转变方面的价值，尽管我们没有为这种转变可能发生的模型提供指导。

img/439480_1_En_5_Fig18_HTML.png

图 5-18

各年龄段就业状况的预测概率

ggplot(newdatlong, aes(
  AGE_W1, value,
  colour = variable, linetype = variable)) +
  geom_line(size = 2) +
  scale_color_viridis(discrete = TRUE) +
  scale_x_continuous("Age (years)") +
  scale_y_continuous("Probability", label = percent) +
  coord_cartesian(ylim = c(0, 1), expand = FALSE) +
  theme_tufte() +
  theme(legend.position = c(.2, .5),
        legend.key.width = unit(2, "cm"))

统计结果

在讨论 GLMs 的章节中已经介绍了计数结果。计数结果的 gam 依赖于与 GLMs 相同的理论，并使用相同的家族(泊松、负二项式)。gam 用于计数结果的新颖之处在于使用了平滑样条，其功能与用于连续、正态分布结果的功能相同，只是平滑样条是在链接尺度上，在计数结果的情况下通常是自然对数。在 GLM 一章中，我们看到了泊松分布的局限性，过度分散可能经常发生并且不能被充分捕捉。因此，这里我们将直接使用负二项式分布来处理 gam，这种分布允许过度分散。尽管我们只研究了一个单一的预测因子，但我们并不局限于此。在下面的例子中，我们检查了慢性疾病的数量，并根据性别和年龄的平滑样条来预测。该总结显示了年龄非线性的有力证据。

## negative binomial regression model
mgam.nbr1 <- vgam(NChronic12_W2 ˜ Sex + s(AGE_W1, k = 5),
              family = negbinomial(),
              data = acl, model = TRUE)

summary(mgam.nbr1)

##
## Call:
## vgam(formula = NChronic12_W2 ˜ Sex + s(AGE_W1, k = 5), family = negbinomial(),
##     data = acl, model = TRUE)
##
##
## Number of linear predictors:  2
##
## Names of linear predictors: loge(mu), loge(size)
##
## Dispersion Parameter for negbinomial family:  1
##
## Log-likelihood: -3636 on 5727 degrees of freedom
##
## Number of iterations:    8
##
## DF for Terms and Approximate Chi-squares for Nonparametric Effects
##
##                  Df Npar Df Npar Chisq P(Chi)
## (Intercept):1    1
## (Intercept):2    1
## Sex              1
## s(AGE_W1, k = 5) 1        3        112      0

为了更好地理解结果，我们可以绘制平滑样条曲线，如图 5-19 所示。我们可以看到，女性比男性报告更多的慢性疾病，报告的疾病数量在年轻时随着年龄的增长而迅速增加，但在老年时增加速度会放缓(图 5-19 )。

img/439480_1_En_5_Fig19_HTML.png

图 5-19

性别、年龄和慢性病数量的广义相加模型

par(mfrow = c(1, 2))
plot(mgam.nbr1, se = TRUE,
     lcol = viridis(4)[1],
     scol = viridis(4)[2])

与二元和多项逻辑回归一样，目前，该图处于链接级别。我们可以在原始计数尺度上获得预测，以便以更直观的度量标准绘图。

## generate new data for prediction
## use the whole range of age and sex
newdat <- as.data.table(expand.grid(
  Sex = levels(acl$Sex),
  AGE_W1 = seq(
    from = min(acl$AGE_W1, na.rm=TRUE),
    to = max(acl$AGE_W1, na.rm=TRUE),
    length.out = 1000)))

newdat$yhat <- predict(mgam.nbr1,
                       newdata = newdat,
                       type = "response")

一旦我们有了一个预测数据集，我们就可以使用ggplot()来绘制图表。结果如图 5-20 所示。虽然性别的影响在链接量表上是不变的，但在最初的反应量表上，随着预测分数的增加，它在绝对量级上增加；因此，预计老年男女之间的差距会更大。但是，注意，目前，年龄和性别之间没有交互作用。因此，在图 5-20 中，年龄对男女的影响是相同的。

img/439480_1_En_5_Fig20_HTML.png

图 5-20

按性别分列的各年龄段慢性疾病的预测数量

ggplot(newdat, aes(AGE_W1, yhat, colour = Sex)) +
  geom_line(size = 2) +
  scale_color_viridis(discrete = TRUE) +
  xlab("Age (years)") +
  ylab("Number Chronic Conditions") +
  theme_tufte() +
  coord_cartesian(xlim = range(acl$AGE_W1),
                  ylim = c(0, 2.5),
                  expand = FALSE) +
  theme(legend.position = c(.2, .8),
        legend.key.width = unit(1, "cm"))

我们可能想知道女性是否真的在年轻时报告了更多的慢性疾病，她们是否比男性更快达到稳定状态。这暗示了一种互动。由于VGAM中目前不支持平滑样条的交互，我们分离包并切换到mgcv。如下图所示，可使用gam()功能拟合模型。

detach("package:VGAM")
library(mgcv)

mgam.nbr2 <- gam(NChronic12_W2 ˜ Sex + s(AGE_W1, k = 10, by = Sex),
              family = nb(), data = acl)

summary(mgam.nbr2)

##
## Family: Negative Binomial(20719.179)
## Link function: log
##
## Formula:
## NChronic12_W2 ˜ Sex + s(AGE_W1, k = 10, by = Sex)
##
## Parametric coefficients:
##               Estimate Std. Error z value Pr(>|z|)
## (Intercept)    -0.2674     0.0395   -6.77  1.3e-11 ***
## Sex(2) FEMALE   0.2661     0.0477    5.58  2.4e-08 ***
## ---
## Signif. codes:    0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Approximate significance of smooth terms:
##                          edf Ref.df Chi.sq p-value
## s(AGE_W1):Sex(1) MALE   4.36   5.36  295  <2e-16 ***
## s(AGE_W1):Sex(2) FEMALE 4.11   5.10  447  <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## R-sq.(adj) =  0.248   Deviance explained = 25.6%
## -REML = 3649.7  Scale est. = 1         n = 2867

现在，我们再次生成预测，使用的代码与我们给模型安装vgam()时使用的代码相同。

## generate new data for prediction
## use the whole range of age and sex
newdat <- as.data.table(expand.grid(
  Sex = levels(acl$Sex),
  AGE_W1 = seq(
    from = min(acl$AGE_W1, na.rm=TRUE),
    to = max(acl$AGE_W1, na.rm=TRUE),
    length.out = 1000)))

newdat$yhat <- predict(mgam.nbr2,
                       newdata = newdat,
                       type = "response")

最后，我们再次绘制结果，如图 5-21 所示。然而，研究结果显示，如果有什么不同的话(尽管结果可能并不可靠)，女性的平台期远远没有女性的平台期长，男性平台期更早，甚至在老年女性预计会报告更多的慢性疾病。

img/439480_1_En_5_Fig21_HTML.png

图 5-21

根据一个交互模型，按性别预测不同年龄的慢性疾病数量

ggplot(newdat, aes(AGE_W1, yhat, colour = Sex)) +
  geom_line(size = 2) +
  scale_color_viridis(discrete = TRUE) +
  xlab("Age (years)") +
  ylab("Number Chronic Conditions") +
  theme_tufte() +
  coord_cartesian(xlim = range(acl$AGE_W1),
                  ylim = c(0, 2.7),
                  expand = FALSE) +
  theme(legend.position = c(.2, .8),
        legend.key.width = unit(1, "cm"))

与二元逻辑博弈一样，如果我们愿意，我们可以使用 bootstrapping 来生成预测的置信区间。请注意，这比二元逻辑博弈的例子花费的时间要长一些，可能是由于软件的差异，但也因为这是一个更复杂的模型，有两个预测因子和作为性别函数的年龄平滑样条。由于运行时间较长，在这个示例中，如果运行并行处理进行实际分析，可能会更有优势，因为您可能会使用至少几千个引导样本。

nboot <- 500

out <- matrix(NA_real_, ncol = nboot, nrow = nrow(newdat))

start.time <- proc.time()
set.seed(12345)
for (i in 1:500) {
  tmp <- gam(NChronic12_W2 ˜ Sex + s(AGE_W1, k = 10, by = Sex),
              family = nb(),
             data = acl[sample(nrow(acl), replace = TRUE)])
  out[, i] <- predict(tmp,
                      newdata = newdat,
                      type = "response")
}
stop.time <- proc.time()

## time to bootstrap 500 times
stop.time - start.time

##    user  system elapsed
##  167.18    0.73  168.08

现在，我们可以从自举预测中生成一些摘要。首先，有时人们会将 bootstrap 预测的平均值与实际模型进行比较，以查看是否存在系统偏差。下面的代码只是一个计算平均绝对差的快速检查。在这种情况下，它非常小。

mean(abs(newdat$yhat - rowMeans(out)))

## [1] 0.0094

接下来，我们可以计算置信区间，但是要取 bootstrap 样本的百分位数。

newdat$LL <- apply(out, 1, quantile,
  probs = .025, na.rm = TRUE)

newdat$UL <- apply(out, 1, quantile,
  probs = .975, na.rm = TRUE)

最后，我们可以重新制作预测计数图，但现在增加了置信区间。结果如图 5-22 所示。

img/439480_1_En_5_Fig22_HTML.png

图 5-22

使用 bootstrapped 置信区间按性别对不同年龄的慢性病进行预测计数

ggplot(newdat, aes(AGE_W1, yhat)) +
  geom_ribbon(aes(ymin = LL, ymax = UL, fill = Sex), alpha = .2) +
  geom_line(aes(colour = Sex), size = 2) +
  scale_color_viridis(discrete = TRUE) +
  scale_fill_viridis(discrete = TRUE) +
  xlab("Age (years)") +
  ylab("Number Chronic Conditions") +
  theme_tufte() +
  coord_cartesian(xlim = range(acl$AGE_W1),
                  ylim = c(0, 4),
                  expand = FALSE) +
  theme(legend.position = c(.2, .8),
       legend.key.width = unit(2, "cm"))

总的来说，在不同年龄的趋势形态上，女性和男性之间存在一些差异，但在预测中也存在相当大的不确定性，特别是在最年长的年龄，这表明女性超过 80 岁的明显增加可能是也可能不是一个非常可靠的趋势。同样，尽管男性预计在 80 岁后相对稳定，但他们有一个很宽的置信区间，可能包括一个明显的增长。在这种情况下，根本没有足够的数据来确定。事实上，如果我们看看第一波中 80 岁或以上的人在第二波中完成慢性病报告的人数，我们看到只有 27 名男性和 73 名女性，没有太多数据，特别是男性，可以据此对过去 80 年的趋势做出强有力的推断，因此有很大的置信区间。

xtabs(˜Sex + I(AGE_W1 > 80), data = acl[!is.na(NChronic12_W2)])

##             I(AGE_W1 > 80)
## Sex          FALSE TRUE
##   (1) MALE    1010   27
##   (2) FEMALE  1757   73

5.3 总结

本章简要介绍了回归的多项式、样条和光滑样条，然后介绍了一类灵活的模型，广义可加模型(gam)。它展示了 GAMs 如何被用来扩展参数广义线性模型(GLMs)以捕捉预测器的未知函数形式。特别是，当有连续的预测值时，gam 通常是有用的，并且担心与结果的关联可能不能被线性或多项式趋势充分捕获，或者没有足够的信息来推测多项式趋势的程度。在这些情况下，当有足够大的样本量时，GAMs 会表现出色，允许人们捕捉和模拟这些未知的趋势。本章还展示了如何检查结果，以及可视化和呈现 gam 结果的基础知识，包括如何使用 bootstrapping 获得不确定性估计值，以及如何绘制和可视化交互。表 5-1 简要概述了所使用的一些关键功能。

表 5-1

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| vgam() | 来自VGAM包的矢量广义加性模型，用于拟合半参数模型，该模型既包括广义线性模型等标准参数项，也包括一个或多个项的光滑样条。 |
| s() | 函数来指示应该对哪个预测变量应用平滑样条。注意，这个函数在VGAM包和mgcv包中以相同的名称出现，但是在VGAM包中，控制灵活性的参数是df，而在mgcv包中，相同的参数是k。 |
| gam() | mgcv包中的广义加性模型；见前面的vgam()，因为它们是相似的。 |
| plot() | 当应用于广义加性模型时，通常会使用参数化或平滑样条结果生成每个预测变量的图。 |
| linearHypothesis() | 测试来自car包的线性假设的函数。允许我们测试关于来自一个vgam()模型的参数项的假设。 |
| predict() | 在R中为广义加性模型准备了方法的通用函数，根据模型从原始或新数据生成预测得分。由于平滑样条难以用语言概括，所以在表示广义可加模型时经常使用预测值图。 |
| vis.gam() | 通过mgcv包中的gam()功能拟合模型的透视图(3D)和等高线图。对于可视化交互尤其有用。 |
| gam.check() | 用于检查所允许的最大灵活性是否(可能)足够，或者灵活性参数 k 是否应该增加。 |

六、ML：简介

机器学习(ML)是一个相当无定形的，至少在作者看来，是计算机辅助统计的工具包。虽然我们的最终目标将是支持向量机、分类和回归树，以及使用一些最新R包的人工神经网络，但在它们的核心，机器学习只是各种味道的模式识别。

这一介绍性章节的两个焦点，理解样本结构和介绍并行处理，试图为机器学习奠定基础。每个工作流和项目都是不同的，因此我们的意图是深入第六章中的数据将会发生什么，一旦我们的脚湿了，就在下一章中后退一步，适当地清理并设置和减少我们的数据，最后在第三幕中进行一些真正的机器学习。

亲爱的读者，如果你熟悉训练/验证/测试数据集、引导和并行/多核处理，请随意跳到下一章。另一方面，如果你是一名受过更传统训练的统计学家，来自一位作者深情地回忆的舒适的查找表世界，那么准备好以一种与以前截然不同的方式思考数据。

在任何情况下，在这一章中，我们假装数据干净、小而整洁地来到我们面前——选择这个词是因为我们使用了tibbles和名为tidyverse的新 uberpackage 的其他元素，它组合了几个对数据管理有用的包[111]。也许在我们机器学习的探索中，它会更有用。现在，看一下设置和库调用，我们将介绍本章中使用的其他包。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(tidyverse)
library(rsample)
library(data.table)
library(boot)
library(parallel)
library(foreach)
library(doParallel)

options(width = 70, digits = 3)

像往常一样，我们使用几个包，并在这里简要讨论新增加的内容。rsample包[52]允许简单的重采样，而boot包为我们处理通用引导程序[26]。parallel包提供了在多个内核上并行运行计算的功能，从而缩短了得出结果的时间[76]。foreach包是众所周知的 for 循环的变体，它有助于并行化[63]。最后(目前)，doParallel包允许foreach实际使用并行化。

6.1 培训和验证数据

我们从iris样本和一个关于数据的词开始。iris 数据集有 150 个完美的观察值。在机器学习中，一个风险是机器对我们的样本数据学习得太好，然后在真实世界的测试中不太准确。这被称为过度训练或过度适应。换句话说，我们用来估计模型和现实生活之间可能的误差的标准可能太乐观，太小了。一种解决方案是将数据分成两部分。一个是训练片，展示给机器看。另一个是测试部分，作为储备，用于以后评估该模型对新数据或“野生”数据的处理效果。没有什么是不需要权衡或成本的，使用这种技术，挑战是一样的，提供的数据越多，机器应该做得越好。常见的比率包括 80/20、75/25 或 70/30，大部分数据在训练样本中，而较小的一组数据则用于测试。事实上，为了阻止甚至是人为的偏见，在进行探索性数据分析之前进行分割可能是推荐的。

这里值得花点时间来讨论一下这个理论框架。从技术上讲，如果我们遵循这个逻辑结论，有三个数据是有意义的。一组训练集是数据的主体，用于探索性数据分析和模型训练。第二部分，一个较小的集合，将用于验证模型，看看它做得有多好。由于我们可能会从几个模型中进行选择，此验证集(不用于训练模型)可用于在线性拟合和二次拟合之间或者在人工神经网络和随机森林之间做出决定。由于这种验证数据本质上仍将用于模型选择，它在技术上仍是拟合过程的一部分，因此不能真正给出新数据的真实性能。最后，第三部分将被保留到最后，只用于评估模型在面对真实世界的新数据时的误差。

这当然需要足够的数据来牺牲。对于我们在机器学习中的例子，我们并没有忽视这种关注。相反，我们是在本地假设下展示任何单一计算或技术背后的机制，即所研究的技术已经通过文献或一些其他过程被确定为最佳前进方式。未能保留最终的第三个测试集可能是机器学习技术在面对新数据时表现不佳的一个原因(当然，这不是唯一的原因)。

在我们的示例中，使用 80/20 分割可能是有意义的。我们使用基数为R的函数set.seed(5)来确定rsample重采样函数使用的随机数发生器。这允许感兴趣的读者精确复制值。使用的函数是initial_split()，它接受要分割的数据的参数以及要设置到训练集中的数据的比例。鉴于我们的具体情况，在iris的 150 行中，我们保留 29 行作为我们的测试集，保留 80%用于模型构建和训练。

set.seed(5)
case_data <- initial_split(data = iris, prop = 0.8)
case_data

## <121/29/150>

这种重采样实际上是随机抽取数据——这很重要，因为如果数据以某种方式排序，它可能会过度影响模型，尤其是因为我们拆分了数据。我们没有选择在这个重采样分割中使用任何strata。如果这对数据很重要，那么这些层将根据给定的比例进行分割。从case_data对象中，我们通过rsample包中的相关函数调用来提取我们的训练和测试数据。此外，我们使用来自tidyverse的glimpse()来查看我们的训练数据集。

data_train <- training(case_data)
data_test <- testing(case_data)
glimpse(data_train)

## Observations: 121
## Variables: 5
## $ Sepal.Length <dbl> 5.1, 4.9, 4.7, 4.6, 5.0, 5.4, 4.6, 5.0, 4.4,...
## $ Sepal.Width  <dbl> 3.5, 3.0, 3.2, 3.1, 3.6, 3.9, 3.4, 3.4, 2.9,...
## $ Petal.Length <dbl> 1.4, 1.4, 1.3, 1.5, 1.4, 1.7, 1.4, 1.5, 1.4,...
## $ Petal.Width  <dbl> 0.2, 0.2, 0.2, 0.2, 0.2, 0.4, 0.3, 0.2, 0.2,...
## $ Species      <fct> setosa, setosa, setosa, setosa, setosa, seto...

注意我们有四个类型为double的列，我们确实看到有一个用于species的因子列。经过进一步检查，这些竟是三种鸢尾花。

unique(data_train$Species)

## [1] setosa     versicolor virginica
## Levels: setosa versicolor virginica

为了将重点放在 ML 和支持合理快速 ML 的计算机环境中使用样本的方式上，我们将一个简单的线性模型拟合到我们的数值数据中，以展示考虑样本数据结构的三种不同方式。目的是提供一个可操作的例子，作为理解这三种方法的一种透镜。

本文之前已经拟合过线性模型，因此我们只注意到该模型是线性拟合，其中数据集中可用的四个数字变量中的三个用于预测第四个变量Petal.Length。

length.lm = lm(Petal.Length ~ Sepal.Length +
                 Sepal.Width + Petal.Width,
               data = data_train)
length.lm

##
## Call:
## lm(formula = Petal.Length ~ Sepal.Length + Sepal.Width + Petal.Width,
##     data = data_train)
##
## Coefficients:
##  (Intercept)  Sepal.Length   Sepal.Width   Petal.Width
##       -0.274         0.723        -0.630         1.466

summary(length.lm)

##
## Call:
## lm(formula = Petal.Length ~ Sepal.Length + Sepal.Width + Petal.Width,
##     data = data_train)
##
## Residuals:
##     Min      1Q  Median      3Q     Max
## -1.0349 -0.1699 -0.0061  0.1976  0.5751
##
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)
## (Intercept)   -0.2735     0.3091   -0.88     0.38
## Sepal.Length   0.7230     0.0609   11.87  < 2e-16 ***
## Sepal.Width   -0.6298     0.0715   -8.81  1.3e-14 ***
## Petal.Width    1.4661     0.0700   20.93  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Residual standard error: 0.299 on 117 degrees of freedom
## Multiple R-squared:  0.971,  Adjusted R-squared:  0.97
## F-statistic: 1.32e+03 on 3 and 117 DF,  p-value: <2e-16

剩余标准误差(RSE)为 0.299，RSE 可视为回归线的 y 高度与定型集中各点的实际 y 高度之间的一种平均值。接近零的值比远离零的值更可取(就告诉我们我们模型的一些功效而言)。形式上，方程[47]，这是一个真正伟大的文本背后的所有这些更深层次的理论，给出如下:

$$ RSE=\sqrt{\frac{\sum \limits_{i=1}^n{\left({y}_i-{\widehat{y}}_i\right)}²}{n-4}} $$

(6.1)

翻译成R，我们在这里展示代码:

sqrt(
  sum(
    (fitted(length.lm)-data_train$Petal.Length)²
  )/(nrow(data_train)-4)
)

## [1] 0.299

在这两种情况下，请注意除法部分的数据集大小减去了变量的数量(在我们的例子中是 4)。虽然免费为我们提供这个值有点儿R,但均方差(MSE)可能是一种更常见的测量拟合优度或质量的方法。这两个等式本质上是相同的，因为在本质上，它们都涉及由模型生成的 y 高度减去在给定成对输入值的数据中找到的 y 高度。由于R已经为我们存储了模型的这些残差，代码看起来有点不同，但是一个快速的实验会显示前面代码的第三行和后面的mean()中的参数是相同的。

mse_train<- mean(length.lm$residuals²)
mse_train

## [1] 0.0862

这两种度量都是以原始数据为单位的，并且这两种度量都有一个关键缺陷。它们是在训练数据上测量的，并且模型被专门训练为在这些相同的数据上表现良好。这是样本内精度测量的一个示例，它不太可能是我们的模型在野生或真实世界数据上表现如何的一个很好的估计器。不是从训练数据计算 MSE(或者实际上任何类型的拟合优度度量),同时拥有训练和测试数据的目的正是为了让我们能够根据训练中没有使用的数据来估计模型性能。我们很自然地转向我们的data_test。

如果我们在测试数据上测量相同类型的 y 值差异，我们会看到两种情况下的数字都更大。这给了我们一些证据，我们有一个模型犯了过度拟合。这也是一个很大的激励因素，说明考虑模型时不仅要考虑样本内数据，还要考虑样本外数据是多么重要。

sqrt(
  sum(
    (predict(length.lm, data_test)-data_test$Petal.Length)²
  )/(nrow(data_test)-2)
)

## [1] 0.41

mse_test <- mean((predict(length.lm, data_test) -
                  data_test$Petal.Length)²)
mse_test

## [1] 0.156

这种训练与测试过程是关键。任何好的模型的目标都是具有小的残差。事实上，作为模型系数选择的一部分，训练数据的残差通常被最小化，因此，我们不是从训练样本内部的数据来看 MSE，而是从样本外部的数据来看测试数据 MSE。这可以帮助我们理解我们的模型可能如何执行。请记住，正如在开始时提到的，我们目前并不确定这个模型是好是坏。我们真的在使用我们的测试数据来理解我们的模型在部署后如何支持真实世界的使用。如果我们要根据测试数据修改我们的模型，同样，我们实际上需要保留三组数据。

记住，MSE 是原始数据单位的平方。因此，虽然测试数据的 MSE 高于训练数据——实际上几乎是两倍——但它仍然足够好，可以继续进行。有时，任何种类的可操作数据都比没有好，测试 MSE 较高的事实可能只是警告我们的用户在使用模型数据来通知决策时要小心。它还取决于所使用的数据类型。例如，大学入学趋势可能比健康结果更能容忍错误。在这些花数据的情况下，这些数据是以平方厘米为单位的，我们的测试数据表明我们可能会偏离大约半厘米，而训练数据声称可能只偏离四分之一厘米。

我们有一个模型，我们知道它在现实世界中的表现。然而，我们确实损失了 29 个数据点的价值。如果我们能够得到样本外的 MSE 估计值，并且仍然拥有全部 150 个数据点，那就太好了。损失的一部分不仅仅是我们的模型可能在多 20%的数据下做得更好。那就是特定的数据分割，虽然是随机的，但可能仍然有点极端，我们的意思是我们选择在小数据集上分割数据的位置，即使是随机的，也可能影响我们的最终结果。

仅在两个维度上考虑我们的测试与训练数据。在图的顶行，可以看到我们的输入仅仅是Sepal.Length与我们的输出Petal.Length在训练与测试中有一些不同的范围。Q-Q 图的第二行证实了这些样品在图 6-1 中看起来确实略有不同。

par(mfrow=c(2,2))
plot(data_train$Sepal.Length, data_train$Petal.Length)
plot(data_test$Sepal.Length, data_test$Petal.Length)
qqnorm(data_train$Petal.Length,
       xlab = "Theoretical Quantiles Train")
qqnorm(data_test$Petal.Length,
       xlab = "Theoretical Quantiles Test")

即使是六位数的总结也显示测试数据与我们的样本数据略有不同:

summary(data_train$Sepal.Length)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
##     4.3     5.1     5.7     5.8     6.3     7.9

summary(data_test$Sepal.Length)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
##    4.40    5.20    6.10    6.02    6.50    7.70

因此，虽然我们可能有比只看训练数据 MSE 更好的想法，我们的真实世界 MSE 可能是什么，但我们受set.seed(5)数据拉动的支配。我们这样做的两个风险是基于样本分割的潜在高方差，在其他条件相同的情况下，如果在 121 和 150 个观察值之间进行选择，我们预计基于 150 个观察值训练的模型会更好一些。

我们在这一部分的目标是激发对单独的训练和测试数据的需求。在这个过于简单的案例中，我们的测试数据可能会让我们对我们训练过的模型在现实世界中的表现有所了解。但是一般来说，我们会因为丢失数据而牺牲很多。我们如何做得更好，尤其是对于较小的样本？

img/439480_1_En_6_Fig1_HTML.png

图 6-1

一些数据的 2D 和 Q-Q 图

6.2 重采样和交叉验证

解决这个问题的方法是所谓的交叉验证。我们不是只做一次训练/测试分割，而是做多次。

有几种方法可以完成这个过程。与其将我们的数据分成两部分，不如让我们设想 5 部分，每部分包含我们的 iris 数据集的 30 个观察值。我们将前四个箱合并在一起以形成我们的训练集，同时保留箱 5 作为测试。将模型拟合到训练集，并计算测试集的 MSE。重复这个过程五次，接下来我们只保留 bin 4 作为我们的测试集，合并 1-3 和 5 作为我们的训练集，依此类推。我们依次从每个箱中获得五个不同的 MSE 值。如果我们平均这些，我们现在有所谓的交叉验证 MSE(有时称为 CV)。

虽然可能有一些软件包为我们做了这种计算，但偶尔让我们亲自动手看看到底发生了什么也是有帮助的。首先，我们将我们的虹膜样本随机放入一个变量中，我们称之为crossData，没有替换(这确保我们的箱不以任何方式排序)。我们通过tidyverse包中的sample_n()函数来实现。通过使用%>%管道操作符，我们不必将数据集作为函数的第一个参数。一旦我们的数据被打乱，我们就添加一个列，把它分成五个箱。选择 5 是因为它很小，能很好地分成 150，我们喜欢它。另外，调用一个store变量来保存 MSEs。

crossData <- iris %>%
  sample_n(nrow(iris), replace = FALSE)
crossData <- add_column(crossData,
  Bin = cut(1:150, breaks = 5, labels = c(1:5)))
store <- tibble(Fold=1:5, MSE=NA_integer_)

现在我们使用一个 for 循环来遍历我们的五个 bin。我们这样做五次，因为我们有五个箱，每次我们都留出一个箱作为测试数据，如上所述。在交叉验证的说法中，折叠的数量是我们的 K 数，这被称为 K 折叠(或在我们的情况下为 5 折叠)。这个 for 循环的每一次传递都代表我们数据的一个“折叠”。我们系统地通过我们的数据来训练我们的线性模型，计算保留的测试箱上的 MSE，将该 MSE 存储在我们的store变量中，并移动到下一个折叠。

for(i in 1:5){
  data_train<-crossData %>% filter(Bin != i)
  data_test<-crossData %>% filter(Bin == i)
  lengthFold.lm = lm(Petal.Length ~ Sepal.Length +
                      Sepal.Width + Petal.Width,
                     data = data_train)
  store[i,]$MSE <- mean((predict(lengthFold.lm, data_test) -
                           data_test$Petal.Length)²)
}

现在我们得到了所有五次折叠的平均标准误差。请注意，这个 MSE 来自我们的折叠测试部分，因此这可能会给我们一个很好的想法，即我们可能会期望一个根据所有数据训练的模型在现实生活中对新输入的数据进行处理。

mse_k <- mean(store$MSE)
mse_k

## [1] 0.109

在这种情况下，MSE 约为 0.109，这小于我们在前面章节中只有一组训练/测试数据时的估计值。

当进行 K 折叠和交叉验证时，我们使用的模型不是单个折叠模型，而是一个基于所有数据训练的模型，我们看到样本外估计值与样本内估计值的 MSEs 相当接近。因此，虽然我们的交叉验证 MSE 比我们的完整数据集 MSE 大一点，但它们彼此之间并不是不可能远离的，至少对于花瓣长度这样的东西来说不是太远。

lengthFold.lm <- lm(Petal.Length ~ Sepal.Length +
                   Sepal.Width + Petal.Width,
                   data = iris)
lengthFold.lm

##
## Call:
## lm(formula = Petal.Length ~ Sepal.Length + Sepal.Width + Petal.Width,
##     data = iris)
##
## Coefficients:
##  (Intercept)  Sepal.Length   Sepal.Width   Petal.Width
##       -0.263         0.729        -0.646         1.447

mse_ALL <- mean(lengthFold.lm$residuals²)
mse_ALL

## [1] 0.099

请注意，在存储的每个折叠的 MSE 值中(其中模型适合于其他箱，因此这是 for 循环每次迭代的真正样本外测试)，我们有一个从 0.075 到 0.18 的很大范围，这只是显示了单个测试/训练数据集的风险！这又回到了我们之前的警告，当将太多的数据集划分给测试数据集时，较小的数据集会有一点风险。

store

## # A tibble: 5 x 2
##    Fold    MSE
##   <int>  <dbl>
## 1     1 0.180
## 2     2 0.109
## 3     3 0.0822
## 4     4 0.0746
## 5     5 0.101

现在，我们没有理由不能只做 4 次折叠，甚至 100 次折叠(进行一些代码编辑),因此一般称为 K-Fold，K 可以是从 1(没有数据分割)、2(我们的第一个例子是一个特殊的加权情况)到 n(这也是一个特殊情况，称为留一个交叉验证或 LOOCV)中选择的任何数字。最后一件要注意的事，好吧，注意到一段时间后就忘了，是关于我们的 for 循环。虽然我们是按顺序运行的，即 1、2、3、4、5，但我们没有理由必须这样运行。换句话说，迭代 2 不依赖于迭代 1。如果我们要拟合一个复杂的模型或者拟合更多的数据，我们的 for 循环每次运行都需要一些时间。尽管如此，只要我们得到 fold-MSEs 表，每次运行都是独立的。再次注意到这一点，现在马上忘记它。

k 倍似乎是一个体面的技术，它是。我们能够在一个完整的数据集上训练一个模型，但我们仍然对我们的模型在样本之外的数据上的表现有所了解。然而，虽然这对于我们正在使用的线性模型来说可能是很好的，但取决于我们真正部署的实际机器学习模型，K-Fold 模型和在完整数据集上使用的模型之间可能没有明显的联系。或者至少，我们可能不想处理这样一个事实，即我们在整个数据集上部署的模型很可能是基于与任何单个 K 倍模型相当不同的系数权重构建的。我们该如何解决这个问题？

还要注意，虽然 K-Fold 模型可以工作，但它确实比我们的简单训练/测试模型需要更多的计算能力。我们从只拟合一个模型到拟合六次模型。就工作量而言，这可能是一个相当大的增长。因此，当我们考虑允许我们的模型在整个数据集上训练并从完全训练的模型中获得我们的误差估计的方法时，要认识到每一种改进都取决于机器技术的提高。

6.3 引导

我们现在把注意力转向另一项技术，即自举。在我们刚刚使用的 K-Fold 或交叉验证技术中，虽然最终我们确实从样本外数据中获得了我们的“真实”MSE 估计，但每个模型都是使用不到一个完整的数据集样本构建的，这意味着每个模型可能都有点弱。因此，我们的误差估计虽然比 pass 好，但可能仍然比它需要的更强。

Bootstrap 用不同的方式解决这个问题。假设我们的样本，最初的iris样本是从鸢尾花群体中精心抽取的样本，我们可以假设，如果我们从iris重新取样，替换，并做很多很多次，我们应该会看到一个看起来非常接近群体的整体。

首先，我们编写一个函数，它是我们自举中感兴趣的统计量。我们之前已经知道 MSE 是什么了。注意我们每次都符合模型。我们的函数将获取一个数据集，计算线性模型，然后计算样本内 MSE 并返回该值。想必我们会在别处收集，事实上我们会！

mse <- function(data, i) {
  lengthBoot.lm <- lm(Petal.Length ~ Sepal.Length +
                      Sepal.Width + Petal.Width,
                      data=data[i,])
  return(mean(lengthBoot.lm$residuals²))
}

现在，使用来自library(boot),的函数boot()，我们运行引导程序。正在发生的是，这个函数通过替换，从我们的虹膜数据样本中进行重采样。事实上，它这样做了一万次。每次，重采样都被发送到我们的mse()函数，该模型的 MSE 返回值存储在bootResults中。

bootResults <- boot(data=iris, statistic=mse, R=10000)
bootResults

##
## ORDINARY NONPARAMETRIC BOOTSTRAP
##
##
## Call:
## boot(data = iris, statistic = mse, R = 10000)
##
##
## Bootstrap Statistics :
##     original   bias    std. error
## t1*    0.099 -0.00263      0.0129

我们可以用数字和图形来查看结果。图 6-2 显示了所有这些样本内 MSE 的总体分布。

img/439480_1_En_6_Fig2_HTML.png

图 6-2

自举结果。

plot(bootResults)

从这个分布中，我们看到 MSEs 的 95%置信区间(注意 0.95 也是默认值)在 0.08 和 0.13 之间。

boot.ci(bootResults, conf = 0.95, type="bca")

## BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS
## Based on 10000 bootstrap replicates
##
## CALL :
## boot.ci(boot.out = bootResults, conf = 0.95, type = "bca")
##
## Intervals :
## Level       BCa
## 95%   ( 0.0794,  0.1343 )
## Calculations and Intervals on Original Scale

就像 K-Fold 方法一样，对于实际模型，我们将使用整个数据集lengthFull.lm的线性拟合来获得可变系数。这只是给我们一种感觉，我们可能期望现实世界的 MSE 生活在哪里。

我们可能认为这个置信区间有点太低，因为它是基于样本内均值标准误差的。人们可以想象对 bootstrap 的改进，其中使用重采样完成后剩余的数据点来计算样本外 bootstrap MSE。当然，这种估计可能有点过高，因为这些数据点是从训练中删除的。虽然每个启动的线性模型都是针对 150 个值进行训练的，但不可能提取所有 150 个原始值-事实上，这就是为什么会得到直方图中显示的正态分布。这种分布正是因为不是所有的值都被拉出来，所以 MSE 是变化的。使用剩余的数据值当然会让我们到达与 K 倍相同的地方，因为我们预计这种 bootstrap 技术的 MSE 可能会比真实世界的数据在完整模型上经历的稍大一些。尽管如此，通过多次进行 bootstrap，我们也许会对我们的模型如何工作有所了解。聪明的研究人员经常开发新技术，目前.632 bootstrap值得探索。然而，我们现在停留在我们的基本引导。这一介绍性章节是关于在执行机器学习时要考虑的三个简单结构。

K-Fold 和 bootstrap 的另一个有趣之处是它需要一些时间来运行。很可能该数据集的 K 倍太小，很难发现。然而，10，000 个引导可能确实变得引人注目。现在，时间不会太长，可能只有 6 秒钟，但我们确实抽取了 10，000 个大小为 150 的样本，总计 1，500，000 个点！

如果我们的原始数据有 1000 个点呢？还是一万？这很可能会降低我们使用 bootstrap 的能力。至少，在我们对如何使用电脑变得更聪明之前是这样。

6.4 并行处理和随机数

至少就计算环境而言，它有两个主要特征。它存在于内存中，而不是硬盘中。因此，任何关于拥有数百万或数十亿数据点与数百或数千数据点的讨论都需要考虑随机存取存储器的大小。尽管如此，由于现代图形贪婪，大多数计算机都有相当多的这种能力。另一个特性是，默认情况下，R 在单个处理器上工作。大多数现代计算机至少有两个。因为我们已经加载了parallel库，所以继续在您的系统上运行代码片段并比较结果:

detectCores()

## [1] 12

detectCores(logical = TRUE)

## [1] 12

detectCores(logical = FALSE)

## [1] 6

我们写这篇文章的计算机有四个物理核心，每个都有两个逻辑“核心”现在，这不是一本关于计算机硬件的书，所以让我们忽略物理和逻辑内核的细微差别。事实上，根据您的操作系统和硬件系统，您可能无法区分这三者。在任何情况下，如果返回的数字大于 1，那么如果将更多的处理器放入工作池，bootstrapping 和 K-Fold 可以运行得更快。

还记得我们在 K-Fold 中说过，我们的 for 循环每次都是完全相同的操作，迭代 c 不依赖于要计算的迭代 a。自举也是一样。我们正在进行 10，000 次随机拉动，并将其输入到我们的函数mse(),中，如果我们正在做一个比简单线性拟合更复杂的模型，或者如果我们的数据变得更大，我们可能会发现自己需要等待相当长的时间。如果同样的过程是独立完成的，那么本节的方法可以很好地工作。如果这个过程不是独立的，那就超出了本文的范围(当然，尽管有方法来适应这个过程)。

现在，多核与集群和并行之间存在细微差别。如果您的数据生活在真正的大数据世界中，这些细微差别可能对您有意义。但是，我们冒险记忆也可能成为一个问题，这些也超出了本文的范围。然而，如果我们对 10，000 次重采样的 6 秒估计是正确的，并且我们得到了两个内核而不是一个，我们应该能够将执行时间减少一半。

这在实践中并不完全正确，因为启动和停止多核环境会产生一些开销。然而，回想一下，我们的分析只是一个简单的线性模型，然后是一个平均值。这些间接成本大多是固定的，因此如果模型拟合更奇特，并且引导花费一天或半天，那么将该过程削减大约一半开始变得有意义。而且，由于我们的系统有几个核心，我们实际上可以做得比一半更好！一个警告:无论你的系统中有多少个内核，至少留一个给系统使用——否则一切都会停滞不前，直到R完成。最有可能的是，你会听到风扇运转的声音——毕竟你要做一些计算工作了！

在下面的代码中，我们将只在 2 个内核上运行，因此我们将 10，000 次启动分为 5，000 次。为了简单起见，我们构建一个函数runP()来处理并行流程运行。接下来，我们使用makeCluster()函数创建R的两个并行副本，在其上运行我们的函数。我们的R副本需要与我们的机器拥有相同的环境，所以我们使用clusterEvalQ()函数来设置我们的cl集群，使其拥有我们需要的库结构。虽然我们使用checkpoint()来确保版本是正确的，但是R的每个副本只需要boot库。在这里吝啬可以节省开销时间，所以在传递信息时要明智。从那里，我们还使用clusterExport()从我们的全球环境中导出一些已经构建的函数。我们做的最后一点集群开销是设置我们的随机数流，以便我们的结果通过clusterSetRNGStream()与你的相匹配。

从这里开始，其余的大部分应该对引导很熟悉，所以我们花一点时间来剖析实际的并行调用——记住前面的步骤是开销。从 base R调用apply()函数对某种数组应用函数。函数parLapply()是相同的，除了第一个参数链接到我们刚刚建立的集群，第二个参数只是说我们将运行我们的函数两次，第三个当然是我们之前构建的 bootstrapping 5,000 runs 函数。do.call()函数也是一个基本函数，它只是在我们的并行函数上调用组合函数c(),以便将两个结果合并到一个引导对象中。这样做是为了让熟悉的boot.ci()像以前一样工作。当然，我们确实花了一些时间通过stopCluster()关闭我们的集群。

## notice 10000/2 = 5000
runP <- function(...) boot(data=iris, statistic=mse, R=5000)

## makes a cluster with 2 cores as 10000/5000 = 2
cl<-makeCluster(2)

## passes along parts of the global environment
## to each node / part of the cluster
## again, base is a file path variable to our book's path
## set book_directory <- "C:/YourPathHere/"
clusterExport(cl, c("runP", "mse", "book_directory", "checkpoint_directory" ))

## creates the library and some environment on
## each of the parts of the cluster
clusterEvalQ(cl, {

library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

    library(boot)
  })

## [[1]]
##  [1] "boot"          "checkpoint"    "RevoUtils"     "stats"
##  [5] "graphics"      "grDevices"     "utils"         "datasets"
##  [9] "RevoUtilsMath" "methods"       "base"
##
## [[2]]
##  [1] "boot"          "checkpoint"    "RevoUtils"     "stats"
##  [5] "graphics"      "grDevices"     "utils"         "datasets"
##  [9] "RevoUtilsMath" "methods"       "base"

## similar to set.seed() except for clusters
clusterSetRNGStream(cl, 5)

## uses the parLapply() function

which works on windows too
pBootResults <- do.call(c, parLapply(cl, seq_len(2), runP))

#stop the cluster
stopCluster(cl)

# view results
pBootResults

##
## ORDINARY NONPARAMETRIC BOOTSTRAP
##
##
## Call:
## boot(data = iris, statistic = mse, R = 5000)
##
##
## Bootstrap Statistics :
##     original   bias    std. error
## t1*    0.099 -0.00295      0.0128

## get 95% confidence interval of the MSEs
## (note 0.95 is the default)
boot.ci(pBootResults, conf = 0.95, type="bca")

## BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS
## Based on 10000 bootstrap replicates
##
## CALL :
## boot.ci(boot.out = pBootResults, conf = 0.95, type = "bca")
##
## Intervals :
## Level       BCa
## 95%   ( 0.0795,  0.1352 )
## Calculations and Intervals on Original Scale

就是这样。根据我们的计算，这还不到使用一个处理器所用时间的一半，但这没关系。请注意，这其中的大部分可以根据您所处的环境进行修改。由于我们有了更多的内核，我们可以增加激活的R实例的数量，并相应地减少runP()函数中的引导运行次数。或者，通过将seq_len()编辑为四个而不是两个，我们可以在两个内核上运行不止一个周期的runP()。在这种情况下，我们让引导函数运行四次，在每个 R 实例上运行两次，我们得到 20，000 次引导运行。因此，您可以看到，它基于可用的硬件和数据细微差别，非常可定制和灵活。图 6-2 中的结果与图 6-3 中的结果相似:

plot(pBootResults)

不过，值得花点时间承认这两个数字略有不同——尽管幸运的是，您的机器在每种情况下都与我们的相符。原因在于随机数及其生成方式。要使研究具有可重复性，有助于set.seed()或clusterSetRNGStream()。这不仅有助于我们在各种机器上的输出与您的相匹配，还有助于我们今天的输出与明天的输出相匹配。随机数是从一个起点或种子生成的，这就是这两种技术的作用。然而，在集群的情况下，虽然我们希望在全局级别上有相同的种子，但对于每个处理器，我们确实希望有稍微不同的起点，以便我们真正获得 10，000 个唯一的重采样，而不是 5，000 个重复的副本。这是通过使用种子生成器的集群变体来实现的，它在幕后相当巧妙地处理这个过程，以便恰好出现可重复的随机性。尽管如此，这是一个不同于之前使用的随机性，所以数字会略有不同。

img/439480_1_En_6_Fig3_HTML.png

图 6-3

引导结果

在本节中，我们看到了如何为任何流程构建一个集群，并合并集群的结果。我们使用了我们的boot()函数(不可否认，现在它已经内置了一些并行功能)。虽然引导过程可以通过 for 循环手工编码，但我们选择使用一个包。这在R中经常是可能的，在CRAN上有许多包和库。这种不断更新和改进的生态系统是checkpoint包的原因之一。适用于一个版本库的代码可能在下个月或明年就不再适用了。对于任何处理不断变化的数据的人来说，这是机器学习的一个功能，其中真实世界的数据进来并需要分析，这是非常有用的，既可以将代码锁定在特定的时间点，以便它在未来继续工作，也可以偶尔重新访问代码并改进写作，以利用更新或更新的库。

为每一个

我们的最后一节是关于foreach()函数和同名的库。现在，虽然我们在前面介绍的 K-Fold for()函数的上下文中介绍了这一点，但这当然适用于任何循环，只要每个迭代都是独立的。然而，一般来说，在R中经常有对数据矢量化循环函数的方法，并且这些方法会比这个过程更快。此外，对于这种特定情况，由于创建集群的开销，这实际上并没有节省时间，因为我们在简单的线性模型上只处理了 150 位数据 5 次。我们的 K-Fold 在计算上比我们的 bootstrap 简单得多！

接下来的大部分代码都很熟悉。我们从建立集群的代码开始。这里唯一的新函数是registerDoParallel()，它将我们的foreach()函数连接到正确的框架。和以前一样，我们选择在两个内核上完成这项工作。因为我们不使用boot，我们不叫那个库。然而，我们确实调用了tidyverse库，因为我们在 tibbles 上使用了管道。

cl <- makeCluster(2)
registerDoParallel(cl)

clusterExport(cl, c("book_directory", "checkpoint_directory"))

clusterEvalQ(cl, {
  library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

  library("tidyverse")
  })

## [[1]]
##  [1] "forcats"       "stringr"       "dplyr"         "purrr"
##  [5] "readr"         "tidyr"         "tibble"        "ggplot2"
##  [9] "tidyverse"     "checkpoint"    "RevoUtils"     "stats"
## [13] "graphics"      "grDevices"     "utils"         "datasets"
## [17] "RevoUtilsMath" "methods"       "base"
##
## [[2]]
##  [1] "forcats"       "stringr"       "dplyr"         "purrr"
##  [5] "readr"         "tidyr"         "tibble"        "ggplot2"
##  [9] "tidyverse"     "checkpoint"    "RevoUtils"     "stats"
## [13] "graphics"      "grDevices"     "utils"         "datasets"
## [17] "RevoUtilsMath" "methods"       "base"

感兴趣的主要代码在这里。同样，这几乎正是我们第一次做 K 折叠时发生的事情，这就是重点。唯一的变化是foreach()函数和参数。我们再次通过折叠 1 到 5 运行我们的函数。我们确实使用了一个新的参数，.combine,并把它设置到我们的组合函数中，这个函数我们在R和之前的do.call()函数中很熟悉。然后，我们使用%dopar%通过我们在前面的设置代码中设置的注册后端来调用并行处理。这些包处理剩下的，将这五次运行发送到两个内核并合并结果。

k <- foreach(i=1:5, .combine = c) %dopar% {
  data_train <- crossData %>% filter(Bin != i)
  data_test <- crossData %>% filter(Bin == i)
  lengthFold.lm <- lm(Petal.Length ~ Sepal.Length +
                      Sepal.Width + Petal.Width,
                      data = data_train)
  mean((predict(lengthFold.lm, data_test) -
          data_test$Petal.Length)²)
}

请注意，由于要计算五次折叠，而只有两个处理器，所以有点不匹配。根据我们的循环，可以想象这些迭代中的一个或多个可能或多或少是计算密集型的。在这种情况下，当然不可能。尽管如此，还是有可能以这样一种方式建立并行处理，即将花费很长时间的交互首先发送到一个内核，而其余的发送到另一个内核。默认值是它们先入先出，按顺序运行。

stopCluster(cl)
mse_Pk<-mean(k)
mse_Pk

## [1] 0.109

我们看到，之前 for 循环中的 MSE 0.109 与现在的 MSE 0.109 相匹配。当对相同的数据运行时，这两个过程是相同的。事实上，当第一次(甚至是最后一次)通过foreach()让代码运行得更快以确保没有犯愚蠢的错误时，这可能是明智的。如果我们的读者发现自己处于这样一种情景中，作者只能增加他们冰冷的安慰，即我们过去和现在都比期望的更频繁。

6.5 总结

这就完成了机器学习的设置。有了三种好的方法来训练数据，然后获得对现实世界性能的一些估计，我们现在有了思维导图来了解我们的数据将如何被格式化和使用。有了几个好的多核计算包和代码在手，我们就有了让我们的机器学习不需要太长时间的技术工具。

事实上，并行计算技术——尤其是foreach()——非常容易实现，可以节省大量时间。现在，有很多方法可以绕过 for 循环。矢量化计算就是其中之一。举一个个人的例子，一个作者每天处理相当大的数据(大约 200，000 行和 70 列)。从数据库中提取数据后，基本的数据转换至少需要半天时间。代码是几年前写的，场景最初对时间并不敏感。一般的用例是在周末运行。然而，操作发生了变化，代码开始需要更频繁地运行。在写这段文字的时候，你的作者决定清理代码。在一台小型的四核办公计算机上，通过对一些过程进行矢量化，对其他过程进行并行化，时间从半天缩短到不到 2 小时！

这也许是看待这一章的一个很好的方式。它确实让我们可以用机器学习做一些非常棒的事情。然而，这些技术可以混合搭配，让生活和数据变得更简单、更友好。就像一些工作的旧代码一样，只是现在有点太慢了，不方便，有可能通过一些非常小的改变获得一些非常重要的突破！

像往常一样，我们通过调用表 6-1 中的主要函数来结束。

表 6-1

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| boot() | 从引导库并运行引导程序 |
| boot.ci() | 计算引导输出的置信区间 |
| clusterEvalQ() | 从并行库中设置要复制到每个集群实例的环境 |
| clusterExport() | 从全局环境中导出值，供每个集群环境使用 |
| clusterSetRNGStream() | 创建一个随机数种子，并适当地渗透到每个集群 |
| detectCores() | 确定 R 中有多少内核可用 |
| do.call() | 调用函数并通过列表传递参数的基本函数 |
| filter() | tidyverse 函数返回某些行 |
| fitted() | 从线性模型中提取拟合的 y 值 |
| foreach() | for的平行版本(大部分) |
| glimpse() | tidyverse 函数，水平显示列名，后跟前几个值 |
| initial_split() | 将数据分成训练和测试用例的 rsample 函数 |
| lm() | 基于提供的关系创建线性模型 |
| makeCluster() | 形成一个集群 |
| parLapply() | 除适用于并行计算之外的应用功能 |
| predict() | 显示线性模型的预测 y 值 |
| registerDoParallel() | 向并行集群注册foreach()函数的 doParallel 包操作符 |
| seq_len() | 创建一定长度的序列 |
| set.seed() | 为可重现的结果创建随机数种子 |
| stopCluster() | 停止由makeCluster创建的集群 |
| testing() | 提取测试数据的 rsample 函数 |
| training() | 提取列车数据的 rsample 函数 |
| unique() | 仅返回唯一值 |

七、ML：无监督

这一章关注无监督机器学习，它通常处理未标记的数据。目标是基于共同的特征将这些数据分类到相似的组中。通常，尽管不总是，无监督的机器学习也被用作一种降维。例如，如果您得到的数据集包含数百或数千个要素，但只有几千个案例，您可能希望首先利用无监督学习将大量要素提取到数量较少的维度中，这些维度仍然可以从较大的集合中捕获大部分信息。无监督机器学习也是探索性数据分析阶段的最后一步。可以利用无监督机器学习中的部分排序或聚类来了解您的数据有多少“唯一”的组或维度。想象一个由来自几个不同地理区域的各种指标组成的数据集。人们可能期望无监督的分组技术来指示关于地理区域的一些事情。或者，人们可能会发现相距遥远的位置有几个高度共同的特征。

无论有无标签，数据总是杂乱无章地出现在我们面前。因此，预处理阶段通常需要付出大量的努力。通常，数据不符合机器学习算法预期的格式。通常，需要的是一系列列，其中前几列在某种意义上是关键列(可能是地理区域和收集某些测量值的年份)，而后面的列表示对特定特征或变量的观察。可能需要进行操作才能将数据转换成正确的格式，其中每一行都是特定时间点的唯一观察值。我们将在本章的示例数据中看到一些数据操作。

像往常一样，我们使用几个包，并在这里简要讨论新增加的内容。readxl包[112]允许从 Excel 数据文件中快速读取我们的示例数据，而ape包为我们处理树状图选项[72]。MASS包提供了处理非线性降维的功能[99]。matrixStats包提供了矩阵和向量的功能。最后，viridis软件包提供了一个更好的调色板——特别是对于色盲来说。

library(checkpoint)
 checkpoint("2018-09-28", R.version = "3.5.1",
   project = book_directory,
   checkpointLocation = checkpoint_directory,
   scanForPackages = FALSE,
   scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(ggplot2)
library(cowplot)
library(viridis)
library(scales)
library(readxl)
library(data.table)
library(ape)
library(MASS)
library(matrixStats)

options(width = 70, digits = 2)

本章讨论的一种方法是主成分分析(PCA)。虽然R有一些 PCA 的内置函数，但是在包pcaMethods中有更广泛的选项，它是Bioconductor的一部分，是 CRAN 包库的替代，有许多用于生物信息学的R包。我们可以使用下面的代码安装pcaMethods。注意到

source("https://bioconductor.org/biocLite.R")
biocLite("pcaMethods")

一旦安装了pcaMethods，我们就可以像加载任何其他R包一样加载它。

library(pcaMethods)

7.1 数据背景和探索性分析

所使用的样本数据来自世界银行，在 CC-BY 4.0 下获得许可，并已被修改为仅包括来自某些地区的某些列的数据[2]。数据在Gender_StatsData_worldbank.org_ccby40.xlsx里。特别是，我们将数据简化为近年来的一些关键信息，这样就没有遗漏变量。所使用的文件可以从出版商的网站或 GitHub 存储库中下载。

应该注意的是，read_excel()默认为stringsAsFactors = FALSE，这通常是人们希望读入数据的方式。如果需要因子，很有可能在以后通过适当的函数调用来控制它。

## Note: download Excel file  from publisher website first
dRaw <- read_excel("Gender_StatsData_worldbank.org_ccby40.xlsx")
dRaw <- as.data.table(dRaw) # convert data to data.table format.

丢失的变量可以用不同的方法处理。处理缺失数据的最简单方法是删除所有缺失的信息。代价是将我们的数据缩减为全部可用信息的一个非常小的子集。更好地处理缺失数据的低成本方法将在我们关于缺失数据的章节中讨论。现在，只需注意在本章的示例数据中没有丢失数据。

理解数据的结构是任何分析的关键的第一步。例如，至少，知道存在什么类型的数据以及数据是如何组织的是很重要的。对我们的数据使用str()函数告诉我们，该结构具有按年份组织的字符和数字数据，从 1997 年到 2014 年。事实上，大多数数据都是数字。

summary()函数按列生成一个简短的摘要，并显示我们的数据变化很大。在这一点上，我们开始意识到我们的数据对于机器学习格式来说不是最佳的。换句话说，每一列都不是单一的、唯一的度量。此外，时间信息不是在 year 变量中捕获的，而是在变量名本身中捕获的。

深入研究我们数据的标签，我们发现通过unique()函数，我们的数据来自几个大的地理区域，似乎围绕着某些特定的指标。

str(dRaw)

## Classes 'data.table' and 'data.frame':       99 obs. of  21 variables:
##  $ CountryName   : chr  "Sub-Saharan Africa" "Sub-Saharan Africa" "Sub-Saharan Africa" "Sub-Saharan Africa" ...
##  $ Indicator Name: chr  "Adolescent fertility rate (births per 1,000 women ages 15-19)" "Age dependency ratio (% of working-age population)" "Children out of school, primary, female" "Children out of school, primary, male" ...
##  $ IndicatorCode : chr  "SP.ADO.TFRT" "SP.POP.DPND" "SE.PRM.UNER.FE" "SE.PRM.UNER.MA" ...
##  $ 1997          : num  1.32e+02 9.17e+01 2.44e+07 2.03e+07 1.55e+01 ...
##  $ 1998          : num  1.31e+02 9.13e+01 2.44e+07 2.05e+07 1.53e+01 ...
##  $ 1999          : num  1.30e+02 9.09e+01 2.43e+07 2.08e+07 1.52e+01 ...
##  $ 2000          : num  1.28e+02 9.04e+01 2.37e+07 2.00e+07 1.49e+01 ...
##  $ 2001          : num  1.27e+02 9.04e+01 2.31e+07 1.95e+07 1.47e+01 ...
##  $ 2002          : num  1.26e+02 9.02e+01 2.28e+07 1.91e+07 1.44e+01 ...
##  $ 2003          : num  124 90 21938840 18230741 14 ...
##  $ 2004          : num  1.23e+02 8.97e+01 2.14e+07 1.79e+07 1.36e+01 ...
##  $ 2005          : num  1.21e+02 8.94e+01 2.06e+07 1.71e+07 1.32e+01 ...
##  $ 2006          : num  1.20e+02 8.94e+01 1.99e+07 1.67e+07 1.28e+01 ...
##  $ 2007          : num  1.18e+02 8.94e+01 1.94e+07 1.52e+07 1.23e+01 ...
##  $ 2008          : num  1.16e+02 8.92e+01 1.90e+07 1.52e+07 1.19e+01 ...
##  $ 2009          : num  1.15e+02 8.89e+01 1.92e+07 1.56e+07 1.15e+01 ...
##  $ 2010          : num  1.13e+02 8.85e+01 1.98e+07 1.61e+07 1.10e+01 ...
##  $ 2011          : num  1.11e+02 8.83e+01 1.92e+07 1.54e+07 1.07e+01 ...
##  $ 2012          : num  1.09e+02 8.80e+01 1.91e+07 1.55e+07 1.03e+01 ...
##  $ 2013          : num  1.07e+02 8.75e+01 1.91e+07 1.53e+07 1.00e+01 ...
##  $ 2014          : num  1.05e+02 8.69e+01 1.92e+07 1.56e+07 9.73 ...
##  - attr(*, ".internal.selfref")=<externalptr>

summary(dRaw)

##  CountryName        Indicator Name     IndicatorCode
##  Length:99          Length:99          Length:99
##  Class :character   Class :character   Class :character
##  Mode  :character   Mode  :character   Mode  :character
##
##
##
##       1997               1998               1999
##  Min.   :       6   Min.   :       6   Min.   :       6
##  1st Qu.:      16   1st Qu.:      15   1st Qu.:      15
##  Median :      71   Median :      71   Median :      71
##  Mean   :  949741   Mean   :  872971   Mean   :  817616
##  3rd Qu.:    4366   3rd Qu.:    4338   3rd Qu.:    3993
##  Max.   :24371987   Max.   :24437801   Max.   :24292225
##       2000               2001               2002
##  Min.   :       6   Min.   :       6   Min.   :       5
##  1st Qu.:      15   1st Qu.:      16   1st Qu.:      16
##  Median :      70   Median :      70   Median :      70
##  Mean   :  781078   Mean   :  736806   Mean   :  674889
##  3rd Qu.:    4224   3rd Qu.:    4275   3rd Qu.:    4672
##  Max.   :23672959   Max.   :23125633   Max.   :22795557
##       2003               2004               2005
##  Min.   :       5   Min.   :       5   Min.   :       5
##  1st Qu.:      16   1st Qu.:      15   1st Qu.:      16
##  Median :      70   Median :      71   Median :      71
##  Mean   :  651075   Mean   :  637985   Mean   :  659420
##  3rd Qu.:    5568   3rd Qu.:    6772   3rd Qu.:    8042
##  Max.   :21938840   Max.   :21350198   Max.   :20582825
##       2006               2007               2008
##  Min.   :       5   Min.   :       5   Min.   :       5
##  1st Qu.:      15   1st Qu.:      16   1st Qu.:      16
##  Median :      71   Median :      71   Median :      72
##  Mean   :  653180   Mean   :  597847   Mean   :  573176
##  3rd Qu.:    9166   3rd Qu.:   11168   3rd Qu.:   13452
##  Max.   :19904220   Max.   :19402096   Max.   :19015196
##       2009               2010               2011
##  Min.   :       5   Min.   :       5   Min.   :       5
##  1st Qu.:      16   1st Qu.:      16   1st Qu.:      16
##  Median :      72   Median :      72   Median :      72
##  Mean   :  569320   Mean   :  569669   Mean   :  561551
##  3rd Qu.:   12484   3rd Qu.:   12654   3rd Qu.:   13404
##  Max.   :19209252   Max.   :19774011   Max.   :19191406
##       2012               2013               2014
##  Min.   :       5   Min.   :       5   Min.   :       5
##  1st Qu.:      16   1st Qu.:      16   1st Qu.:      16
##  Median :      72   Median :      73   Median :      73
##  Mean   :  567238   Mean   :  592806   Mean   :  610288
##  3rd Qu.:   13047   3rd Qu.:   13574   3rd Qu.:   13852
##  Max.   :19068296   Max.   :19092876   Max.   :19207489

unique(dRaw$CountryName)

## [1] "Sub-Saharan Africa"             "North America"
## [3] "Middle East & North Africa"     "Latin America & Caribbean"
## [5] "European Union"                 "Europe & Central Asia"
## [7] "East Asia & Pacific"            "Central Europe and the Baltics"
## [9] "Arab World"

unique(dRaw$IndicatorCode)

##  [1] "SP.ADO.TFRT"       "SP.POP.DPND"       "SE.PRM.UNER.FE"
##  [4] "SE.PRM.UNER.MA"    "SP.DYN.CDRT.IN"    "SE.SCH.LIFE.FE"
##  [7] "SE.SCH.LIFE.MA"    "NY.GDP.PCAP.CD"    "NY.GNP.PCAP.CD"
## [10] "SP.DYN.LE00.FE.IN" "SP.DYN.LE00.MA.IN"

在我们可以对数据使用机器学习算法之前，我们需要将数据重新组织为一种格式，其中每一列都只有与一个指标相关的数据。

我们将使用 IndicatorCodes 作为新的列名，并删除对人友好的描述，尽管一旦我们重新组织了数据，让这些描述便于解释列标签是很好的。因为指示器名称列有一个空格，所以我们用刻度线(在键盘的波浪号键上可以找到)来描述列名的开始和结束，并通过赋值 null 来完全删除该列。

dRaw[,'Indicator Name':= NULL]

为了转换数据，我们对原始数据使用melt()函数将年份列折叠成一个名为 year 的变量。这样，关于时间的信息被捕获到一个变量中，而不是不同变量的名称中。这使得所有数值都在一个名为“值”的列中。情况似乎更糟，因为现在要确定任何单个值的含义，必须同时检查指标代码列和年份列。

但是，使用dcast()，我们可以将数据“转换”成正确的结构，其中指标代码是值变量的列，而我们的CountryName和Year列表示随着时间的推移对国家地区的观察。

## collapse columns into a super long dataset
## with Year as a new variable
d <- melt(dRaw, measure.vars = 3:20, variable.name = "Year")
head(d)

##           CountryName  IndicatorCode Year   value
## 1: Sub-Saharan Africa    SP.ADO.TFRT 1997 1.3e+02
## 2: Sub-Saharan Africa    SP.POP.DPND 1997 9.2e+01
## 3: Sub-Saharan Africa SE.PRM.UNER.FE 1997 2.4e+07
## 4: Sub-Saharan Africa SE.PRM.UNER.MA 1997 2.0e+07
## 5: Sub-Saharan Africa SP.DYN.CDRT.IN 1997 1.6e+01
## 6: Sub-Saharan Africa SE.SCH.LIFE.FE 1997 5.7e+00

str(d)

## Classes 'data.table' and 'data.frame':       1782 obs. of  4 variables:
##  $ CountryName  : chr  "Sub-Saharan Africa" "Sub-Saharan Africa" "Sub-Saharan Africa" "Sub-Saharan Africa" ...
##  $ IndicatorCode: chr  "SP.ADO.TFRT" "SP.POP.DPND" "SE.PRM.UNER.FE" "SE.PRM.UNER.MA" ...
##  $ Year         : Factor w/ 18 levels "1997","1998",..: 1 1 1 1 1 1 1 1 1 1 ...
##  $ value        : num  1.32e+02 9.17e+01 2.44e+07 2.03e+07 1.55e+01 ...
##  - attr(*, ".internal.selfref")=<externalptr>

## finally cast the data wide again
## this time with separate variables by indicator code
## keeping a country and time (Year) variable
d <- dcast(d, CountryName + Year ~ IndicatorCode)

head(d)

##    CountryName Year NY.GDP.PCAP.CD NY.GNP.PCAP.CD SE.PRM.UNER.FE
## 1:  Arab World 1997           2299           2310        6078141
## 2:  Arab World 1998           2170           2311        5961001
## 3:  Arab World 1999           2314           2288        5684714
## 4:  Arab World 2000           2589           2410        5425963
## 5:  Arab World 2001           2495           2496        5087547
## 6:  Arab World 2002           2463           2476        4813368
##    SE.PRM.UNER.MA SE.SCH.LIFE.FE SE.SCH.LIFE.MA SP.ADO.TFRT
## 1:        4181176            8.1            9.7          57
## 2:        4222039            8.3            9.8          56
## 3:        4131775            8.5           10.0          55
## 4:        3955257            8.7           10.0          54
## 5:        3726838            8.8           10.1          53
## 6:        3534138            9.1           10.2          52
##    SP.DYN.CDRT.IN SP.DYN.LE00.FE.IN SP.DYN.LE00.MA.IN SP.POP.DPND
## 1:            6.8                69                65          79
## 2:            6.7                69                65          78
## 3:            6.6                69                66          76
## 4:            6.5                70                66          75
## 5:            6.4                70                66          73
## 6:            6.3                70                66          72

str(d)

## Classes 'data.table' and 'data.frame':    162 obs. of  13 variables:
##  $ CountryName      : chr  "Arab World" "Arab World" "Arab World" "Arab World" ...
##  $ Year             : Factor w/ 18 levels "1997","1998",..: 1 2 3 4 5 6 7 8 9 10 ...
##  $ NY.GDP.PCAP.CD   : num  2299 2170 2314 2589 2495 ...
##  $ NY.GNP.PCAP.CD   : num  2310 2311 2288 2410 2496 ...
##  $ SE.PRM.UNER.FE   : num  6078141 5961001 5684714 5425963 5087547 ...
##  $ SE.PRM.UNER.MA   : num  4181176 4222039 4131775 3955257 3726838 ...
##  $ SE.SCH.LIFE.FE   : num  8.08 8.27 8.5 8.65 8.84 ...
##  $ SE.SCH.LIFE.MA   : num  9.73 9.82 9.97 10.02 10.12 ...
##  $ SP.ADO.TFRT      : num  56.6 55.7 54.9 54.2 53.3 ...
##  $ SP.DYN.CDRT.IN   : num  6.8 6.68 6.57 6.48 6.4 ...
##  $ SP.DYN.LE00.FE.IN: num  68.7 69 69.3 69.6 69.8 ...
##  $ SP.DYN.LE00.MA.IN: num  65 65.3 65.7 65.9 66.2 ...
##  $ SP.POP.DPND      : num  79.1 77.7 76.2 74.7 73.2 ...
##  - attr(*, ".internal.selfref")=<externalptr>
##  - attr(*, "sorted")= chr  "CountryName" "Year"

现在，数据采用了适合机器学习的格式，其中每一行都是按年份对一个全球区域的观察，所有信息都是在一个变量中捕获的，而不是在变量(列)名称中。这种格式的数据有时被称为“整洁”数据，这是 Hadley Wickham 在 2014 年的一篇文章[113]中深入描述的一个概念。

由于我们的列名本身和我们的区域名可能会被图形化，因此缩短这些名称的长度对于提高视觉清晰度是有价值的。此外，一些算法可能有保留字符(如完整的点或其他标点符号)。在这种情况下，我们的数据的列名被分配给x，然后使用gsub函数删除所有标点符号。接下来，使用函数abbreviate将每个列名减少到四个字符。这些名称通过names函数分配给我们的数据集。最后，国名本身也被缩短了。我们希望我们的读者原谅我们在图形易读性和理解性之间的权衡。注意，在这种情况下，我们使用了left.kept选项来增强理解。

## rename columns with shortened, unique names
x<-colnames(d)
x<-gsub("[[:punct:]]", "", x)
(y <- abbreviate(x, minlength = 4, method = "both.sides"))

##   CountryName          Year   NYGDPPCAPCD   NYGNPPCAPCD   SEPRMUNERFE
##        "CntN"        "Year"        "NYGD"        "NYGN"        "SEPR"
##   SEPRMUNERMA   SESCHLIFEFE   SESCHLIFEMA     SPADOTFRT   SPDYNCDRTIN
##        "ERMA"        "SESC"        "FEMA"        "SPAD"        "SPDY"
## SPDYNLE00FEIN SPDYNLE00MAIN     SPPOPDPND
##        "FEIN"        "MAIN"        "SPPO"

names(d) <- y

## shorten regional names to abbreviations.
d$CntN<-abbreviate(d$CntN, minlength = 5,
                   method = "left.kept")

我们简要描述了表 7-1 中每列数据所代表的含义。我们首先显示原始的列名，接着是一个|，然后是我们的缩写。

表 7-1

性别数据中的列列表

|

变量(特征)

|

描述

|
| --- | --- |
| CountryName &#124; CntN | 地理区域或国家集团的简称 |
| Year &#124; Year | 每个数据的来源年份 |
| SP.ADO.TFRT &#124; SPAD | 青少年生育率(每 1，000 名 15-19 岁女性的出生率) |
| SP.POP.DPND &#124; SPPO | 受抚养年龄比率(占工作年龄人口的百分比) |
| SE.PRM.UNER.FE &#124; SEPR | 失学儿童，小学，女性 |
| SE.PRM.UNER.MA &#124; ERMA | 失学儿童，小学，男性 |
| SP.DYN.CDRT.IN &#124; SPDY | 粗死亡率(每千人) |
| SE.SCH.LIFE.FE &#124; SESC | 预期受教育年限，女性 |
| SE.SCH.LIFE.MA &#124; FEMA | 预期受教育年限，男性 |
| NY.GDP.PCAP.CD &#124; NYGD | 人均国内生产总值(现值美元) |
| NY.GNP.PCAP.CD &#124; NYGN | 人均国民总收入，阿特拉斯法(现值美元) |
| SP.DYN.LE00.FE.IN &#124; FEIN | 女性出生时预期寿命(岁) |
| SP.DYN.LE00.MA.IN &#124; MAIN | 出生时预期寿命，男性(岁) |

既然数据已经有了合适的结构，summary()函数将为我们提供一些关于各种度量单位的信息。有趣的是，在某些情况下，每列中的数据范围似乎变化很大。另一项需要注意的是，Year 列不是数字，而是一个因子。虽然把它作为一个因素可能有意义，但也可能没有意义。现在，我们用as.character()函数将Year转换成字符串。

summary(d)

##      CntN                Year          NYGD            NYGN
##  Length:162         1997   :  9   Min.   :  496   Min.   :  487
##  Class :character   1998   :  9   1st Qu.: 3761   1st Qu.: 3839
##  Mode  :character   1999   :  9   Median : 7458   Median : 7060
##                     2000   :  9   Mean   :13616   Mean   :13453
##                     2001   :  9   3rd Qu.:19708   3rd Qu.:19747
##                     2002   :  9   Max.   :54295   Max.   :55010
##                     (Other):108
##       SEPR               ERMA               SESC           FEMA
##  Min.   :  100024   Min.   :  109075   Min.   : 5.7   Min.   : 7.0
##  1st Qu.:  482710   1st Qu.:  563119   1st Qu.:10.3   1st Qu.:11.2
##  Median : 1338898   Median : 1195360   Median :13.3   Median :13.1
##  Mean   : 3992637   Mean   : 3360191   Mean   :12.8   Mean   :12.8
##  3rd Qu.: 3936040   3rd Qu.: 3339679   3rd Qu.:15.7   3rd Qu.:14.9
##  Max.   :24437801   Max.   :20766960   Max.   :17.3   Max.   :16.5
##
##       SPAD          SPDY           FEIN         MAIN         SPPO   

##  Min.   : 11   Min.   : 5.0   Min.   :52   Min.   :48   Min.   :41
##  1st Qu.: 21   1st Qu.: 6.0   1st Qu.:72   1st Qu.:68   1st Qu.:49
##  Median : 38   Median : 8.1   Median :77   Median :70   Median :51
##  Mean   : 45   Mean   : 8.5   Mean   :74   Mean   :69   Mean   :57
##  3rd Qu.: 53   3rd Qu.:10.6   3rd Qu.:80   3rd Qu.:73   3rd Qu.:63
##  Max.   :132   Max.   :15.5   Max.   :84   Max.   :78   Max.   :92
##

str(d)

## Classes 'data.table' and 'data.frame':    162 obs. of  13 variables:
##  $ CntN: chr  "ArbWr" "ArbWr" "ArbWr" "ArbWr" ...
##  $ Year: Factor w/ 18 levels "1997","1998",..: 1 2 3 4 5 6 7 8 9 10 ...
##  $ NYGD: num  2299 2170 2314 2589 2495 ...
##  $ NYGN: num  2310 2311 2288 2410 2496 ...
##  $ SEPR: num  6078141 5961001 5684714 5425963 5087547 ...
##  $ ERMA: num  4181176 4222039 4131775 3955257 3726838 ...
##  $ SESC: num  8.08 8.27 8.5 8.65 8.84 ...
##  $ FEMA: num  9.73 9.82 9.97 10.02 10.12 ...
##  $ SPAD: num  56.6 55.7 54.9 54.2 53.3 ...
##  $ SPDY: num  6.8 6.68 6.57 6.48 6.4 ...
##  $ FEIN: num  68.7 69 69.3 69.6 69.8 ...
##  $ MAIN: num  65 65.3 65.7 65.9 66.2 ...
##  $ SPPO: num  79.1 77.7 76.2 74.7 73.2 ...
##  - attr(*, ".internal.selfref")=<externalptr>

d[, Year := as.character(Year)]

接下来，我们开始探索我们各种特征之间的关系。我们使用ggplot2包中的ggplot()函数制作一些图表，将人均国民总收入作为输入(x 轴)，青少年生育率作为响应变量(y 轴)。一个是人均美元，另一个是每 1000 名 15-19 岁女性的出生率。plot_grid()函数帮助我们制作了一个图表面板来显示这两个变量和另一个图表，其中我们按数据年份给数据点着色。

## ggplot2 plot object indicating x and y variables
p1 <- ggplot(d, aes(NYGN, SPAD))

## make a grid of two plots
plot_grid(
  ## first plot data points only
  p1 + geom_point(),
  ## data poins colored by year
  p1 + geom_point(aes(colour = Year)) +
    scale_colour_viridis(discrete = TRUE),
  ncol = 1
)

看图 7-1 ，似乎有明显的群体。下一部分转向机器学习方法，试图准确地确定有多少不同的群体。人们认为，并非我们所有的地区都是截然不同的(例如，欧盟与欧洲和中亚之间可能有重叠)。因此，简单地按地理区域划分每个群体可能是不必要的。相反，我们将检查一些算法，这些算法试图根据经验确定需要多少个聚类或分组来捕获观察到的数据。

img/439480_1_En_7_Fig1_HTML.png

图 7-1

每千名妇女的人均国民生产总值和青少年生育率图

720 万美元

比较常见的分组算法之一是kmeans。我们可以使用stats包中名副其实的kmeans()函数在R中执行kmeans集群，该包是少数几个“附带”base R的包之一。

kmeans ()有两个主要参数:包含连续数字数据的数据集x和告诉函数我们希望从数据中提取多少个聚类的中心数k。简而言之，该算法所做的是创建一组良好的 k 中心点，使得组内平方和(欧几里德距离的代表)最小化，给定我们指定的要提取的聚类数量的约束。

该算法的启动方式有一定的可变性，因此如果您希望您的分析具有可重复性，在R中设置随机启动种子是很重要的。我们通过使用值为2468的set.seed()函数来做到这一点，如果您想重现我们的结果，就应该使用这个函数。

接下来，初始化变量wgss以包含组内平方和。对于任何给定数量的聚类，这是算法寻求最小化的度量。

案例k = 1会很无聊，所以我们从两个中心开始，让我们的for()循环在 2 到 9 个中心上迭代算法，用于我们的NYGN对SPAD的数据。对于每次迭代，我们将组内平方和的总和存储在变量中，并绘制我们熟悉的数据图，这一次通过分配的分类成员关系来给点着色。

最后，我们在最后一个图块中添加了一个 scree 图，以显示聚类数与组内平方和的减少量相比的情况。最终的数字如图 7-2 所示。

set.seed(2468)
wgss <- vector("numeric", 8)
plots <- vector("list", 9)
p1 <- ggplot(d, aes(NYGN, SPAD))

for(i in 2:9) {
  km <- kmeans(d[, .(NYGN, SPAD)],
             centers = i)

  wgss[i - 1] <- km$tot.withinss

  plots[[i - 1]] <- p1 +
    geom_point(aes_(colour = factor(km$cluster))) +
    scale_color_viridis(discrete = TRUE) +
    theme(legend.position = "none") +
    ggtitle(paste("kmeans centers = ", i))
}

plots[[9]] <- ggplot() +
  geom_point(aes(x = 2:9, y = wgss)) +
  xlab("Number of Clusters") +
  ylab("Within SS") +
  ggtitle("Scree Plot")

do.call(plot_grid, c(plots, ncol = 3))

在图 7-2 中，我们看到了各种可能的集群数量。请记住，在这种情况下，我们碰巧知道这些数据来自九个地理区域。然而，观察右下方的 scree 图，我们看到在 3 或 4 次之后，组内平方和的减少没有显著改善。作为一种无监督的学习技术，kmeans 向我们展示了这些数据的变化远小于仅基于地理的预期。

img/439480_1_En_7_Fig2_HTML.png

图 7-2

不同数量 k 组的人均国民生产总值和每千名妇女的青少年生育率图

注意图 7-2 中的主要因素似乎是 GNP。因为那是最远的距离，所以说它是决定因素是有道理的。kmeans 的目标是最小化每个组的中心和组成该组的点之间的距离。更仔细地看我们的数据，我们看到我们的两个变量之间的规模相当大的差异。也就是说，一个范围超过一百个左右，另一个超过几千个。

summary(d[,.(NYGN, SPAD)])

##       NYGN            SPAD
##  Min.   :  487   Min.   : 11
##  1st Qu.: 3839   1st Qu.: 21
##  Median : 7060   Median : 38
##  Mean   :13453   Mean   : 45
##  3rd Qu.:19747   3rd Qu.: 53
##  Max.   :55010   Max.   :132

通常，数据的规模可能是相对任意的，并不表明在分析中哪个变量应该给予更大的权重。解决这类问题的一种方法是通过居中和缩放。中心数据从每个特征中减去数据的平均值，因此每个特征的平均值等于零。缩放将我们的数据除以每个特征的标准偏差，因此也有一个标准范围。base R中的scale()函数为我们处理这两种操作，并处理矩阵或数据框和数据表样式的数据。

x <- scale(d[,.(NYGN, SPAD)])
summary(x)

##       NYGN            SPAD
##  Min.   :-0.92   Min.   :-1.04
##  1st Qu.:-0.68   1st Qu.:-0.74
##  Median :-0.46   Median :-0.21
##  Mean   : 0.00   Mean   : 0.00
##  3rd Qu.: 0.45   3rd Qu.: 0.26
##  Max.   : 2.96   Max.   : 2.72

现在我们可以重现上次绘制的图表，但使用的是我们缩放后的数据。这表明现在 y 轴高度是分组中的一个区分符(图 7-3 )。

img/439480_1_En_7_Fig3_HTML.png

图 7-3

不同数量 k 组的人均国民生产总值和每千名妇女的青少年生育率图

set.seed(2468)
wgss <- vector("numeric", 8)
plots <- vector("list", 9)
p1 <- ggplot(d, aes(NYGN, SPAD))

for(i in 2:9) {
  km <- kmeans(x, centers = i)

  wgss[i - 1] <- km$tot.withinss

  plots[[i - 1]] <- p1 +
    geom_point(aes_(colour = factor(km$cluster))) +
    scale_color_viridis(discrete = TRUE) +
    theme(legend.position = "none") +
    ggtitle(paste("kmeans centers = ", i))
}

plots[[9]] <- ggplot() +
  geom_point(aes(x = 2:9, y = wgss)) +
  xlab("Number of Clusters") +
  ylab("Within SS") +
  ggtitle("Scree Plot")

do.call(plot_grid, c(plots, ncol = 3))

通过缩放我们的数据，我们使 kmeans 更有可能根据 y 轴的生育率高度来识别各组，尽管在我们图表的左侧仍然很清楚，除了 GNP 之外，肯定还有一些因素可以解释各种生育率。同样，尽管规模很大，但我们从 scree 图中可以看出，“逻辑”组可能比我们选择的九个区域要少。事实上，如果我们稍微思考一下现实世界的地理情况，我们可能会决定六个组可能是最大值，并且查看各种 kmeans 图和 scree 图可能会向我们显示，在 6 之后，组内总平方和值的改善相对较小，甚至四个组也可能足够接近数据。

然而，假设我们决定将中心数设为 6，让我们看看将默认的最大迭代次数从 10 改变会得到什么。虽然在分组中有一些细微的差异，但我们真正注意到的是我们的视觉检查告诉我们的，无论如何，最右边的那个组是相当稀疏定义的(因此它切换组，因为它缺乏强信号)。最大迭代次数控制算法在排序过程中运行的次数。

kmeans取一组被称为质心的 k 随机起始点，然后根据哪个质心与该观测值的欧氏距离最小，为每个值(观测值)分配聚类成员。从那里，每个聚类中的所有点被用于计算新的质心，该质心现在位于该聚类的中心。所以现在有了第二代 k 形心，这意味着每一个点都要再次对照每个形心进行检查，并根据最小欧几里得距离分配聚类成员。如果组成员发生变化，那么每个聚类中的点将用于计算该组的中心，这将成为新的质心，我们现在有了第三代质心。重复该过程，直到组成员不再有变化或者达到最大迭代次数。在这种情况下，似乎由于弱信号，我们有一些点可以向任何一个方向移动，因此连续的迭代会导致一些成员关系的转换。结果如图 7-4 所示。

img/439480_1_En_7_Fig4_HTML.png

图 7-4

不同迭代次数下每 1 000 名妇女的人均国民生产总值和青少年生育率图

set.seed(2468)
plots <- vector("list", 9)
p1 <- ggplot(d, aes(NYGN, SPAD))

for(i in 6:14) {
  km <- kmeans(x, centers = 6, iter.max = i)

  plots[[i - 5]] <- p1 +
    geom_point(aes_(colour = factor(km$cluster))) +
    scale_color_viridis(discrete = TRUE) +
    theme(legend.position = "none") +
    ggtitle(paste("kmeans iters = ", i))
}

do.call(plot_grid, c(plots, ncol = 3))

最后一个在kmeans()中定期修改的形式参数是nstart。kmeans 通过测量每个点到组中心的距离来计算组，并试图在每次迭代中使距离测量值变小。然而，对于第一代，在开始时，它会随机设置 k 个中心。因此，nstart决定了有多少不同的随机化竞争成为第一代 k 质心。该算法选择最佳选择作为开始第一代和运行下一次迭代的位置。尽管如此，在本例中，我们没有发现任何重大变化，如图 7-5 所示。

img/439480_1_En_7_Fig5_HTML.png

图 7-5

不同 nstart 值的人均国民生产总值和每 1 000 名妇女的青少年生育率图

set.seed(2468)
plots <- vector("list", 9)
p1 <- ggplot(d, aes(NYGN, SPAD))

for(i in 1:9) {
  km <- kmeans(x, centers = 6, iter.max = 10, nstart = i)

  plots[[i]] <- p1 +
    geom_point(aes_(colour = factor(km$cluster))) +
    scale_color_viridis(discrete = TRUE) +
    theme(legend.position = "none") +
    ggtitle(paste("kmeans nstarts = ", i))
}

do.call(plot_grid, c(plots, ncol = 3))

虽然这些示例是在二维空间中完成的，但是我们可以在更高维的数据上执行 kmeans 聚类。虽然不可能通过二维图显示所有 11 个变量，但我们仍然可以观察 scree 图并确定最佳组数。我们执行与之前相同的计算，只是这次只绘制了碎石图。

x <- scale(d[,-c(1,2)])
wgss<-0
set.seed(2468)
for( i in 1:11){
  km <- kmeans(x, centers = i)
  wgss[i]<-km$tot.withinss
}

ggplot() +
  geom_point(aes(x = 1:11, y = wgss)) +
  xlab("Number of Clusters") +
  ylab("Within SS") +
  ggtitle("Scree Plot - All Variables")

根据图 7-6 中的碎石图，我们确定了完整数据集的最佳组数。在这种情况下，我们可能选择 4，现在最后一次运行算法，看看分组会发生什么。结果存储在kmAll变量中，我们使用cbind()以及我们的国家名称和年份将这些结果绑定到我们的数据。

img/439480_1_En_7_Fig6_HTML.png

图 7-6

所有人的屏幕图

kmAll <- kmeans(x, centers = 4, nstart = 25)
x <- cbind(d[, c(1,2)], x,
           Cluster = kmAll$cluster)
tail(x)

##     CntN Year  NYGD  NYGN SEPR ERMA SESC FEMA SPAD SPDY FEIN MAIN
## 1: Sb-SA 2009 -0.89 -0.87  2.4  2.3 -1.5 -1.5  2.2 1.11 -2.2 -2.2
## 2: Sb-SA 2010 -0.87 -0.87  2.5  2.4 -1.5 -1.5  2.1 0.95 -2.1 -2.1
## 3: Sb-SA 2011 -0.86 -0.86  2.4  2.3 -1.4 -1.4  2.1 0.81 -2.0 -2.0
## 4: Sb-SA 2012 -0.85 -0.84  2.4  2.3 -1.3 -1.4  2.0 0.68 -1.9 -1.9
## 5: Sb-SA 2013 -0.85 -0.84  2.4  2.3 -1.3 -1.3  1.9 0.56 -1.8 -1.8
## 6: Sb-SA 2014 -0.85 -0.83  2.4  2.3 -1.3 -1.4  1.9 0.45 -1.7 -1.7
##    SPPO Cluster
## 1:  2.2       1
## 2:  2.2       1
## 3:  2.2       1
## 4:  2.2       1
## 5:  2.1       1
## 6:  2.1       1

如果我们交叉列表显示病例属于一个国家和一个特定群集的频率，我们可以看到一些区域相当一致，而其他区域似乎偶尔改变群集。

xtabs(~ CntN + Cluster, data = x)

##        Cluster
## CntN     1  2  3  4
##   ArbWr  0 18  0  0
##   CEatB  0  0  0 18
##   Er&CA  0  0  1 17
##   ErpnU  0  0 11  7
##   EsA&P  0 14  0  4
##   LtA&C  0 18  0  0
##   ME&NA  0 18  0  0
##   NrthA  0  0 18  0
##   Sb-SA 18  0  0  0

这是否意味着我们的算法失败了？首先，由于这是无监督的学习，答案很可能是，即使特定的地理区域没有被数据完全再现，经验结构仍然可以告诉我们一些有用的东西。此外，在这种情况下，我们的数据确实有时间成分。当我们按时间检查结果时，我们看到随着时间的推移，这种变化是一致的，一个区域切换集群成员。

unique(x[
  order(CntN, Year, Cluster),
  .(CntN, Year, Cluster)][
    CntN=="EsA&P"])

##      CntN Year Cluster
##  1: EsA&P 1997       2
##  2: EsA&P 1998       2
##  3: EsA&P 1999       2
##  4: EsA&P 2000       2
##  5: EsA&P 2001       2
##  6: EsA&P 2002       2
##  7: EsA&P 2003       2
##  8: EsA&P 2004       2
##  9: EsA&P 2005       2
## 10: EsA&P 2006       2
## 11: EsA&P 2007       2
## 12: EsA&P 2008       2
## 13: EsA&P 2009       2
## 14: EsA&P 2010       2
## 15: EsA&P 2011       4
## 16: EsA&P 2012       4
## 17: EsA&P 2013       4
## 18: EsA&P 2014       4

unique(x[
  order(CntN, Year, Cluster),
  .(CntN, Year, Cluster)][
    CntN == "ErpnU"])

##      CntN Year Cluster
##  1: ErpnU 1997       4
##  2: ErpnU 1998       4
##  3: ErpnU 1999       4
##  4: ErpnU 2000       4
##  5: ErpnU 2001       4
##  6: ErpnU 2002       4
##  7: ErpnU 2003       4
##  8: ErpnU 2004       3
##  9: ErpnU 2005       3
## 10: ErpnU 2006       3
## 11: ErpnU 2007       3
## 12: ErpnU 2008       3
## 13: ErpnU 2009       3
## 14: ErpnU 2010       3
## 15: ErpnU 2011       3
## 16: ErpnU 2012       3
## 17: ErpnU 2013       3
## 18: ErpnU 2014       3

正如我们所看到的，kmeans()是一种将相似案例分组在一起的方法，尽管我们的数据出于教学目的而被标记，但并不要求我们的数据有标签。使用 scree 图和for循环，可以确定合理的最佳聚类，以便将数据组织到相似的组中。在某种程度上，这是探索性数据分析的最后一步，因为结果可能会对您组织的客户或您研究的参与者有所启发。但是，请记住，未缩放的数据可能会对某些维度赋予不同的权重，并且算法的目标是最小化欧几里德距离，这可能不会产生人眼可能看到的相同的明显分组。

7.3 分级集群

虽然kmeans开始时选择k个任意中心，并将每个点分配到最近的中心，然后重复该过程一定次数，但层次聚类是不同的。取而代之的是，每个点被分配到它自己唯一的簇中——你有多少个点就有多少个组！然后，确定每个点之间的距离，并找到最近的邻居。邻居然后加入一个更大的群体。这个过程一直重复，直到最后两个超群合并成一个大群。

因为这依赖于距离，所以第一步是计算每个点与其他每个点的距离。距离函数再次默认为欧几里德距离。因此，在最基本的情况下，这也需要连续的数字数据。然而，可以编写定制的距离函数，允许其他类型的“距离”只要输出是距离矩阵，其中较大的数字表示较大的距离，该算法将进行处理(尽管该处理的功效当然不能保证)。

第一阶段是对我们的数据使用dist()函数。为了建立我们的直觉，我们只使用二维数据。

hdist <- dist(d[,.(NYGN, SPAD)])
str(hdist)

##  'dist' num [1:13041] 1.13 22.04 100.03 186.5 166.08 ...
##  - attr(*, "Size")= int 162
##  - attr(*, "Diag")= logi FALSE
##  - attr(*, "Upper")= logi FALSE
##  - attr(*, "method")= chr "euclidean"
##  - attr(*, "call")= language dist(x = d[, .(NYGN, SPAD)])

生成的对象编码了 2D 数据集中每个点之间的相对距离。该信息被传递给hclust()函数，该函数创建了我们的层次集群，可以通过调用plot()来绘制该集群。这是一个树状图，每个线段的高度显示了我们数据的任意两行/观察值之间的距离。该图如图 7-7 所示。

img/439480_1_En_7_Fig7_HTML.png

图 7-7

带行号的聚类树状图

hclust <- hclust(hdist)
plot(hclust)

请注意，这里使用了行名，在这种情况下，行名是数字，没有太大的帮助。我们可以设置一个关键列，以便更好地理解这个树状图。虽然这不是最清晰的图，但人们确实注意到，在图 7-8 中，相似的区域似乎经常彼此紧密相连。

img/439480_1_En_7_Fig8_HTML.png

图 7-8

通过 ape 包改变树状图

x <- d[, .(CntN, Year, NYGN, SPAD)]
x[, Key := paste(CntN, Year)]
x[, CntN := NULL]
x[, Year := NULL]

hdist <- dist(x[,.(NYGN, SPAD)])
hclust <- hclust(hdist)
plot(hclust, labels = x$Key)

现在，虽然kmeans可能更简单，但它显示了一个最终结果，即一个人选择多少组就有多少组。因此，scree 图对于确定多少个集群可能有意义是有价值的。在这里，每一行都从自己的组开始，然后每一个邻居都被系统地连接成对。

高度向我们显示了任何两个相连组之间的距离。此外，请注意，对于给定的高度，我们可以了解我们的数据适合多少“组”。

plot(hclust, labels = x$Key)
abline(h = 30000, col = "blue")

在h = 30,000的高度，如图 7-9 所示，我们只有两组。一组包括北美(NrtA)和 2000 年代的大部分欧盟国家(普尔)，而另一组包括其余国家。看一下摘要以及对我们的父数据的几个数据表调用表明，主要高度(记住，这是基于欧几里德距离的)可能是 GNP (NYGN)。请注意，这很好地说明了为什么一旦我们完成了探索性的工作，扩展我们的数据仍然很重要。如果我们不努力确保数据列大致相等，GNP (NYGN)之类的东西可能会淹没其他显著特征。

img/439480_1_En_7_Fig9_HTML.png

图 7-9

带有国家名称、年份和高度线的聚类树状图

summary(x)

##       NYGN            SPAD         Key
##  Min.   :  487   Min.   : 11   Length:162
##  1st Qu.: 3839   1st Qu.: 21   Class :character
##  Median : 7060   Median : 38   Mode  :character
##  Mean   :13453   Mean   : 45
##  3rd Qu.:19747   3rd Qu.: 53
##  Max.   :55010   Max.   :132

d[, mean(NYGN), by = CntN][order(V1)]

##     CntN    V1
## 1: Sb-SA   953
## 2: ArbWr  4260
## 3: ME&NA  5045
## 4: EsA&P  5801
## 5: LtA&C  6004
## 6: CEatB  8531
## 7: Er&CA 19021
## 8: ErpnU 28278
## 9: NrthA 43188

d[, mean(SPAD), by = CntN][order(V1)]

##     CntN  V1
## 1: ErpnU  15
## 2: EsA&P  20
## 3: CEatB  23
## 4: Er&CA  23
## 5: NrthA  37
## 6: ME&NA  40
## 7: ArbWr  52
## 8: LtA&C  73
## 9: Sb-SA 120

调整我们的abline()的高度允许我们改变我们查看数据的方式，现在它在四个集群中。现在，特别是在书本形式中，很难清晰地打印出如此大的图表，尽管我们最好的尝试是在图 7-10 中。试着在你自己的机器上运行代码，记住我们还处于探索阶段。这有助于我们理解国家之间的相似性，以及这两个维度的结构。

img/439480_1_En_7_Fig10_HTML.png

图 7-10

带有国家名称、年份和另一条高度线的聚类树状图

plot(hclust, labels = x$Key)
abline(h = 20000, col = "blue")

考虑到维度，认识到这个模型非常适合可视化整个数据集——在所有列上。它只需要对我们的代码做一点小小的调整，而不是将变量限制为两个。当然，高度测量将发生巨大变化，因为我们现在有一个更大的空间来填充我们的欧几里德距离。此外，如图 7-11 所示，最后两个分组将撒哈拉以南非洲(S-SA)与我们的其他地区联系在一起。

img/439480_1_En_7_Fig11_HTML.png

图 7-11

带有国家名称、年份和所有维度数据的聚类树状图

x <- copy(d)
x[, Key := paste(CntN, Year)]
x[, CntN := NULL]
x[, Year := NULL]

hdist <- dist(x[, -12])
hclust <- hclust(hdist)

plot(hclust, labels = x$Key)

现在，hclust函数将距离矩阵作为第一个形式参数，将方法类型作为第二个形式参数。第二个形式参数默认为“complete ”,它使用聚类点之间的最大距离来确定组距离，然后总是根据该最大距离对最近的组进行分组。其他方法将产生不同的结果，因为它们选择使用其他方法(例如最小化类内方差的迭代增加)。请注意，这里我们没有刷新我们的hdist矩阵——我们只是简单地改变了使用的方法。结果如图 7-12 所示。

img/439480_1_En_7_Fig12_HTML.png

图 7-12

使用 ward 聚类树图。D2 方法

hclust <- hclust(hdist, method = "ward.D2")
plot(hclust, labels = x$Key)

值得注意的是，欧几里德距离可以被替换为一些其他的距离度量；事实上，有几个内置选项。除了内置函数之外，在不太深奥的情况下，使用一些对推文进行情感分析的函数来确定某个特定趋势标签有多少组意见可能是有意义的。当然，一旦情感分析被转换成一些数字，在这些数字上使用欧几里德距离也许是有意义的。在任何情况下，关键是，不要求数据从数字级别开始。

如前所述，尤其是当我们在分析中增加更多维度时，如果不调整数据，范围最大的列将对我们的分组产生巨大的影响。缩放后，使用所有变量并重新绘图，结果如图 7-13 所示。

img/439480_1_En_7_Fig13_HTML.png

图 7-13

带标度的聚类树状图

x <- scale(d[,-c(1,2)])
row.names(x) <- paste(d$CntN, d$Year)
hdist <- dist(x)
hclust <- hclust(hdist)

plot(hclust, labels = paste(d$CntN, d$Year))
abline(h = 6, col = "blue")

现在，虽然我们可以选择根据一定的高度来砍伐我们的树，但这只是直观地向我们展示了我们的群体是如何排列的。我们还可以使用cutree()函数在某个高度对我们的数据进行聚类。在 h = 6 的情况下，这将我们的树分成三组，我们可以看到这个函数给了我们。

cut_hclust <- cutree(hclust, h = 6)
unique(cut_hclust)

## [1] 1 2 3

或者，不是在特定的高度上切割，而是在一定数量的簇上切割。通过创建数据的副本，我们可以在名为 cluster 的新列中记录集群分配。

dcopy <- as.data.table(copy(d))
dcopy[, cluster:= NA_integer_]

dcopy$cluster <- cutree(hclust, k = 3)

tail(dcopy)

##     CntN Year NYGD NYGN    SEPR    ERMA SESC FEMA SPAD SPDY FEIN MAIN
## 1: Sb-SA 2009 1198 1186 1.9e+07 1.6e+07  8.2  9.4  115 11.5   58   55
## 2: Sb-SA 2010 1555 1287 2.0e+07 1.6e+07  8.3  9.4  113 11.0   58   55
## 3: Sb-SA 2011 1706 1412 1.9e+07 1.5e+07  8.4  9.6  111 10.7   59   56
## 4: Sb-SA 2012 1740 1631 1.9e+07 1.6e+07  8.6  9.7  109 10.3   60   57
## 5: Sb-SA 2013 1787 1686 1.9e+07 1.5e+07  8.9  9.9  107 10.0   61   57
## 6: Sb-SA 2014 1822 1751 1.9e+07 1.6e+07  8.7  9.7  105  9.7   61   58
##    SPPO cluster
## 1:   89       3
## 2:   89       3
## 3:   88       3
## 4:   88       3
## 5:   87       3
## 6:   87       3

为了结束我们关于层次化集群的部分，我们提到了ape包，它有几个可视化选项，可以显示默认情况下由plot()提供的树状图。诚然，用较少的类别来可视化模型更容易。请记住，在无监督学习的通常应用中，一个自然的目标是确定合理存在多少个类别。所以我们的教学例子将不仅仅是有点笨拙，正是因为我们保持了一个相当广泛的，固定的类别集。我们在图 7-14 中展示了结果。

img/439480_1_En_7_Fig14_HTML.png

图 7-14

通过 ape 包改变树状图

plot(as.phylo(hclust), type = "cladogram")

plot(as.phylo(hclust), type = "fan")

plot(as.phylo(hclust), type = "radial")

分级聚类的部分优势在于，它们可以是一种可视化观察结果之间的相似性和不相似性的方式。作为这个过程的一部分，将树分成清晰的组可能是一个有用的步骤。现在，基于我们早期的 kmeans 分析，我们相信可能有四个重要的组，所以我们尝试可视化。这里，cutree()的第二个形式参数被设置为用k = 4期望的集群数。此外，as.phylo()函数用于将我们的hclust对象转换成供ape包使用的对象类型(一个phylo对象)。我们展示了一种新的图表类型— unrooted—和一个label.offset，它在我们的标签和图表之间提供了一些距离(从而在我们的人类友好但适合图表不友好标签的字符之间创建了一些非常重要的空间)。最后，我们在tip.color参数中引入cutree()信息，并用cex缩小文本的放大倍数。最终结果如图 7-15 所示。

img/439480_1_En_7_Fig15_HTML.png

图 7-15

通过 ape 包改变树状图

hclust4 <- cutree(hclust, k = 4)
plot(as.phylo(hclust), type = "unrooted", label.offset = 1,
     tip.color = hclust4, cex = 0.8)

请注意，该图本身是基于原始的层次聚类模型的—只有尖端的颜色用于将我们的数据分组为配对(但是这些配对在该图中是有意义的)。

img/439480_1_En_7_Fig16_HTML.png

图 7-16

通过 ape 包改变树状图

7.4 主成分分析

到目前为止，在无监督学习中，我们已经看到了两种技术来了解我们的数据中有多少组或簇。一个是kmeans，它被预先告知应该找到多少个组(可能基于 scree plot 分析)。另一个是hclust，将每个观察结果放在单个组中，然后最终将这些点连接起来，直到只有一个组。分析员要看哪些观察值最接近，哪些子群最接近。主成分分析(PCA)也试图以某种方式确定组。PCA 将数据分解成独特的(即不相关的、独立的、正交的)分量。例如，在我们的数据集中，我们可以想象 GDP 和 GNP 在某种程度上是相关的。其实它们是高度相关的！这些本质上都是一样的。甚至他们的范围和手段都相当接近，如图 7-18 所示。

img/439480_1_En_7_Fig17_HTML.png

图 7-17

四个集群上的无根类型

cor(d$NYGD, d$NYGN)

## [1] 1

summary(d[,.(NYGD, NYGN)])

##       NYGD            NYGN
##  Min.   :  496   Min.   :  487
##  1st Qu.: 3761   1st Qu.: 3839
##  Median : 7458   Median : 7060
##  Mean   :13616   Mean   :13453
##  3rd Qu.:19708   3rd Qu.:19747
##  Max.   :54295   Max.   :55010

ggplot(d, aes(NYGD, NYGN)) +
  geom_point()

从视觉上看，图 7-18 本质上是直线 y = x 。主成分分析可以认为是一种分组操作。分组的目的是看看我们有多少真正的独特维度。在这种情况下，虽然看起来我们在数据集中有两个不同的列，但事实是我们实际上只有一个唯一信息列(维度)似乎是合理的。

img/439480_1_En_7_Fig18_HTML.png

图 7-18

一个高度相关的图——这里真的有二维吗？

主成分分析(PCA)允许我们做的是确定我们不需要两列，并以有原则的方式将它们组合成一个维度。这将简化我们的特征空间，正如我们所看到的，不会导致太多的信息损失。另一方面，如果我们看看其他一些变量，我们会发现简单地删除一列以支持另一列是没有意义的。即使它们高度相关，仍然清楚的是，有时，特别是在某一点上，SE.SCH.Life.FE (SESC)有相当多的变化，而 GDP(纽约市)变化很小，如图 7-19 所示。显然，这里有不止一个维度的信息。

img/439480_1_En_7_Fig19_HTML.png

图 7-19

一个高度相关的图——这里真的有二维吗？

ggplot(d, aes(NYGD, SESC)) +
  geom_point()

cor(d$NYGD, d$SESC)

## [1] 0.79

与 PCA 相关的技术是因子分析(FA)。这两种方法都具有探索性，因为数据的真实维度是未知的，尽管存在验证性 FA，其目标是测试假设的维度。此外，PCA 和 FA 都试图找到一个更低维的空间来提供数据的合理近似。但是，PCA 和 FA 也有很多不同之处。它们来自不同的理论背景，对主成分(PCA)和因子(FA)的解释也不相同，对数据的基本假设也不同。一个显著的区别是 FA 通常关注变量间的共享方差，而 PCA 包含共享和唯一方差。这种差异是由于 PCA 和 FA 的基础和目标不同。FA 来源于心理测量学的传统，通常与专门设计的测试一起使用，例如，分析考试中的不同问题或旨在测量智商或评估某些心理结构的多个问题。在一次考试中，所有问题的目标是提供一个学生对课程整体理解的指数，这是无法直接观察到的。与任何给定测试问题特有的方差相比，问题间共享的方差被认为是整体理解的更好指标，任何给定测试问题特有的方差可能代表措辞不当的问题、某个特定概念的糟糕教学或对特定概念缺乏理解。在 PCA 中，目标通常是用尽可能少的维度再现更高维的空间。因此，如果考试中的一个问题与任何其他问题没有太多重叠，PCA 不会认为这是整体表现的潜在不良指标，而是认为这是另一个需要的独特维度。一般来说，PCA 在机器学习中使用得更多，因为它较少建立在任何特定的理论或信念上，即一组项目应该有一些共享的重叠，并且因为使用 PCA 通常更容易包括足够多的成分，使得原始数据几乎可以完美地恢复，但是是从更小的维度集恢复。

PCA 所做的是查看我们的数据，并将左右移动数据的部分与上下移动数据的部分分开，换句话说，分成主要成分。如果你有线性代数的背景，标准 PCA 是协方差(或者如果标准化，相关性)矩阵的特征值分解。无论如何，我们都要回到我们的主题，看看我们感兴趣的两列。再次参考这两部的原著剧情。

pca()函数既有对scale数据的参数，如果设置为“uv ”,则将方差设置为 1(单位方差),如果设置为TRUE,则将数据设置为零center。传统类型的 PCA 基于特征值和奇异值分解(SVD)，因此对于传统 PCA，我们告诉pca()函数使用method = "svd"。

首先，我们只收集国民生产总值的原始数据。PCAP 对阿多。TFRT 进入我们的工作数据集，x。计算主成分分析非常简单，我们可以立即缩放和集中我们的数据，并使用奇异值分解来估计传统的主成分分析。summary()函数向我们显示了每个主成分可以单独解释总方差的多少，另一行显示了解释的累积方差。在只有两个变量的情况下，100%的方差， R 2 = 1，可以用两个主成分来解释。

x <- d[,.( NYGN, SPAD)]
res <- pca(x, method="svd", center=TRUE, scale = "uv")

summary(res)

## svd calculated PCA
## Importance of component(s):
##                  PC1    PC2
## R2            0.7213 0.2787
## Cumulative R2 0.7213 1.0000

为了将我们的结果可视化，我们可以创建一个图表，显示原始数据是如何转换为双标图的，如图 7-20 所示。你能认出正交旋转吗？当然，不仅仅是轮换在起作用。PC1 变量是可以用一条直线解释的最大方差。差异的剩余部分预计到 PC2。biplot()函数显示新空间中原始数据值的向量。

img/439480_1_En_7_Fig20_HTML.png

图 7-20

原始数据和主成分分析的比较

biplot(res, main = "Biplot of PCA")

接下来，我们将检查当我们使用所有变量进行 PCA 时会发生什么。我们可以绘制一个 scree 图，看看当我们添加额外的主成分时，精度如何提高，作为一种尝试确定需要多少成分才能充分代表数据中的基本维度的方法。我们为数据中的列数设置了一个额外的参数,nPcs,,这是我们可能需要的主成分的最大可能数量，尽管如果我们数据的真实维度更少，那么很少的成分可能足以代表数据。

我们使用图 7-21 中的plot()函数绘制了从较少维度恢复的原始信息的比例图，这是一种反向 scree 图。再次查看 scree 图，我们会发现这里实际上只有 4 个维度的独特数据，即使只有一个维度也能够捕捉 11 个变量中超过一半的方差。

img/439480_1_En_7_Fig21_HTML.png

图 7-21

数据中所有特征的传统 PCA 的 Scree 图

x <- d[, -c(1,2)]
res <- pca(x, method="svd", center=TRUE, scale = "uv",
           nPcs = ncol(x))

summary(res)

## svd calculated PCA
## Importance of component(s):
##                  PC1    PC2     PC3     PC4     PC5     PC6    PC7
## R2            0.7278 0.1614 0.06685 0.02554 0.01226 0.00447 0.0011
## Cumulative R2 0.7278 0.8892 0.95607 0.98161 0.99387 0.99834 0.9994
##                   PC8    PC9  PC10  PC11
## R2            0.00021 0.0002 1e-04 5e-05
## Cumulative R2 0.99965 0.9999 1e+00 1e+00

## reverse scree plot
ggplot() +
  geom_bar(aes(1:11, cumsum(res@R2)),
           stat = "identity") +
  scale_x_continuous("Principal Component", 1:11) +
  scale_y_continuous(expression(R²), labels = percent) +
  ggtitle("Scree Plot") +
  coord_cartesian(xlim = c(.5, 11.5), ylim = c(.5, 1),
                  expand = FALSE)

我们也可以从这个 PCA 创建双绘图，但是一次只能绘制两个组件。图 7-22 显示了前两个组成部分的结果，它们共同解释了大部分的差异。

img/439480_1_En_7_Fig22_HTML.png

图 7-22

前两个主成分的双标图

biplot(res, choices = c(1, 2))

顺便提一下，现在我们在res变量中有了我们的数据，我们可以使用该数据(以及尽可能多的列，比如前四列)来代替我们的原始数据。特别是，如果我们希望执行监督机器学习技术，正如下一章所讨论的，使用 PCA 数据可能会有优势。例如，来自我们的 PCA 的结果表明，我们可以用四个分量捕获所有 11 个原始特征中除 2%之外的所有变化。

使用主成分代替原始特征的优点是主成分是正交的。缺点是，由于每一个主成分分析都可能包含几个原始变量，因此很难准确解释每一个特征意味着什么或代表什么。但是，如果模型的预测能力得到提高或者是唯一的目标，这可能是我们愿意做出的权衡。在某些情况下，它还可以加速模型计算，因为后期分析只需管理较少的要素，从而减少分析所需的内存和计算。

我们使用scores()函数提取主成分得分，查看前几行，然后使用相关矩阵显示它们确实是线性独立的。

head(scores(res))

##       PC1  PC2  PC3   PC4  PC5    PC6   PC7    PC8     PC9     PC10
## [1,] -2.5 -1.2 0.74 -0.31 0.99 -0.075 -0.22 0.0046  0.0015 -0.00660
## [2,] -2.4 -1.2 0.72 -0.31 0.89 -0.057 -0.21 0.0075 -0.0035  0.00095
## [3,] -2.3 -1.3 0.70 -0.29 0.82 -0.047 -0.19 0.0121 -0.0046 -0.00521
## [4,] -2.2 -1.3 0.69 -0.29 0.75 -0.074 -0.18 0.0202 -0.0086 -0.01269
## [5,] -2.0 -1.3 0.66 -0.27 0.70 -0.095 -0.15 0.0290 -0.0149 -0.00243
## [6,] -1.9 -1.4 0.62 -0.25 0.64 -0.104 -0.13 0.0355 -0.0237 -0.00071
##          PC11
## [1,] -9.9e-03
## [2,]  4.7e-06
## [3,]  1.3e-02
## [4,]  1.1e-02
## [5,]  1.3e-02
## [6,]  1.3e-02

round(cor(scores(res)),2)

##      PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8 PC9 PC10 PC11
## PC1    1   0   0   0   0   0   0   0   0    0    0
## PC2    0   1   0   0   0   0   0   0   0    0    0
## PC3    0   0   1   0   0   0   0   0   0    0    0
## PC4    0   0   0   1   0   0   0   0   0    0    0
## PC5    0   0   0   0   1   0   0   0   0    0    0
## PC6    0   0   0   0   0   1   0   0   0    0    0
## PC7    0   0   0   0   0   0   1   0   0    0    0
## PC8    0   0   0   0   0   0   0   1   0    0    0
## PC9    0   0   0   0   0   0   0   0   1    0    0
## PC10   0   0   0   0   0   0   0   0   0    1    0
## PC11   0   0   0   0   0   0   0   0   0    0    1

除了特征值和奇异值分解的传统 PCA 方法外，pca()函数还有多种其他方法可用于各种其他情况。一种这样的方法是robustPca，它改变算法，试图对极端值或异常值更加鲁棒。为了查看其效果，我们将使用相同的数据，使用prep()函数对其进行预缩放，然后创建两个版本，一个没有异常值，一个有异常值。

接下来，我们运行四个主成分分析模型，传统的奇异值分解主成分分析和鲁棒主成分分析。最后，我们使用常规和稳健的 PCA 方法，从无异常值和有异常值的数据中，绘制负载，即用于将原始数据投影到主成分上的值。结果如图 7-23 所示。在该图中，您可以清楚地看到传统 PCA 中的负载如何显著变化，但在鲁棒 PCA 中，异常值的添加对负载几乎没有影响。一般来说，如果您担心您的数据可能有极值或异常值，那么首先清理或删除它们是值得的，或者至少比较传统和稳健 PCA 方法的结果，以确保结果不会对少数极值分数的存在过于敏感。

img/439480_1_En_7_Fig23_HTML.png

图 7-23

使用传统的奇异值分解主成分分析和稳健主成分分析绘制有和没有异常值的主成分分析模型的负荷图

x <- d[, -c(1,2)]
x <- prep(x, center = TRUE, scale = "uv")

xout <- copy(x)
xout[1:5, "NYGD"] <- (-10)

res1 <- pca(x, method = "svd",
            center = FALSE, nPcs = 4)
res2 <- pca(xout, method = "svd",
            center = FALSE, nPcs = 4)

res1rob <- pca(x, method = "robustPca",
               center = FALSE, nPcs = 4)
res2rob <- pca(xout, method = "robustPca",
               center = FALSE, nPcs = 4)
plot_grid(
  ggplot() +

    geom_point(aes(
      x = as.numeric(loadings(res1)),
     y = as.numeric(loadings(res2)))) +
    xlab("Loadings, SVD, No Outliers") +
    ylab("Loadings, SVD, Outliers"),
  ggplot() +
    geom_point(aes(
      x = as.numeric(loadings(res1rob)),
     y = as.numeric(loadings(res2rob)))) +
    xlab("Loadings, Robust PCA, No Outliers") +
    ylab("Loadings, Robust PCA, Outliers"),
    ncol = 1)

7.5 非线性聚类分析

主成分分析的一个常见目标是减少维数，从而简化模型并提高预测精度。PCA 的一个基本假设是在这些较少的维度中存在可感测的线性关系，换句话说，对于 n 个标称维度，存在一些基本的正交向量要被投影，而不会有大的信号损失。如果有理由怀疑情况并非如此，那么非线性方法可能是合适的。

虽然前四行代码在分层集群中很常见，但是MASS包中的sammon()函数获取这些距离，并尝试将更高维度(在我们的示例中为 11 维)映射到k维(在本例中，我们设置 k = 2 以绘制图表)。我们提到这一点的主要目的只是为了观察，在明显非线性关系的情况下，PCA 可能不如放松线性假设的其他方法有效。

x <- scale(d[, -c(1,2)])
row.names(x) <- paste(d$CntN, d$Year)
head(x)

##             NYGD  NYGN SEPR  ERMA SESC FEMA SPAD  SPDY  FEIN  MAIN
## ArbWr 1997 -0.81 -0.79 0.33 0.156 -1.5 -1.4 0.37 -0.66 -0.74 -0.62
## ArbWr 1998 -0.82 -0.79 0.31 0.164 -1.5 -1.3 0.34 -0.71 -0.70 -0.57
## ArbWr 1999 -0.81 -0.79 0.27 0.147 -1.4 -1.2 0.32 -0.75 -0.67 -0.53
## ArbWr 2000 -0.79 -0.79 0.22 0.113 -1.3 -1.2 0.30 -0.78 -0.63 -0.48
## ArbWr 2001 -0.80 -0.78 0.17 0.070 -1.3 -1.2 0.27 -0.81 -0.60 -0.44
## ArbWr 2002 -0.80 -0.78 0.13 0.033 -1.2 -1.1 0.24 -0.84 -0.57 -0.41
##            SPPO
## ArbWr 1997  1.6
## ArbWr 1998  1.4
## ArbWr 1999  1.3
## ArbWr 2000  1.2
## ArbWr 2001  1.1
## ArbWr 2002  1.0

sdist <- dist(x)

xSammon <- sammon(sdist, k = 2)

## Initial stress        : 0.04343
## stress after   7 iters: 0.03619

head(xSammon$points)

##            [,1] [,2]
## ArbWr 1997 -2.6 -1.2
## ArbWr 1998 -2.5 -1.2
## ArbWr 1999 -2.3 -1.3
## ArbWr 2000 -2.2 -1.3
## ArbWr 2001 -2.1 -1.4
## ArbWr 2002 -2.0 -1.4

Sammon 技术试图最小化一个名为stress的度量，该度量试图测量高维对象被“挤压”到低维空间的效率。

如果将前面的代码调整为 k = 3，我们可以预期应力会降低。图 7-24 显示了使用 Sammon 将 11 维减少到只有 2 维的结果。

img/439480_1_En_7_Fig24_HTML.png

图 7-24

带文本标签的 Sammon 点图

plot(xSammon$points, type = "n")
text(xSammon$points, labels = row.names(x) )

7.6 摘要

在这一章中，我们发展了无监督机器学习的概念。虽然采用这种技术的数据通常是未标记的，但在这种情况下，我们用标记数据进行了演示，以便对我们可能预期的聚类或分组类型有所了解。常用的技术kmeans和hclust与标准欧几里德距离一起使用(从而将我们限制在数字数据)。然而，这些强大的技术使我们能够理解在一个复杂的多维数据集中可能有多少真正的组。最后，介绍了降维的概念，使用主成分分析作为最常用的方法，同时以简单的观察结束，即主成分分析的线性假设可以通过更复杂的技术放宽。表 7-2 中概述了本章使用的一些功能，并简要介绍了它们的作用。

表 7-2

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| read_excel() | 将文件路径作为字符串，并读入 Excel 文件 |
| as.data.table() | 将 data.frame 转换为 data.table 对象 |
| str() | 显示了 R 中对象的底层结构 |
| summary() | 尝试对数据或模型对象进行统计汇总 |
| melt() | 将宽数据转换为长数据 |
| dcast() | 将熔化的长数据转换为宽格式 |
| sort() | 按升序对数据进行排序 |
| unique() | 删除重复项 |
| plot() | 数据和模型结果的一般绘图 |
| set.seed() | 允许为伪随机算法复制代码 |
| kmeans() | 运行 kmeans 算法 |
| scale() | 在平均值= 0 时将数据按列居中，并调整到单位标准偏差 |
| for() | 调用迭代器上的 for 循环操作 |
| cbind() | 通过列将数据绑定在一起 |
| dist() | 创建一个距离矩阵，显示每个元素与其他元素之间的欧几里德距离 |
| hclust() | 创建分层集群对象 |
| abline() | 在绘图对象上绘制一条线 |
| row.names() | 允许访问 data.frame 行名属性 |
| cutree() | 按高度或簇切割层次树对象 |
| tail() | 显示最后六行数据 |
| copy() | 复制数据对象，而不仅仅是通过引用指定一个新名称 |
| as.phylo() | 创建一个 phylo 对象—用于 ape 包绘图 |
| cor() | 显示项目之间的相关性 |
| pca() | 执行 PCA 简化计算 |
| scores() | 提取主成分得分 |
| loadings() | 提取主成分载荷，用于将原始数据投影到主成分空间 |
| biplot() | 在 PC1 和 PC2 上绘制 PCA 图并显示原始数据向量 |
| sammon() | 非线性降维算法；第二种形式是新的维度 |
| text() | 地块对象上的文字标签 |

八、ML：监督机器学习和分类

在前一章中，数据被输入一个算法，然后该算法试图对常见类型的数据进行分组。虽然我们偶尔会保留标签，以便了解算法的执行情况，但在现实生活中，无监督的机器学习是一种探索性分析。有时称为预处理，它通常是一个初始阶段，包括数据的缩放和居中。

通常，目标不是简单的分组，而是使用当前数据预测未来的能力。机器学习的常见目标是训练具有良好预测能力的模型。什么是可接受的预测准确度水平将因应用而异。其中一位作者在一所社区大学工作，在那里，即使对学生的最终字母分数等事情的预测准确性水平很低，也可能允许更相关、更有针对性的干预发生(例如，关于辅导中心时间或分配给导师或教练的短信)。在那种情况下，假阳性的风险可能很小。相反，另一位作者研究健康结果数据，其中假阳性对患者整体健康带来更高水平的可能风险。

对于这一章，新的软件包包括caret [32]，其中包含了用于准备数据和模型开发的有用功能。kernlab包用于支持向量机【49】。结合caret，我们将使用DALEX【11】，这将有助于解释模型(并需要spdep【12】)。以类似的方式，rattle [119]允许额外的可视化。最后，我们还将包RSNNS [10]用于多层感知器模型——一种神经网络。

关于caret的一个注意事项是它不会自动安装特定分析方法所需的软件包。因此，当您逐步完成后面的分析时，预计需要安装一些包。为了减轻这种情况，我们在这里包括了包ranger【124】、e1071【62】、gbm【120】和plyr【110】。

 library(checkpoint)
 checkpoint("2018-09-28", R.version = "3.5.1",
   project = book_directory,
   checkpointLocation = checkpoint_directory,
   scanForPackages = FALSE,
   scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(ggplot2)
library(cowplot)
library(data.table)
library(readxl)
library(viridis)

library(RSNNS)
library(kernlab)
library(rpart)
library(rattle)
library(DALEX)
library(caret)
library(spdep)
library(ranger)
library(e1071)
library(gbm)
library(plyr)
set.seed(1234)

options(width = 70, digits = 2)

8.1 数据准备

对于监督学习的大多数应用，数据需要某种程度的准备。我们使用与上一章相同的初始步骤开始这个过程，读入我们的样本数据集，并将其转换为我们现在熟悉的布局。回想一下,'是标签上方波浪号键上的勾号。

## Note: download Excel file  from publisher website first
dRaw <- read_excel("Gender_StatsData_worldbank.org_ccby40.xlsx")
dRaw <- as.data.table(dRaw) # convert data to data.table format.

dRaw[,'Indicator Name':= NULL]

## collapse columns into a super long dataset
## with Year as a new variable
data <- melt(dRaw, measure.vars = 3:20, variable.name = "Year", variable.factor = FALSE)

## cast the data wide again
## this time with separate variables by indicator code
## keeping a country and time (Year) variable
data <- dcast(data, CountryName + Year ~ IndicatorCode)
rm(dRaw) #remove unneeded variable

#rename columns with shortened, unique names
x<-colnames(data)
x<-gsub("[[:punct:]]", "", x)
(y <- abbreviate(x, minlength = 4, method = "both.sides"))

##   CountryName          Year   NYGDPPCAPCD   NYGNPPCAPCD   SEPRMUNERFE
##        "CntN"        "Year"        "NYGD"        "NYGN"        "SEPR"
##   SEPRMUNERMA   SESCHLIFEFE   SESCHLIFEMA     SPADOTFRT   SPDYNCDRTIN
##        "ERMA"        "SESC"        "FEMA"        "SPAD"        "SPDY"
## SPDYNLE00FEIN SPDYNLE00MAIN     SPPOPDPND
##        "FEIN"        "MAIN"        "SPPO"

names(data) <- y

#shorten regional names to abbreviations.
data$CntN<-abbreviate(data$CntN, minlength = 5, method = "left.kept")

我们再次简要描述表 8-1 中每列数据所代表的内容。

警告:虽然许多现代软件包将执行我们在本节中试图概括和可视化的所有或部分步骤，但它有助于理解某些预处理技术背后的价值。某些度量标准的使用取决于所选的模型和输入模型的基础数据。例如，树方法可以很好地处理字符或因子数据，而传统的线性回归需要数字输入。因此，即使在本章中，期望讨论的每个模型以完全相同的方式使用我们的固定数据集也是没有意义的。因此，当我们通过这些方法工作时，我们将保留data作为上一章工作数据集的持有者。我们将对其副本执行额外的处理，并在合理的情况下返回到data。

表 8-1

性别数据中的列列表

|

变量(特征)

|

描述

|
| --- | --- |
| CountryName &#124; CntN | 地理区域或国家集团的简称 |
| Year &#124; Year | 每个数据的来源年份 |
| SP.ADO.TFRT &#124; SPAD | 青少年生育率(每 1，000 名 15-19 岁女性的出生率) |
| SP.POP.DPND &#124; SPPO | 受抚养年龄比率(占工作年龄人口的百分比) |
| SE.PRM.UNER.FE &#124; SEPR | 失学儿童，小学，女性 |
| SE.PRM.UNER.MA &#124; ERMA | 失学儿童，小学，男性 |
| SP.DYN.CDRT.IN &#124; SPDY | 粗死亡率(每千人) |
| SE.SCH.LIFE.FE &#124; SESC | 预期受教育年限，女性 |
| SE.SCH.LIFE.MA &#124; FEMA | 预期受教育年限，男性 |
| NY.GDP.PCAP.CD &#124; NYGD | 人均国内生产总值(现值美元) |
| NY.GNP.PCAP.CD &#124; NYGN | 人均国民总收入，阿特拉斯法(现值美元) |
| SP.DYN.LE00.FE.IN &#124; FEIN | 女性出生时预期寿命(岁) |
| SP.DYN.LE00.MA.IN &#124; MAIN | 出生时预期寿命，男性(岁) |

一个热编码

我们看到在CntN(地区名称)列中有九种独特的分类数据类型。要将名义数据转换成适用于回归或计算的数据(换句话说就是数字)，基本的技术是从名义类别中创建一组新的列，如果一行不适合，则包含值0，如果一行适合，则包含值1。如果我们有九个值，我们可以创建九列，每列以ArbWr(阿拉伯世界)开始，以S-SA(撒哈拉以南非洲)结束。在这种情况下，每行将有一个1，其余的留在0。这有时被称为one hot encoding。或者，由于我们只有九个选项，我们可以只对前八个选项进行编码。如果前八个都是0，这仍然会向我们的模型发出第九个选项的信号。这种方法有时被称为dummy coding。实际上，这两个术语似乎可以互换使用。不同的型号可能偏好不同的布局。像往常一样，花一些时间从可接受的输入方面理解特定模型的需求。

d <- copy(data)
sort(unique(d$CntN))

## [1] "ArbWr" "CEatB" "Er&CA" "ErpnU" "EsA&P" "LtA&C" "ME&NA" "NrthA"
## [9] "Sb-SA"

我们使用来自caret的dummyVars函数为我们执行一个热编码。这个函数接受一个常用的R公式的输入，这里我们要求它对整个数据集进行操作，而不是只对其中的一部分进行操作。该函数将忽略数字数据，但它将转换字符和因子数据。从str函数可以看出，我们的年份信息是一个字符类型。如果不加处理，年份也会被虚拟编码。在这种情况下，我们继续转换到数字，希望有一个体面的适合没有。不可否认，目前这仅仅是基于保持低的总列数的愿望。

str(d)

## Classes 'data.table' and 'data.frame':      162 obs. of  13 variables:
##  $ CntN: chr  "ArbWr" "ArbWr" "ArbWr" "ArbWr" ...
##  $ Year: chr  "1997" "1998" "1999" "2000" ...
##  $ NYGD: num  2299 2170 2314 2589 2495 ...
##  $ NYGN: num  2310 2311 2288 2410 2496 ...
##  $ SEPR: num  6078141 5961001 5684714 5425963 5087547 ...
##  $ ERMA: num  4181176 4222039 4131775 3955257 3726838 ...
##  $ SESC: num  8.08 8.27 8.5 8.65 8.84 ...
##  $ FEMA: num  9.73 9.82 9.97 10.02 10.12 ...
##  $ SPAD: num  56.6 55.7 54.9 54.2 53.3 ...
##  $ SPDY: num  6.8 6.68 6.57 6.48 6.4 ...
##  $ FEIN: num  68.7 69 69.3 69.6 69.8 ...
##  $ MAIN: num  65 65.3 65.7 65.9 66.2 ...
##  $ SPPO: num  79.1 77.7 76.2 74.7 73.2 ...
##  - attr(*, ".internal.selfref")=<externalptr>

d[,Year:=as.numeric(Year)]

ddum <- dummyVars("~.", data = d)
d <- data.table(predict(ddum, newdata = d))
rm(ddum) #remove ddum as unneeded
str(d)

## Classes 'data.table' and 'data.frame':    162 obs. of  21 variables:

##  $ CntNArbWr: num  1 1 1 1 1 1 1 1 1 1 ...
##  $ CntNCEatB: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNEr&CA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNErpnU: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNEsA&P: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNLtA&C: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNME&NA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNNrthA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNSb-SA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ Year     : num  1997 1998 1999 2000 2001 ...
##  $ NYGD     : num  2299 2170 2314 2589 2495 ...
##  $ NYGN     : num  2310 2311 2288 2410 2496 ...
##  $ SEPR     : num  6078141 5961001 5684714 5425963 5087547 ...
##  $ ERMA     : num  4181176 4222039 4131775 3955257 3726838 ...
##  $ SESC     : num  8.08 8.27 8.5 8.65 8.84 ...
##  $ FEMA     : num  9.73 9.82 9.97 10.02 10.12 ...
##  $ SPAD     : num  56.6 55.7 54.9 54.2 53.3 ...
##  $ SPDY     : num  6.8 6.68 6.57 6.48 6.4 ...
##  $ FEIN     : num  68.7 69 69.3 69.6 69.8 ...
##  $ MAIN     : num  65 65.3 65.7 65.9 66.2 ...
##  $ SPPO     : num  79.1 77.7 76.2 74.7 73.2 ...
##  - attr(*, ".internal.selfref")=<externalptr>

缩放和居中

准备工作的第二阶段是根据上一章提到的原因对我们的数据进行缩放和集中。简而言之，这些原因是为了防止可能具有较长射程的某些组件意外超重。我们不缩放前九列，它们是我们的虚拟编码列。我们将使用cbind重新添加这些列。

dScaled<-scale(d[,-c(1:9)])
dScaled<-as.data.table(dScaled)
d <- cbind(d[,c(1:9)], dScaled)
rm(dScaled) #remove d2 as unneeded
str(d)

## Classes 'data.table' and 'data.frame':   162 obs. of  21 variables:
##  $ CntNArbWr: num  1 1 1 1 1 1 1 1 1 1 ...
##  $ CntNCEatB: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNEr&CA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNErpnU: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNEsA&P: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNLtA&C: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNME&NA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNNrthA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ CntNSb-SA: num  0 0 0 0 0 0 0 0 0 0 ...
##  $ Year     : num  -1.633 -1.441 -1.249 -1.057 -0.865 ...
##  $ NYGD     : num  -0.813 -0.822 -0.812 -0.792 -0.799 ...
##  $ NYGN     : num  -0.793 -0.793 -0.795 -0.786 -0.78 ...
##  $ SEPR     : num  0.327 0.309 0.266 0.225 0.172 ...
##  $ ERMA     : num  0.1565 0.1643 0.1471 0.1134 0.0699 ...
##  $ SESC     : num  -1.52 -1.46 -1.39 -1.34 -1.28 ...
##  $ FEMA     : num  -1.35 -1.31 -1.25 -1.22 -1.18 ...
##  $ SPAD     : num  0.37 0.344 0.319 0.295 0.269 ...
##  $ SPDY     : num  -0.66 -0.708 -0.749 -0.784 -0.815 ...
##  $ FEIN     : num  -0.744 -0.704 -0.668 -0.635 -0.603 ...
##  $ MAIN     : num  -0.622 -0.573 -0.527 -0.484 -0.444 ...
##  $ SPPO     : num  1.55 1.45 1.34 1.24 1.13 ...
##  - attr(*, ".internal.selfref")=<externalptr>

转换

这个缩放过程不会删除异常值。我们应该检查数据，看看是否存在显著的非正常行为，因为一些机器学习技术在正常数据上表现得更好。在这些情况下，执行其他变换(如对数缩放)可能会有所帮助。正如我们在图 8-1 中看到的，数据中存在一些异常值。

img/439480_1_En_8_Fig1_HTML.png

图 8-1

寻找重要的畸形数据

boxplot(d[,-c(1:9)], las = 2)

在图 8-2 中更仔细地观察小学毕业的男性儿童，可以发现非正常行为的证据。直方图不是正态分布的传统钟形，Q-Q 图不像直线y = x。

par(mfrow = c(1,2))
hist(d$ERMA, 100)
qqnorm(d$ERMA)

par(mfrow = c(1,1))

事实上，如果我们使用夏皮罗-维尔克正态性检验进行假设检验，我们看到 p 值是显著的，因此我们拒绝正态数据的零假设。

img/439480_1_En_8_Fig2_HTML.png

图 8-2

寻找重要的畸形数据

shapiro.test(d$ERMA)

##
##      Shapiro-Wilk normality test
##
## data:  d$ERMA
## W = 0.6, p-value <2e-16

基于图 8-2 中的直方图和 Q-Q，转换数据可能是有意义的，也许使用对数转换。首先，我们观察到缩放和居中数据的范围自然包括零，这对于对数变换来说是一个挑战。原始的data显示这不是底层信息的问题。然而，夏皮罗-维尔克正态性检验表明，即使是对数变换仍然不利于符合正态分布。

range(d$ERMA)

## [1] -0.62  3.32

range(data$ERMA)

## [1] 1.1e+05 2.1e+07

shapiro.test( log(data$ERMA) )

##
##      Shapiro-Wilk normality test
##
## data:  log(data$ERMA)
## W = 1, p-value = 3e-04

现在，从视觉上看，我们确实看到对数转换确实在一定程度上分隔了我们的数据，如图 8-3 所示。

img/439480_1_En_8_Fig3_HTML.png

图 8-3

寻找重要的畸形数据

par(mfrow = c(1,2))
hist(data$ERMA, 100)
hist( log (data$ERMA) , 100)

par(mfrow = c(1,1))

这个间距足以保证一个转换吗？一种确定方法是比较原始数据和转换数据与所需响应变量之间的相关性。我们的反应/输出变量将是SPAD，青春期生育率。我们创建一个数据集的副本，其中包括日志格式和原始格式的ERMA,并观察相关性。由于第一列中产生的相关性显示在未转换的列中相关性更强，所以我们最终选择不执行转换。

d2 <- copy(data[,.(SPAD, ERMA)])
d2[, Log.ERMA := log(ERMA)]
cor(d2)

##          SPAD ERMA Log.ERMA
## SPAD     1.00 0.83     0.72
## ERMA     0.83 1.00     0.81
## Log.ERMA 0.72 0.81     1.00

rm(d2) #no longer needed

从技术上讲，应该检查每个考虑中的变量的正态性(同样，这只是因为我们的一些模型在使用正态预测时表现更好)。同样，一般来说，在应用特定模型时，理解最佳模型性能的预期输入是很重要的。首先，使用lapply，我们观察到所有的 p 值都是显著的。接下来，我们使用sapply对数据进行对数转换，并使用colnames添加后缀。最后，我们将原始数据相关性与SPAD和对数转换相关性进行比较和对比。在某些情况下，相关性稍好一些。在其他国家，情况并非如此。

lapply(data[,-c(1:2)], shapiro.test)

## $NYGD
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.8, p-value = 3e-13
##
##
## $NYGN
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.8, p-value = 1e-13
##
##
## $SEPR
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.6, p-value <2e-16
##
##
## $ERMA
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.6, p-value <2e-16
##
##
## $SESC

##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.9, p-value = 7e-06
##
##
## $FEMA
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 1, p-value = 5e-05
##
##
## $SPAD
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.8, p-value = 5e-13
##
##
## $SPDY

##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.9, p-value = 6e-08
##
##
## $FEIN
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.8, p-value = 1e-13
##
##
## $MAIN

##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.8, p-value = 9e-14
##
##
## $SPPO
##
##     Shapiro-Wilk normality test
##
## data:  X[[i]]
## W = 0.8, p-value = 6e-13

dlog <- copy(data)
dlog <- sapply(dlog[,-c(1:2)], log)
dlog<-as.data.table(dlog)
colnames(dlog) <- paste(colnames(dlog), "LOG", sep = ".")

dlog<-cbind(data, dlog)
View(cor(dlog[,-c(1:2)]))
rm(dlog) #remove as we will not use.

现在，我们在所有情况下都不进行对数转换。根据分析结果，根据所需的模型精度，甚至根据所选的具体模型，我们保留记录哪些变量在转换后具有更强相关性的权利。通常，各种级别的预处理成为模型调整过程的一部分。

培训与验证数据

我们到达预处理阶段，讨论训练和测试数据。回想一下引言章节，训练数据集的选择相当重要。对于任何单个模型，选择一个训练集和一个验证集(通常是 80/20 分割)是有意义的。这允许在训练集上创建模型，然后在验证集上获得一些“真实”世界的准确性(因此模型没有看到数据)。然而，在本章中，我们打算讨论几种可能的模型。如果我们选择这些模型中的一个，我们又一次(因为我们使用验证数据来选择“最佳”模型)冒了某种程度的过度拟合的风险。因此，在我们的模型用于现实生活之前，我们需要从训练和验证中保留最后一点测试数据，以用作我们最终的“真实”世界估计。这变得很复杂，因为 60/20/20 的分割现在只留给我们一半多一点的数据用于训练。

当然，交叉验证是避免留给训练的数据太少的一种方法。我们可以执行一个 80/20 的训练/测试分割，对我们的训练数据使用交叉验证，并节省我们自己对正式验证集的需求。这在计算上非常昂贵，尤其是在多个模型上(或者甚至是一个模型的多次迭代)。回想一下，最后，一旦选择了一个特定的模型，在现实世界中使用之前，正确的最后一步确实是对所有数据重新训练该模型——不再进行拆分。根据模型本身的计算强度，这可能要付出相当大的代价。

由于我们的数据集只有 162 个观察值，为了简单起见，我们将只进行标准的 80/20 分割。我们的目标是在我们的模型中使用交叉验证，这样保留的测试集可以在最后使用。

使用set.seed(1234)来允许再现性，我们引入一个新的函数来执行从caret包createDataPartition的分割。第一种形式允许函数了解我们的数据是如何分层的，第二种形式告诉我们分割的比率(在这个例子中是 80/20)。一旦index被填充，我们使用它来分离我们的训练和验证或测试数据。拆分完数据后，我们就为最后阶段的预处理做好了准备。

set.seed(1234)
index <- createDataPartition(data$CntN, p = 0.8, list = FALSE)
trainData <- data[index, ]
validationData <- data[-index, ]

我们应该注意，从技术上讲，对于训练数据、测试数据和验证数据，缩放和居中应该分开进行。事实上，音阶和中心公式必须在火车上开发；否则，这些集合之间可能会有信息泄漏。然而，由于我们一直在重新设置我们的数据，并且我们打算在即将到来的部分再次缩放，我们希望我们的读者原谅我们的订购。

主成分分析

我们在上一章看到了主成分分析。降维的优点包括减少处理时间、减少过拟合和模型简化。如果您已经在无监督学习一章中安装了pcaMethods包，则不需要再次安装。如果您需要安装，请删除注释掉代码的井号，然后运行。无论哪种情况，第三行代码肯定都需要运行。

#source("https://bioconductor.org/biocLite.R")
#biocLite("pcaMethods")
library(pcaMethods)

## Loading required package: Biobase

## Loading required package: BiocGenerics

##
## Attaching package: 'BiocGenerics'

## The following objects are masked from 'package:Matrix':
##
##     colMeans, colSums, rowMeans, rowSums, which

## The following objects are masked from 'package:parallel':
##
##     clusterApply, clusterApplyLB, clusterCall, clusterEvalQ,
##     clusterExport, clusterMap, parApply, parCapply, parLapply,
##     parLapplyLB, parRapply, parSapply, parSapplyLB

## The following objects are masked from 'package:stats':
##
##     IQR, mad, sd, var, xtabs

## The following objects are masked from 'package:base':
##
##     anyDuplicated, append, as.data.frame, basename, cbind,
##     colMeans, colnames, colSums, dirname, do.call, duplicated,
##     eval, evalq, Filter, Find, get, grep, grepl, intersect,
##     is.unsorted, lapply, lengths, Map, mapply, match, mget,
##     order, paste, pmax, pmax.int, pmin, pmin.int, Position,
##     rank, rbind, Reduce, rowMeans, rownames, rowSums, sapply,
##     setdiff, sort, table, tapply, union, unique, unsplit,
##     which, which.max, which.min

## Welcome to Bioconductor
##
##     Vignettes contain introductory material; view with
##     'browseVignettes()'. To cite Bioconductor, see
##     'citation("Biobase")', and for packages
##     'citation("pkgname")'.

##
## Attaching package: 'pcaMethods'

## The following object is masked from 'package:stats':
##
##     loadings

已经分割了我们的数据，我们为 PCA 准备数据。在这里，我们的选择一部分是由我们的数据决定的，一部分是由我们的最终模型决定的。例如，各种类型的森林和基于树的方法可能不存在字符或因子数据问题。另一方面，各种类型的回归将需要前面提到的虚拟编码。PCA 不是特别适合伪编码的数据。然而，如果大量数据碰巧是分类的，那么首先对所有分类预测器进行虚拟编码，然后尝试各种类型的降维，这可能是有意义的，其中 PCA(又名svd)只是一种方法。

另一方面，我们的数据只有一位完全分类的数据—CntN。如果我们的数据集有几个伪编码列，然后我们将其他 10 个变量减少到 3 或 4 个，我们仍然可以获得可观的降维。

一般来说，PCA 是应用于数据的最后预处理步骤。当然，在 PCA 之前，应该对数值数据进行缩放和居中。至于分类数据是否也应该经过主成分分析？为简洁起见，我们将展示如何手动排除分类数据。如果您的数据需要不同的或更细微的技术，我们希望我们展示了足够的过程，以便您可以根据自己的目的修改代码。

首先，记住我们的数据的已知结构，我们用str函数验证我们已经选择了我们的训练集的正确行。

默认情况下，stats库带有基类R，prcomp是该库中的一个函数。它对我们的训练数据执行维度计算。请记住，任何符合我们 PCA 训练数据的模型都需要提供新数据或验证数据，这些数据执行了相同的 PCA 过程。为此，在通过summary(pc)查看 PCA 的结果后，我们使用predict功能。第一种形式是我们的 PCA 分析，在本例中存储在pc中。第二个是新数据，在本例中是我们的validationData。当然，对于实际生产中使用的模型，新数据将是我们希望放入模型的新数据。

然而，从上一章我们知道，除了“基本的”PCA 之外，还可以做更多的工作。因此，我们还展示了使用pcaMethods库中的pca函数所需的步骤。该功能的细节在无监督机器学习一章中有解释。现在我们注意到这个过程的结果与predict完美地工作在一起，我们展示了两种方法的第一维的打印输出，以表明它们确实是相同的。

当然，pca的优势在于通过method = " "形式的便利，方法转换成listPcaMethods()列出的任何方法都很容易。

#confirm structure
str(trainData[,c(3:8,10:13)])

## Classes 'data.table' and 'data.frame':      135 obs. of  10 variables:
##  $ NYGD: num  2299 2170 2314 2589 2495 ...
##  $ NYGN: num  2310 2311 2288 2410 2496 ...
##  $ SEPR: num  6078141 5961001 5684714 5425963 5087547 ...
##  $ ERMA: num  4181176 4222039 4131775 3955257 3726838 ...
##  $ SESC: num  8.08 8.27 8.5 8.65 8.84 ...
##  $ FEMA: num  9.73 9.82 9.97 10.02 10.12 ...
##  $ SPDY: num  6.8 6.68 6.57 6.48 6.4 ...
##  $ FEIN: num  68.7 69 69.3 69.6 69.8 ...
##  $ MAIN: num  65 65.3 65.7 65.9 66.2 ...
##  $ SPPO: num  79.1 77.7 76.2 74.7 73.2 ...
##  - attr(*, ".internal.selfref")=<externalptr>

#base R / traditional method
pc <- prcomp(trainData[,c(3:8,10:13)], center = TRUE, scale. = TRUE)

summary(pc)

## Importance of components:
##                          PC1   PC2    PC3    PC4     PC5     PC6
## Standard deviation     2.703 1.321 0.8175 0.4029 0.27986 0.16986
## Proportion of Variance 0.731 0.175 0.0668 0.0162 0.00783 0.00289
## Cumulative Proportion  0.731 0.905 0.9719 0.9881 0.99597 0.99886
##                            PC7     PC8     PC9    PC10
## Standard deviation     0.08417 0.04726 0.03535 0.02894
## Proportion of Variance 0.00071 0.00022 0.00012 0.00008
## Cumulative Proportion  0.99957 0.99979 0.99992 1.00000

pcValidationData1 <- predict(pc, newdata = validationData[,c(3:8,10:13)])

#scalable method using PcaMethods
pc<-pca(trainData[,c(1:8,10:13)], method = "svd",nPcs = 4, scale = "uv", center = TRUE)
pc

## svd calculated PCA
## Importance of component(s):
##                  PC1    PC2     PC3     PC4
## R2            0.7306 0.1745 0.06683 0.01623
## Cumulative R2 0.7306 0.9051 0.97191 0.98814
## 10   Variables
## 135  Samples
## 0    NAs ( 0 %)
## 4    Calculated component(s)
## Data was mean centered before running PCA
## Data was scaled before running PCA
## Scores structure:
## [1] 135   4
## Loadings structure:
## [1] 10  4

summary(pc)

## svd calculated PCA
## Importance of component(s):
##                  PC1    PC2     PC3     PC4
## R2            0.7306 0.1745 0.06683 0.01623
## Cumulative R2 0.7306 0.9051 0.97191 0.98814

pcValidationData2 <- predict(pc, newdata = validationData[,c(3:8,10:13)])

#demonstration of how to access transformed validation data
pcValidationData1[,1]

##  [1] -1.11 -0.87 -0.77  0.96  1.08  1.67 -1.52 -1.17 -0.82  0.37  1.06
## [12]  1.67  1.94  2.67  3.36  0.76  0.86  1.00 -1.14 -0.49  0.40  2.66
## [23]  3.72  3.80 -7.52 -5.80 -4.95

pcValidationData2$scores[,1]

##  [1] -1.11 -0.87 -0.77  0.96  1.08  1.67 -1.52 -1.17 -0.82  0.37  1.06
## [12]  1.67  1.94  2.67  3.36  0.76  0.86  1.00 -1.14 -0.49  0.40  2.66
## [23]  3.72  3.80 -7.52 -5.80 -4.95

转换完我们的数据后，现在使用cbind将一个热编码的CntN和我们的响应变量SPAD放入就很简单了。

在我们结束预处理数据这一节时，记住几个关键原则很重要。

如果使用单一模型，那么训练和验证分离(通常是 80/20)是合适的，除非使用交叉验证或引导。请记住，后两者的计算量可能很大。如果从一个以上的模型中进行选择，则需要一个训练集来训练各种模型，需要一个验证集来估计模型在未知数据上的性能，最后需要一个测试集来估计最终选择的模型在真实数据上的性能(否则，我们实际上在验证步骤中有第二阶段过度拟合)。交叉验证可以消除对验证集的需求，但在使用多个模型时，计算成本会更高。另一方面，使用 70/20/10 进行训练、验证和测试的成本可能很高。无论选择哪种方法，都应该首先进行，以防止不同组之间的信息泄漏。

如果您的数据有丢失的值，首先阅读专门讨论丢失数据的章节可能会有所收获。插补通常是数据布局正确后的第一步。

分类数据的热编码或虚拟编码是一种选择。一些模型只需要数字数据，其他模型可以用因子格式处理分类数据。正如每种类型的模型可能并不适合所有类型的数据一样，某些类型的数据也不适合某些模型。因此，要同时考虑数据和模型！对于某些模型来说，保持数据的分类和因子格式，可以为模型提供有效使用数据所需的信息，同时不会对数据产生任意的线性影响。相比之下，其他模型可能无法处理这些因素，因此除了虚拟代码之外可能别无选择。

一般来说，数字数据应该缩放和居中。事实上，删除方差为零或接近零的列也可能是明智的。具有接近零的方差的列可以被保留，并且稍后在预处理中经受 PCA。

除了基本的居中和缩放之外，它还有助于转换数据以获得适当的数据分布。虽然我们只讨论了对数变换，但是对于特定类型和特征的数据以及特定的模型来说，有许多可能的变换是有价值的。同样，如果一个特定模型的第一遍不够精确，更高级的数学可能是合适的。

8.2 监督学习模式

现在我们了解了一些预处理数据的方法，我们的下一个任务是满足一些模型。记住，监督学习仅仅意味着我们头脑中有一个特定的反应变量。对于各种类型的响应或预测变量，不同的模型可能更适合于更好地分析特定类型的数据。例如，如果我们有更多的分类变量，那么我们可能更喜欢基于分类的监督学习。另一方面，如果我们的数据主要是数字，我们可能会在回归方法中发现更多的价值。一些模型生活在两个世界中，或者可以适应这样做。而且，正如我们在预处理中已经看到的，数据本身可以变异，例如，通过虚拟编码从分类到数字。当然，这是一个很差的方法，只能以一种方式工作——直方图条可能是一个很好的例子，可以将连续的数字数据重新编码为分类数据。

在研究这些模型时，需要记住的是，具体应用需要什么样的精度。找到一个提供比机会更好的结果的模型是合理可行的。仅仅比机会好就足够了吗？有时间(人和机器)测试更多的模型吗？大多数模型都有调整参数、允许更多交叉验证的额外输入或惩罚额外的模型复杂性。花多少精力调优才算现实？

在下面的章节中，我们采取了一种平衡的方法。我们准备数据，使其与特定模型最佳交互，我们假设硬件水平合理，并选择使用合理的计算时间，我们讨论各种调整参数选项，但不必穷尽这些选项。对于任何特定的数据应用，在数据收集、预处理和最终模型调整上花费比在模型选择步骤上更多的时间是有意义的。有了这个想法，然后安全地储存在我们的脑海中，我们继续前进。

支持向量机

支持向量机(SVM)在概念上有点类似于 k 近邻，因为其思想是找到我们的数据分组。这是通过寻找通过识别关键数据点(支持向量)确定的边界曲线来实现的。支持向量是那些具有一些最大间隔(在一些度量下)的向量，并且在这些向量之间绘制边界曲线。由于边界划分可以是线性的、多项式的或更奇异的，因此有几种方法来执行基本的 SVM 算法。界定曲线类型的确定被称为 SVM 的核心。自然地，更复杂的边界核往往在计算上更困难。与其他一些包一样，caret包本身支持多种内核风格的几种变体，包括线性、指数、多项式和径向。我们将把这里的讨论限于线性和多项式。

让我们从一个简单的数据集开始——不是我们完整的正式数据集——来直观地理解支持向量机是如何工作的。我们使用青少年生育率和人均国民生产总值作为预测指标，我们的分类回答将是国名。我们重新利用我们熟知的图表 8-4 并注意到，对于任何一个国家分组，通常都有可能存在明显的线性分离。诚然，我们并不期待左下角出现奇迹。

img/439480_1_En_8_Fig4_HTML.png

图 8-4

人均国民生产总值与青少年生育率

svmDataTrain <- trainData[,.(SPAD, NYGN)]
svmDataValidate <- validationData[,.(SPAD, NYGN)]

p1 <- ggplot(data = svmDataTrain,
             aes(x = NYGN, y = SPAD))
  ## data poins colored by country
  p1 + geom_point(aes(colour = trainData$CntN)) +
    scale_colour_viridis(discrete = TRUE)

caret包由一个名为train的函数驱动。花点时间看看下面的代码布局。

第一种形式用于预测，第二种形式用于响应。在撰写本文时，第三种形式有超过 200 种可能的方法。在这种情况下，我们使用的是线性支持向量机，因此svmLinear。因为我们打算在原始数据上绘制我们的结果，所以现在我们选择保持preProcess为空。将来，它将采用center, scale, and pca等数值以及各种插补选项。正式参数metric = "Accuracy"表示我们希望我们的汇总输出让我们知道CountryName的训练区域与实际国家相比有多准确。同样，可以将 svm 看作是使用线性边界将数据分成不同的区域。我们想知道这条分界线多长时间划好一次。最后，trainControl功能用于控制模型的训练方式。在这种情况下，我们将使用交叉验证cv和five折叠。实际上有大量的数据包含在svm变量中。显示的打印输出只是一个小摘要。它确实提醒我们没有预处理，并且按照要求，告诉我们交叉验证的估计准确性。请记住，这种准确性是基于每个折叠的交叉验证过程。

set.seed(12345)

  svm <- train(x = svmDataTrain,
             y = trainData$CntN,
             method = "svmLinear",
             preProcess = NULL,
             metric = "Accuracy",
             trControl = trainControl(method = "cv",
                                      number = 5,
                                      seeds = c(123, 234, 345, 456, 567, 678)
                                      )
             )
svm

## Support Vector Machines with Linear Kernel
##
## 135 samples
##   2 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results:
##
##   Accuracy  Kappa
##   0.82      0.8
##
## Tuning parameter 'C' was held constant at a value of 1

接下来，我们稍微深入研究一下模型的准确性。因为我们实际上使用了交叉验证，这被认为是一个很好的估计。首先，我们使用有两个输入的predict函数。一个是包含我们模型的新svm。另一个是我们用来训练那个模型的训练数据。与一次只使用108元素的交叉验证折叠不同，我们使用所有的135值。接下来，我们发现这些预测的国家名称何时与在我们的trainData变量中找到的正确国家名称相同。这创建了布尔值TRUE和FALSE，它们分别等于1和0,。因此，这些事件中的mean将会给我们true发生频率的比率。请注意，尽管对0.84的不可见数据的估计是准确的，但在我们的训练数据上，我们实际上看到了0.85。这是我们所说的过度拟合的一部分。

#predict the country name on our training data using our new model
predictOnTrain <- predict(svm, newdata = svmDataTrain)

mean( predictOnTrain == trainData$CntN)

## [1] 0.82

现在，使用我们提供的验证数据是不正确的。从技术上来说，我们必须把它保存到最后，而不是用它来通知我们的模型选择，然后在我们看到所有的模型之后才使用它来执行最后的验证步骤。然而，鉴于在第一个示例草图中展示了这个过程的样子，展示最后一步有一定的教学意义。我们执行与训练数据相同的计算(实际上，这个预测过程就是我们对真正新的真实世界数据所做的)。虽然交叉验证比实际训练数据可能显示的更保守，但它并不像它本来可能的那样保守。

同样，我们模型中完全看不见的数据上的0.78是模型过度拟合的一个例子。训练数据在某种程度上使我们的模型产生了偏差，在完全看不见的验证数据的情况下，它表现得不那么好。

predictOnTest <- predict(svm, newdata = svmDataValidate)
mean(predictOnTest == validationData$CntN)

## [1] 0.81

使用与上一章相同的过程，我们绘制了看不见的验证数据，并将正确答案的结果与图 8-5 中的预测进行比较。我们的模型很难理解线性分离的确切位置，也正是不准确性显现的地方。

img/439480_1_En_8_Fig5_HTML.png

图 8-5

训练与测试预测

p1 <- ggplot(data = validationData,
             aes(x = NYGN, y = SPAD))

plot_grid(
  ## data poins colored by country
  p1 + geom_point(aes(colour = validationData$CntN, size = validationData$CntN)) +
    scale_colour_viridis(discrete = TRUE),

  ## data poins colored by predicted country
  p1 + geom_point(aes(colour = predictOnTest, size = predictOnTest)) +
    scale_colour_viridis(discrete = TRUE),
ncol = 1

)

## Warning: Using size for a discrete variable is not advised.
## Warning: Using size for a discrete variable is not advised.

预计前面的代码会生成两个警告—也就是说，对于区域名称这样的离散变量，不建议使用这样的大小。这是一个合理的警告，在现实生活中，我们永远不会使用这样的技术(一个重要的原因是人类倾向于将大小本身解释为重要的，在这种情况下没有这样的意义)。我们在这里使用它只是为了帮助区分类别。

既然我们已经看到并理解了caret模型构建的整体布局，以及如何在最后使用验证数据来理解选择哪个模型，我们将验证数据安全地保存起来，直到最后才会再次使用，以了解我们最终选择的模型可能会如何执行。我们还花了一些时间来清理我们的环境。

rm(p1)
rm(svm)
rm(svmDataTrain)
rm(svmDataValidate)
rm(pcValidationData1)
rm(pcValidationData2)
rm(predictOnTest)
rm(predictOnTrain)
rm(pc)
rm(d)

我们现在准备在我们的整个trainData布景上表演我们的 SVM 模型。我们留下的是我们原始的data的一个副本，我们用来将数据分成训练集和验证集的index，以及实际的训练集和验证集本身。

我们再次构建我们的模型训练数据减去我们的分类国家名称列。现在，我们将字符年份数据重新编码为数字，并为可再现性设置种子。除了包含更多的可变列之外，唯一的不同是设置了preProcess = c("scale", "center", "pca")。这默认为 PCA thresh = 0.95，如果需要，可以按照?preProcess中的说明进行调整。在这种情况下，我们使用默认值。我们看到估算模型的准确性有所提高。

# set up training & validation data
svmDataTrain <- trainData[,-1]
svmDataTrain[,Year:=as.numeric(Year)]
svmDataValidation <- validationData[,-1]
svmDataValidation[,Year:=as.numeric(Year)]
#run linear SVM on the full data set
set.seed(12345)
svmLinear <- train(x = svmDataTrain,
             y = trainData$CntN,
             method = "svmLinear",
             preProcess = c("scale", "center", "pca"),
             metric = "Accuracy",
             trControl = trainControl(method = "cv",
                                      number = 5,
                                      seeds = c(123, 234, 345, 456, 567, 678)
                                      )
             )
svmLinear

## Support Vector Machines with Linear Kernel
##
## 135 samples
##  12 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## Pre-processing: scaled (12), centered (12), principal
##  component signal extraction (12)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results:
##
##   Accuracy  Kappa
##   0.99      0.98
##
## Tuning parameter 'C' was held constant at a value of 1

在这一点上，描述线性 SVM 是如何工作的是很重要的。该算法是为二元分类而设计的。在这种情况下，对于多个结果，它以一个对其余的方式在数据中循环。所以这个线性模型实际上是画了一条直线，一次将一个群体与其他群体隔离开来。目标是在数据之间画一条线，使这条线尽可能远离分界线两侧的点。这有助于一个模型预测未来数据应该走向何方。通过调整参数C，我们控制需要多宽的余量(如果数据过于接近，可能会使生产线选择不同的路径)。更高的C值导致更高的训练精度和更小的裕度——存在过度拟合的风险。

当我们从线性变为多项式时，它允许直线变成多项式曲线。此外，默认情况下，该算法循环遍历几个C值。注意(在运行下面的代码之后),一般来说，对于每组固定的度数和比例，C的值越大，产生的精确度越高。代价是，随着C的增加，我们曲线的边缘缩小，这意味着我们的模型过度拟合数据的可能性增加。

接下来，我们只对我们的模型做一个改变，从线性模型到多项式模型。在caret中，这很容易通过切换到method = "svmPoly"来完成。虽然代码的变化很小，但计算工作量的变化更小。注意svmPoly是一个完全不同于线性版本的模型。虽然算法和数学超出了本文的范围，但是即使在线性程度级别，过程也是不同的。虽然这目前看起来不如我们的线性模型好，但如果是真的，那么0.88的准确性仍然可能相当好。

#run polynomial SVM on the full data set

set.seed(12345)
svmPoly <- train(x = svmDataTrain,
             y = trainData$CntN,
             method = "svmPoly",
             preProcess = c("scale", "center", "pca"),
             metric = "Accuracy",
             trControl = trainControl(method = "cv",
                                      number = 5
                                      )
             )

svmPoly

## Support Vector Machines with Polynomial Kernel
##
## 135 samples
##  12 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## Pre-processing: scaled (12), centered (12), principal
##  component signal extraction (12) 

## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results across tuning parameters:
## 

##   degree  scale  C     Accuracy  Kappa
##   1       0.001  0.25  0.76      0.73
##   1       0.001  0.50  0.76      0.73
##   1       0.001  1.00  0.76      0.73
##   1       0.010  0.25  0.76      0.73
##   1       0.010  0.50  0.76      0.73
##   1       0.010  1.00  0.76      0.73
##   1       0.100  0.25  0.76      0.73
##   1       0.100  0.50  0.78      0.75
##   1       0.100  1.00  0.81      0.79
##   2       0.001  0.25  0.76      0.73
##   2       0.001  0.50  0.76      0.73
##   2       0.001  1.00  0.76      0.73
##   2       0.010  0.25  0.76      0.72
##   2       0.010  0.50  0.76      0.72
##   2       0.010  1.00  0.76      0.72
##   2       0.100  0.25  0.79      0.76
##   2       0.100  0.50  0.81      0.79
##   2       0.100  1.00  0.87      0.85
##   3       0.001  0.25  0.76      0.73
##   3       0.001  0.50  0.76      0.73
##   3       0.001  1.00  0.76      0.73
##   3       0.010  0.25  0.76      0.72
##   3       0.010  0.50  0.76      0.72
##   3       0.010  1.00  0.76      0.72
##   3       0.100  0.25  0.80      0.78
##   3       0.100  0.50  0.86      0.84
##   3       0.100  1.00  0.90      0.88
## 

## Accuracy was used to select the optimal model using the
##  largest value.
## The final values used for the model were degree = 3, scale = 0.1
##  and C = 1.

请注意，这两个模型完全符合我们的完整训练集。因此，尽管多项式预测的估计精度较低，但这两个模型似乎都非常符合我们的数据。

predictOnTrainL <- predict(svmLinear, newdata = svmDataTrain)
mean( predictOnTrainL == trainData$CntN)

## [1] 1

predictOnTrainP <- predict(svmPoly, newdata = svmDataTrain)
mean( predictOnTrainP == trainData$CntN)

## [1] 0.98

基于精度水平，如果在现实生活中面对这两个选项，我们会选择线性选项。在这个阶段，我们已经做出了选择，然后我们将只在我们选择的模型上运行最后一次验证数据。我们在下面的代码中做到了这一点，并取得了很好的结果。因此，我们变得相当确定，基于我们选择的数据，给定 2015 年对我们的其余数据点的新观察，我们将对我们正确排序到正确区域的能力相当有信心。当然，我们最好在未来跟踪我们模型的准确性。

predictOnTestL <- predict(svmLinear, newdata = svmDataValidation)
mean(predictOnTestL == validationData$CntN)

## [1] 1

总的来说，我们的数据集似乎相当完整。换句话说，这些不同的地理区域在最近几年被收集的一组预测因子很好地描述了。考虑到图 8-4 中非常清晰的分组，这并不特别令人震惊。事实上，意识到 PCA 不会对这两个变量有特别大的改变。有很好的垂直和水平分隔。

这就结束了关于支持向量机的部分。在接下来的章节中，我们将继续使用caret的高度一致的结构来利用其他模型。随着我们对整体模型结构越来越熟悉，我们试图增加额外的技能。请记住，在现实生活中，后面介绍的技巧很可能会用到支持向量机。

分类和回归树

分类和回归树(CART)是为数字、连续预测值和分类响应变量而设计的。这非常符合我们的数据集。我们刷新 CART 的训练和验证数据，使用set.seed来获得再现性，并使用我们现在熟悉的train函数。我们添加了一个新的特性，tuneLength = 10，它控制复杂度的迭代次数。增加该值会增加模型的总计算时间；因此，对于较大的数据集，模型精度的提高需要与训练模型的时间进行权衡。

cartDataTrain <- copy(trainData[,-1])
cartDataTrain[,Year:=as.numeric(Year)]
cartDataValidation <- copy(validationData[,-1])
cartDataValidation[,Year:=as.numeric(Year)]

set.seed(12345)

cartModel <- train(x = cartDataTrain,
             y = trainData$CntN,
             method = "rpart",
             preProcess = c("scale", "center", "pca"),
             metric = "Accuracy",
             tuneLength = 10,
             trControl = trainControl(method = "cv",
                                      number = 5
                                      )
             )

cartModel

## CART
##
## 135 samples
##  12 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## Pre-processing: scaled (12), centered (12), principal
##  component signal extraction (12)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results across tuning parameters:
##
##   cp     Accuracy  Kappa
##   0.000  0.84      0.83
##   0.014  0.84      0.83
##   0.028  0.84      0.83
##   0.042  0.85      0.83
##   0.056  0.85      0.83
##   0.069  0.85      0.83
##   0.083  0.85      0.83
##   0.097  0.76      0.73
##   0.111  0.73      0.70
##   0.125  0.11      0.00
## 

## Accuracy was used to select the optimal model using the
##  largest value.
## The final value used for the model was cp = 0.083.

在精确度降低之前，模型最终根据精确度(如我们所要求的)选择最大的复杂性值(这是交叉验证的一个例子，帮助我们避免过度拟合模型)。

可使用通用绘图功能绘制finalModel，如图 8-6 所示。这棵树没有太多的层次。请注意，虽然我们的估计准确性可能相当高(因此我们可能希望我们的模型具有可靠的预测值)，但该模型对于理解为什么应该做出特定预测并不那么有用。因此，虽然通常树模型可能被认为是相当容易解释的，但使用主成分分析会降低我们理解为什么我们的模型可能是正确的能力。

img/439480_1_En_8_Fig6_HTML.png

图 8-6

分类树形图

plot(cartModel$finalModel)
text(cartModel$finalModel, cex = 0.5)

虽然通用的plot函数很有帮助，但是fancyRpartPlot通常看起来更整洁，尽管在这种情况下，很难找到合适的文本缩放级别，如图 8-7 所示。在任何情况下，重要的是要注意，虽然模型的准确性可以通过主成分分析来提高，但模型的可解释性变得更加复杂。开发一种方法来更好地解释将是有帮助的。

img/439480_1_En_8_Fig7_HTML.png

图 8-7

花式分类树形图

fancyRpartPlot(cartModel$finalModel, cex = 0.4, main = "")

接下来，我们重复我们用于 SVM 的准确性度量。我们的最终模型在训练数据上是高度精确的，并且确实在完全看不见的数据上保持了这种精确度(嗯，几乎保持了)。同样，如果我们希望对模型在真实世界数据中的表现有一个真实的估计，当我们继续使用交叉验证时，正确的方法是等到本章的最后，通过交叉验证选择最准确的模型，然后最后只对选择的模型运行predictOnTestT。然而，作为一种教学方法，在完全看不见的数据上看到结果是有价值的，所以我们请求我们的读者继续原谅我们。

predictOnTrainT <- predict(cartModel, newdata = cartDataTrain)
mean( predictOnTrainT == trainData$CntN)

## [1] 0.77

predictOnTestT <- predict(cartModel, newdata = cartDataValidation)
mean(predictOnTestT == validationData$CntN)

## [1] 0.67

caret包有一个我们还没有介绍的功能，叫做confusionMatrix。虽然这种情况下的输出很长，但是我们可以看到预测与验证参考的结果。一点滚动和良好的记忆显示，有一个阿拉伯世界的预测是不正确的，实际的数据值是东亚和太平洋。混淆矩阵会有所帮助，因为它显示了超出简单准确性的细节。它可以允许检测显示错误发生位置的模式。如果该模型旨在处理真实世界的数据，则可能需要收集额外的信息来支持这些数据之间的分类。此外，它还提供了一个置信区间。

confusionMatrix(predictOnTestT, as.factor(validationData$CntN))

## Confusion Matrix and Statistics
##
##           Reference
## Prediction ArbWr CEatB Er&CA ErpnU EsA&P LtA&C ME&NA NrthA Sb-SA
##      ArbWr     3     0     0     0     2     3     3     0     0
##      CEatB     0     3     0     0     0     0     0     0     0
##      Er&CA     0     0     2     0     0     0     0     0     0
##      ErpnU     0     0     1     3     0     0     0     0     0
##      EsA&P     0     0     0     0     1     0     0     0     0
##      LtA&C     0     0     0     0     0     0     0     0     0
##      ME&NA     0     0     0     0     0     0     0     0     0
##      NrthA     0     0     0     0     0     0     0     3     0
##      Sb-SA     0     0     0     0     0     0     0     0     3
##
## Overall Statistics

##
##                Accuracy : 0.667
##                  95% CI : (0.46, 0.835)
##     No Information Rate : 0.111
##     P-Value [Acc > NIR] : 1.15e-11
##
##                   Kappa : 0.625
##  Mcnemar's Test P-Value : NA
##
## Statistics by Class:

##
##                      Class: ArbWr Class: CEatB Class: Er&CA
## Sensitivity                 1.000        1.000       0.6667
## Specificity                 0.667        1.000       1.0000
## Pos Pred Value              0.273        1.000       1.0000
## Neg Pred Value              1.000        1.000       0.9600
## Prevalence                  0.111        0.111       0.1111
## Detection Rate              0.111        0.111       0.0741
## Detection Prevalence        0.407        0.111       0.0741
## Balanced Accuracy           0.833        1.000       0.8333
##                      Class: ErpnU Class: EsA&P Class: LtA&C
## Sensitivity                 1.000        0.333        0.000
## Specificity                 0.958        1.000        1.000
## Pos Pred Value              0.750        1.000          NaN
## Neg Pred Value              1.000        0.923        0.889
## Prevalence                  0.111        0.111        0.111
## Detection Rate              0.111        0.037        0.000
## Detection Prevalence        0.148        0.037        0.000
## Balanced Accuracy           0.979        0.667        0.500
##                      Class: ME&NA Class: NrthA Class: Sb-SA
## Sensitivity                 0.000        1.000        1.000
## Specificity                 1.000        1.000        1.000
## Pos Pred Value                NaN        1.000        1.000
## Neg Pred Value              0.889        1.000        1.000
## Prevalence                  0.111        0.111        0.111
## Detection Rate              0.000        0.111        0.111
## Detection Prevalence        0.000        0.111        0.111
## Balanced Accuracy           0.500        1.000        1.000

如您所见，在这个数据集中，分类和回归树工作得相当好。虽然 PCA 方面可能会使对哪些输入值驱动哪些决策的完美理解变得复杂，但树通常可以简洁地用图表表示。此外，如果愿意，可以尝试不使用五氯苯甲醚。使用原始数据(尽管可能经过标准化和缩放)可能会产生一个足够准确且更容易解释的模型。另一方面，单棵树在某些情况下可能不够准确。和模型总是有取舍的。

随机森林

随机森林比树的概念前进了一步。回想上一节，意识到我们的树真的很擅长识别中欧。虽然它在阿拉伯世界犯了一些错误，但它在中欧(CEatB)表现良好。如果我们不是训练一棵树，而是训练很多棵树，会怎么样？当然，简单地循环 CART 算法会产生一个克隆森林，这里不需要这样做。相反，随机森林概念上的第一步是随机选取某些预测值列，并从该列子集中随机选取某些观察值。这创建了训练数据集的随机子集，并且这些子集的每一个都用于训练树。一旦树木长成森林，模型就可以进行预测了。回归预测或数值数据是每棵树预测响应值的平均值。对我们的分类或分类数据的预测将是机器学习式的民主，其中多数投票获胜(如果需要，还附带一个概率)。

我们从设置现在常用的数据集副本开始。caret的一个非常有用的特性仍然是train函数的标准化，它允许我们非常容易地在这些不同的模型之间工作。对于随机森林，我们使用method = "ranger"。模型变量num.trees被设置为控制我们森林的大小，我们从森林中只有 20 棵树开始。默认情况下，该模型在一些调整参数上运行一个小的网格搜索，稍后我们将对此进行更深入的讨论。在这种情况下，基于交叉验证选择的模型估计具有很高的准确性，只有 20 棵树。请注意，finalModel中包含了几个特定的变量，我们确认模型中只有 20 棵树。在这种情况下，初始阶段将创建 20 个随机子集，每个子集用于训练 20 棵树中的一棵树。

rfDataTrain <- copy(trainData[,-1])
rfDataTrain[,Year:=as.numeric(Year)]
rfDataValidation <- copy(validationData[,-1])
rfDataValidation[,Year:=as.numeric(Year)]

set.seed(12345)

rfModel <- train(x = rfDataTrain,
             y = trainData$CntN,
             method = "ranger",
             preProcess = c("scale", "center", "pca"),
             metric = "Accuracy",
             num.trees = 20,
             trControl = trainControl(method = "cv",
                                      number = 5
                                      )
             )

rfModel

## Random Forest
##
## 135 samples
##  12 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## Pre-processing: scaled (12), centered (12), principal
##  component signal extraction (12)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results across tuning parameters:
##
##   mtry  splitrule   Accuracy  Kappa
##   2     gini        0.93      0.92
##   2     extratrees  0.96      0.96
##   3     gini        0.93      0.92
##   3     extratrees  0.96      0.96
##   4     gini        0.93      0.92
##   4     extratrees  0.99      0.98
##
## Tuning parameter 'min.node.size' was held constant at a value of 1

## Accuracy was used to select the optimal model using the
##  largest value.
## The final values used for the model were mtry = 4, splitrule
##  = extratrees and min.node.size = 1.

rfModel$finalModel$num.trees

## [1] 20

自然地，我们运行我们现在通常的检查，看看最终的模型在我们的测试集和验证集上表现如何。基于validationData的比较，训练数据的保留部分的估计精度可能有点高。

predictOnTrainR <- predict(rfModel, newdata = rfDataTrain)
mean( predictOnTrainR == trainData$CntN)

## [1] 1

predictOnTestR <- predict(rfModel, newdata = rfDataValidation)
mean(predictOnTestR == validationData$CntN)

## [1] 1

随机森林的计算复杂性在一定程度上是被训练的树的数量的特征——这确实也开始对未来的预测产生计算成本(虽然通常不是一个巨大的负担，但预测并不仅仅通过单棵树进行过滤)。我们接下来调整我们的代码来拥有50树。

set.seed(12345)
rfModel <- train(x = rfDataTrain,
             y = trainData$CntN,
             method = "ranger",
             preProcess = c("scale", "center", "pca"),
             metric = "Accuracy",
             num.trees = 50,
             trControl = trainControl(method = "cv",
                                      number = 5
                                      )
             )
rfModel

## Random Forest
##
## 135 samples

##  12 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## Pre-processing: scaled (12), centered (12), principal
##  component signal extraction (12)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results across tuning parameters:
##
##   mtry  splitrule   Accuracy  Kappa
##   2     gini        0.94      0.93
##   2     extratrees  0.99      0.99
##   3     gini        0.93      0.92
##   3     extratrees  0.98      0.97
##   4     gini        0.93      0.92
##   4     extratrees  0.98      0.97
##
## Tuning parameter 'min.node.size' was held constant at a value of 1

## Accuracy was used to select the optimal model using the
##  largest value

.
## The final values used for the model were mtry = 2, splitrule
##  = extratrees and min.node.size = 1.

rfModel$finalModel$num.trees

## [1] 50

这种增加的净效果是为我们的保留验证数据提供了一个完美的匹配。至于它是否经得起未来额外的真实世界测试，则是另一回事了。重要的是要认识到每个数据集都有各种各样的特征，这些特征使得数据集在不同的模型下表现不同。在这种情况下，就目前而言，模型给我们提供了高度准确的结果。如前所述，其中一位作者处理学生的成绩数据，在这种情况下，准确的分数预测会更加困难。

predictOnTrainR <- predict(rfModel, newdata = rfDataTrain)
mean( predictOnTrainR == trainData$CntN)

## [1] 1

predictOnTestR <- predict(rfModel, newdata = rfDataValidation)
mean(predictOnTestR == validationData$CntN)

## [1] 1

提高给定模型准确性的一种方法是通过调整。对于随机森林，调整参数包括num.trees、mtry、splitrule和min.node.size。虽然已经注意到num.trees可以控制树的数量，但是其他的调整参数值得讨论。基于我们之前对 PCA 的探索，有理由假设我们的数据仍然有四个主要成分。在这种情况下，当在任何特定节点时，随机森林算法将随机选择这些预测值中的一些，然后决定这些选择的预测值中的哪一个将给出最大排序增益(回忆树分支到两个子节点中的一个)。mtry变量设置每次随机选择四个预测值中的多少个。因此，一到四是我们的范围，并成为调整我们的模型的一种方式。splitrule允许选择算法的各种细微差别。在我们的例子中，当我们使用模型对数据进行分类时，有意义的选项是gini和extratrees。由于extratrees是迄今为止最佳选择的具体方法，我们将坚持使用它来简化调整过程。最后，min.node.size决定在树停止生长之前允许多少行数据。对于分类数据，默认值为 1。然而，我们的数据有 9 个区域的 135 个观察值，这给了我们每个区域 15 个实例。因此，虽然大于 15 的最小尺寸不太理想，但尝试多个尺寸可能是有意义的。为了用这些变量调整模型，我们使用 base R中的expand.grid函数从我们选择的范围的所有可能组合中创建一个数据框。这被传递到正式的tuneGride和模型运行。

set.seed(12345)

rfModel <- train(x = rfDataTrain,
             y = trainData$CntN,
             method = "ranger",
             preProcess = c("scale", "center", "pca"),
             metric = "Accuracy",
             num.trees = 20,
             trControl = trainControl(method = "cv",
                                      number = 5
                                      ),
             tuneGrid = expand.grid(mtry = c(1, 2, 3, 4),
                                    splitrule = "extratrees",
                                    min.node.size = c(1, 5, 10, 15))
             )

rfModel

## Random Forest
##
## 135 samples
##  12 predictor
##   9 classes: 'ArbWr', 'CEatB', 'Er&CA', 'ErpnU', 'EsA&P', 'LtA&C', 'ME&NA', 'NrthA', 'Sb-SA'
##
## Pre-processing: scaled (12), centered (12), principal
##  component signal extraction (12)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 108, 108
## Resampling results across tuning parameters:
##
##   mtry  min.node.size  Accuracy  Kappa
##   1      1             0.95      0.94
##   1      5             0.94      0.93
##   1     10             0.88      0.87
##   1     15             0.77      0.74
##   2      1             0.98      0.97
##   2      5             0.96      0.95
##   2     10             0.95      0.94
##   2     15             0.90      0.88
##   3      1             0.96      0.96
##   3      5             0.95      0.94
##   3     10             0.93      0.92
##   3     15             0.88      0.87
##   4      1             0.96      0.95
##   4      5             0.96      0.95
##   4     10             0.94      0.93
##   4     15             0.90      0.89
##
## Tuning parameter 'splitrule' was held constant at a value
##  of extratrees

## Accuracy was used to select the optimal model using the
##  largest value.
## The final values used for the model were mtry = 2, splitrule = 
##  extratrees and min.node.size = 1.

rfModel$finalModel$num.trees

## [1] 20

rfModel$finalModel$mtry

## [1] 2

rfModel$finalModel$splitrule

## [1] "extratrees"

rfModel$finalModel$min.node.size

## [1] 1

值得注意的是，在这些更广泛的选项上运行模型将模型在我们的系统上运行的时间增加了 1.9 倍。我们使用函数system.time()作为包含 20 棵树的原始运行的包装器，并使用tuneGride来确定时间成本。作为一般的工作流程，模型调优是最后一个步骤，一旦选择了特定的模型，就要进行调优，正是因为这个原因。

我们最后一次运行我们模型的验证，看到在 20 棵树的限制下，调整并没有增加我们验证数据的准确性。

predictOnTrainR <- predict(rfModel, newdata = rfDataTrain)
mean( predictOnTrainR == trainData$CntN)

## [1] 1

predictOnTestR <- predict(rfModel, newdata = rfDataValidation)
mean(predictOnTestR == validationData$CntN)

## [1] 1

随机梯度推进

随机梯度推进是一种迭代创建树木“森林”的方法。这种方法和随机森林的区别在于迭代。在训练第一个模型之后，计算预测输出和已知训练数据输出之间的误差。然后，误差被用作预测值的附加响应变量，以努力降低误差水平。这个过程重复进行，减少了错误率。该技术非常有效，既不需要删除/填补缺失数据，也不需要缩放/居中/pca。收益往往伴随着权衡，在没有交叉验证的情况下运行时，模型几乎肯定会过度拟合。迭代性质和减少误差的目标在计算时间和存储需求方面也可能相对昂贵。

这一次，我们将使用回归而不是分类模型。为此，我们对国家的训练和验证数据进行虚拟编码，并再次选择将变量Year设置为一个数值。

sgbDataTrain <- copy(trainData)
sgbDataTrain[,Year:=as.numeric(Year)]
sgbDataValidation <- copy(validationData)
sgbDataValidation[,Year:=as.numeric(Year)]

ddum <- dummyVars("˜.", data = sgbDataTrain)
sgbDataTrain <- data.table(predict(ddum, newdata = sgbDataTrain))
sgbDataValidation <- data.table(predict(ddum, newdata = sgbDataValidation))
rm(ddum)

这一次，我们的火车功能确实有些不同。因为我们正在执行回归，caret确实允许第一个形式是回归函数。在这种情况下，我们选择让SPAD作为因变量，所有其他变量都将是预测变量。由于第一个形式不再包含对数据集的提及，我们显式断言了在train函数的第二个形式参数中使用的数据。熟悉的缩放和居中已经完成，尽管我们现在放弃主成分分析。此外，由于这些是回归中的数字数据，我们设置metric = "RMSE"通过均方根误差检测最佳模型。我们继续使用交叉验证。这个模型将相当多的文本打印到屏幕上，显示许多迭代。通过设置verbose = FALSE，我们否定了这一点，尽管我们鼓励感兴趣的读者将设置改为TRUE。

tuneGride选项被设置为默认设置(因此不是严格要求的，尽管为了简洁起见我们在这里包括了它们)。interaction.depth的范围从 1 到 3，所以这些树的“高度”范围从单个节点到孙节点。shrinkage的值控制迭代的移动，较小的值允许更多的微调，但可能会花费模型更长的时间来找到一个“足够好”的位置。现在熟悉的是n.trees控制森林的最大尺寸，n.minobsinnode设置为同样熟悉的 10。一般来说，只有 150 棵树可能不够，价值超过 10，000 的树在野外很常见。

set.seed(12345)
sgbModel <- train(SPAD ~.,
                  data = sgbDataTrain,
             method = "gbm",
             preProcess = c("scale", "center"),
             metric = "RMSE",
             trControl = trainControl(method = "cv",
                                      number = 5
                                      ),
             tuneGrid = expand.grid(interaction.depth = 1:3,
                                    shrinkage = 0.1,
                                    n.trees = c(50, 100, 150),
                                    n.minobsinnode = 10),
             verbose = FALSE
             )
sgbModel

## Stochastic Gradient Boosting
##
## 135 samples
##  20 predictor

##
## Pre-processing: scaled (20), centered (20)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 107, 109
## Resampling results across tuning parameters:
##
##   interaction.depth  n.trees  RMSE  Rsquared   MAE
##   1                   50      14.6  0.81      11.5
##   1                  100      12.3  0.86       9.8
##   1                  150      11.1  0.88       8.8
##   2                   50      10.4  0.91       8.3
##   2                  100       7.8  0.94       5.7
##   2                  150       7.0  0.95       5.0
##   3                   50       8.9  0.93       6.7
##   3                  100       6.8  0.95       4.9
##   3                  150       6.2  0.96       4.4
##
## Tuning parameter 'shrinkage' was held constant at a value of
##  0.1
## Tuning parameter 'n.minobsinnode' was held constant at a
##  value of 10
## RMSE was used to select the optimal model using the smallest value.
## The final values used for the model were n.trees =
##  150, interaction.depth = 3, shrinkage = 0.1 and n.minobsinnode = 10.

所选模型有 150 棵树，每个节点至少有 10 个观察值(与早期的分类选择形成对比，在早期的分类选择中，默认的最小观察值是 1)。这一模型的 RMSE 是每 1000 名 15-19 岁的妇女中有 5.9 个孩子。

在第一次尝试中避免 PCA 有助于理解是什么以某种程度的准确性和效率为代价驱动了模型。使用summary函数，我们可以看到最有影响力的预测值。影响最大的是SPPO，显示的是劳动年龄人口的百分比。紧随其后的是统计小学失学女童的SEPR，以及每千人死亡率的SPDY。在这种情况下，summary也会生成一个图形 8-8 ，这显然不是最佳的。然而，数据打印输出是有用的，并且可视化是有帮助的。

img/439480_1_En_8_Fig8_HTML.png

图 8-8

相对影响可视化

summary(sgbModel)

##                     var rel.inf
## SPPO               SPPO  31.337
## SEPR               SEPR  17.903
## SPDY               SPDY  11.753
## MAIN               MAIN   8.223
## NYGN               NYGN   6.945
## ERMA               ERMA   6.127
## NYGD               NYGD   5.158
## SESC               SESC   4.519
## `CntNLtA&C` `CntNLtA&C`   3.912
## FEMA               FEMA   2.843
## Year               Year   0.504
## CntNNrthA     CntNNrthA   0.337
## CntNErpnU     CntNErpnU   0.250
## FEIN               FEIN   0.104
## `CntNME&NA` `CntNME&NA`   0.049
## CntNArbWr     CntNArbWr   0.018
## `CntNSb-SA` `CntNSb-SA`   0.016
## CntNCEatB     CntNCEatB   0.000
## `CntNEr&CA` `CntNEr&CA`   0.000
## `CntNEsA&P` `CntNEsA&P`   0.000

接下来，我们将注意力转向理解我们的模型的准确性。residuals函数用于计算训练模型对训练数据的 MSE(回想一下机器学习介绍章节中关于 MSE 的讨论)。我们将此与验证数据的预测值和实际值进行比较，发现模型很可能过度拟合。

mean(stats::residuals(sgbModel)²)

## [1] 3.6

mean((predict(sgbModel, sgbDataValidation) -
                  sgbDataValidation$SPAD)²)

## [1] 15

这种方法的一个挑战是，任何特定模型本身的精确机制都非常复杂，很难理解是什么驱动了预测。软件包DALEX有一个名为explain的函数，它试图帮助理解模型的更多内容，以及预测器如何与响应进行交互。虽然这个软件包非常适用于比较测试数据上的各种模型，但语法可以通过训练和验证数据来学习。

explain函数采用模型作为第一个形式，一个标签来区分后面的图形(这里我们区分训练和验证)，一个指针指向我们的data，以及一个响应变量SPAD(青少年生育率)的断言。

explainSGBt <- explain(sgbModel, label = "sgbt",
               data = sgbDataTrain,
               y = sgbDataTrain$SPAD)

explainSGBv <- explain(sgbModel, label = "sgbv",
               data = sgbDataValidation,
               y = sgbDataValidation$SPAD)

对于本文来说，explain对象本身并不特别重要。感兴趣的是能从他们身上找到的信息，函数model_performance是这些中的第一个。重用cowplot包中的plot_grid函数，绘制残差的分布和箱线图。图 8-9 中最左边的图表是残差绝对值的曲线图。记住正态分布残差的一般假设，然后想象绝对值变换将使正态分布看起来像两倍高度的半个分布，我们看到验证集看起来基本上仍然是正态的，尽管它比定型集更容易出错。第二张图显示了同样的事实，箱线图上的范围更大。

img/439480_1_En_8_Fig9_HTML.png

图 8-9

DALEX 残差可视化

performanceSGBt <- model_performance(explainSGBt)
performanceSGBv <- model_performance(explainSGBv)

plot_grid(
  plot(performanceSGBt, performanceSGBv),
  plot(performanceSGBt, performanceSGBv, geom = "boxplot"),
  ncol = 2)

虽然我们已经看到了模型权重的相对影响，但是函数variable_importance计算了在没有来自各种变量的信息的情况下会出现的丢失损失。它对每个数据集都这样做，所以请注意，在图 8-10 中，训练数据的值不同于验证数据集的值。尽管如此，最顶端的关键变量确实与相对影响变量匹配(尽管顺序不同)。

img/439480_1_En_8_Fig10_HTML.png

图 8-10

DALEX 辍学损失

importanceSGBt <- variable_importance(explainSGBt)
importanceSGBv <- variable_importance(explainSGBv)
plot(importanceSGBt, importanceSGBv)

我们讨论的最后一个DALEX函数是variable_response函数，它接受一个单变量的附加形式参数。在这种情况下，我们选择部分相关图类型，并在图 8-11 中看到结果图。小学(SEPR)以外的女童人数与模型结果相对照。该图的价值在于，尽管模型本身可能不容易理解(不像简单的回归方程)，但青少年生育率和小学出勤率之间的关系是可以探究的。

img/439480_1_En_8_Fig11_HTML.png

图 8-11

DALEX 小学缺课计数与少女怀孕。

responseSGBprmt <- variable_response(explainSGBt, variable = "SEPR", type = "pdp")
responseSGBprmv <- variable_response(explainSGBv, variable = "SEPR", type = "pdp")
plot(responseSGBprmt, responseSGBprmv)

我们使用相同的设置运行代码，只是这次每 1000 人的死亡率(SPDY)如图 8-12 所示。这里，关系比较复杂。这也许说明了为什么这种类型的模型可能非常适合处理与预测值有复杂关系的数据。它还显示了为什么这个模型有过度拟合的风险。

img/439480_1_En_8_Fig12_HTML.png

图 8-12

DALEX 每 1，000 人死亡率与少女怀孕

responseSGBdynt <- variable_response(explainSGBt, variable = "SPDY", type = "pdp")
responseSGBdynv <- variable_response(explainSGBv, variable = "SPDY", type = "pdp")
plot(responseSGBdynt, responseSGBdynv)

下一步是什么？嗯，这个模型并没有显示出很高的精确度。扩展调整网格以允许更多的树、更深的树和其他可变模式，从而为算法提供更宽的搜索网格以获得最佳模型。我们把这样的扩展留给感兴趣的读者，因为结构已经构建好了，然后继续下一个模型。

多层感知器

多层感知器(MLP)是一种前馈人工神经网络。这实际上并不完全是最新和最伟大的深度学习或神经网络算法。尽管如此，这是一种人们倾向于从学习开始的神经网络类型。在它的核心，神经网络只是一个由算法优化的线性代数矩阵乘法。净效应是，不是每个预测变量有一个权重的标准回归方程，而是有一个相当大的权重数组。

神经网络的一个关键特征是使用多个方程(因此是矩阵)，而不是试图用单个方程来创建预测值。实际上，预测器的每一部分都将被单独处理、加权并映射到可能的输出。此外，在输入和输出之间可能有几层方程式，而不是使用单一的方程式。这些被恰当地命名为“隐藏层”，虽然它们可以给模型带来很大的灵活性，但大多数多层感知器作为一个模型很难理解。他们的可取之处是他们经常做出相当准确的预测。

事实上，经典的例子是通过图像视觉识别数字或字符。我们的例子要简单得多，可能不太适合这种方法(事实上不是)。这并不以任何方式否定该方法在其他情况下的功效。和以前一样，我们使用虚拟变量创建最后一轮训练和验证数据。

mlpDataTrain <- copy(trainData)
mlpDataTrain[,Year:=as.numeric(Year)]
mlpDataValidation <- copy(validationData)
mlpDataValidation[,Year:=as.numeric(Year)]

ddum <- dummyVars("˜.", data = mlpDataTrain)
mlpDataTrain <- data.table(predict(ddum, newdata = mlpDataTrain))
mlpDataValidation <- data.table(predict(ddum, newdata = mlpDataValidation))
rm(ddum)

模型和种子保持不变。这一次，使用了代表多层感知器的method = "mlpML"。尽管我们不使用主成分分析，但我们会继续扩展和集中我们的数据。第一次运行是通过默认方法完成的，该方法将第二层和第三层清空。这使得第一个隐藏层将被运行，并且默认情况下，模型在第一个层中模拟一些不同数量的节点。由于这本书的创建方式，警告被打印出来(事实上这通常是一个有用的特性)。对于这种模型，会发出许多警告，在这种情况下，这些警告仅显示超出本文范围的模型细微差别。函数supressWarnings用于其同名的结果。

set.seed(12345)
suppressWarnings(
  mlpModel <- train(
    SPAD ~ .,
    data = mlpDataTrain,
    method = "mlpML",
    preProcess = c("scale", "center"),
    metric = "RMSE",
    trControl = trainControl(method = "cv",
                             number = 5)
  )
)
mlpModel

## Multi-Layer Perceptron, with multiple layers
##
## 135 samples
##  20 predictor

##
## Pre-processing: scaled (20), centered (20)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 107, 109
## Resampling results across tuning parameters:
##
##   layer1  RMSE  Rsquared  MAE
##   1       36    0.31      29
##   3       25    0.49      19
##   5       17    0.76      13
##
## Tuning parameter 'layer2' was held constant at a value of 0
##
## Tuning parameter 'layer3' was held constant at a value of 0
## RMSE was used to select the optimal model using the smallest value.

## The final values used for the model were layer1 = 5, layer2 = 0
##  and layer3 = 0.

从输出中可以看出，默认情况下，单个隐藏层被调整为五个节点。summary函数提供了更多的细节，显示了 20 个输入列、5 个隐藏节点和 1 个输出节点的激活函数权重和偏差。这也显示了我们网络的整体布局，20-5-1 布局。

summary(mlpModel)

## SNNS network definition file V1.4-3D
## generated at Fri Nov 02 19:23:07 2018
##
## network name : RSNNS_untitled
## source files :
## no. of units : 26
## no. of connections : 105
## no. of unit types : 0
## no. of site types : 0
##
##
## learning function : Std_Backpropagation
## update function   : Topological_Order
##
##
## unit default section :

##
## act      | bias     | st | subnet | layer | act func     | out func
## ---------|----------|----|--------|-------|--------------|-------------
##  0.00000 |  0.00000 | i  |      0 |     1 | Act_Logistic | Out_Identity
## ---------|----------|----|--------|-------|--------------|-------------
##
##
## unit definition section :

##
## no. | typeName | unitName          | act      | bias     | st | position | act func     | out func | sites
## ----|----------|-------------------|----------|----------|----|----------|--------------|----------|-------
##   1 |          | Input_CntNArbWr   | -0.35224 |  0.25864 | i  |  1, 0, 0 | Act_Identity |          |
##   2 |          | Input_CntNCEatB   | -0.35224 | -0.07158 | i  |  2, 0, 0 | Act_Identity |          |
##   3 |          | Input_`CntNEr&CA` | -0.35224 |  0.17340 | i  |  3, 0, 0 | Act_Identity |          |
##   4 |          | Input_CntNErpnU   | -0.35224 |  0.09913 | i  |  4, 0, 0 | Act_Identity |          |
##   5 |          | Input_`CntNEsA&P` | -0.35224 |  0.02550 | i  |  5, 0, 0 | Act_Identity |          |
##   6 |          | Input_`CntNLtA&C` | -0.35224 | -0.07856 | i  |  6, 0, 0 | Act_Identity |          |
##   7 |          | Input_`CntNME&NA` | -0.35224 |  0.10749 | i  |  7, 0, 0 | Act_Identity |          |
##   8 |          | Input_CntNNrthA   | -0.35224 | -0.17845 | i  |  8, 0, 0 | Act_Identity |          |
##   9 |          | Input_`CntNSb-SA` |  2.81793 |  0.20316 | i  |  9, 0, 0 | Act_Identity |          | 

##  10 |          | Input_Year        |  1.51162 |  0.09500 | i  | 10, 0, 0 | Act_Identity |          |
##  11 |          | Input_NYGD        | -0.84754 | -0.12790 | i  | 11, 0, 0 | Act_Identity |          |
##  12 |          | Input_NYGN        | -0.83754 | -0.26720 | i  | 12, 0, 0 | Act_Identity |          |
##  13 |          | Input_SEPR        |  2.37160 |  0.23106 | i  | 13, 0, 0 | Act_Identity |          |
##  14 |          | Input_ERMA        |  2.28315 | -0.13108 | i  | 14, 0, 0 | Act_Identity |          |
##  15 |          | Input_SESC        | -1.27208 | -0.13525 | i  | 15, 0, 0 | Act_Identity |          |
##  16 |          | Input_FEMA        | -1.28836 |  0.21397 | i  | 16, 0, 0 | Act_Identity |          |
##  17 |          | Input_SPDY        |  0.55710 |  0.19976 | i  | 17, 0, 0 | Act_Identity |          |
##  18 |          | Input_FEIN        | -1.80461 | -0.15568 | i  | 18, 0, 0 | Act_Identity |          |
##  19 |          | Input_MAIN        | -1.77002 |  0.29051 | i  | 19, 0, 0 | Act_Identity |          |
##  20 |          | Input_SPPO        |  2.09958 | -0.29660 | i  | 20, 0, 0 | Act_Identity |          |
##  21 |          | Hidden_2_1        |  1.00000 | 16.57569 | h  |  1, 2, 0 |              |          |
##  22 |          | Hidden_2_2        |  1.00000 | -42.96722| h  |  2, 2, 0 |              |          |
##  23 |          | Hidden_2_3        |  0.00000 | -49.55274| h  |  3, 2, 0 |              |          |
##  24 |          | Hidden_2_4        |  1.00000 | 39.86870 | h  |  4, 2, 0 |              |          |
##  25 |          | Hidden_2_5        |  1.00000 | 21.29272 | h  |  5, 2, 0 |              |          |
##  26 |          | Output_1          | 66.31960 |-1069.78821| o |  1, 4, 0 | Act_Identity |          |
## ----|----------|-------------------|----------|----------|----|----------|--------------|----------|-------
##
##
## connection definition section :
##
## target | site | source:weight

## -------|------|---------------------------------------------------------
##     21 |      | 20:48.96251, 19:-47.13240, 18:-46.89282, 17:29.71989, 16:-31.71886, 15:-30.48963, 14:58.16447, 13:58.57929, 12:-15.94363,
##                 11:-15.49402, 10:21.26738,  9:66.89728,  8:-5.93687,  7:-24.55808,  6:-8.02125,  5:-5.53956,  4:-5.59685,  3:-5.55265,
##                  2:-5.77468,  1:-5.90555
##     22 |      | 20:19.36864, 19:-36.07077, 18:-30.54533, 17:30.76214, 16:-19.48156, 15:-10.87526, 14:40.41421, 13:38.18938, 12: 4.44169,
##                 11: 0.46633, 10:46.79949,  9:49.01194,  8:15.15641,  7:-81.96992,  6:14.43461,  5:-6.70102,  4:-40.07672,  3:12.00658,
##                  2: 7.56544,  1:31.19720
##     23 |      | 20:-12.19030, 19: 2.85565, 18:31.55284, 17:84.06341, 16:77.33264, 15:103.85283, 14:-12.62139, 13:-9.16594, 12:81.62211,

##                 11:81.21730, 10:-194.05856,  9:49.49640,  8:115.78496,  7:-4.44688,  6:179.36331,  5:-26.62095,  4:35.70350,  3:-54.66271,
##                  2:33.46564,  1:-328.59045
##     24 |      | 20:22.24673, 19:-17.17476, 18:-17.65513, 17:-30.85148, 16:-20.34034, 15:-17.87234, 14:19.58477, 13:16.31513, 12:-25.13864,
##                 11:-24.56263, 10:-14.12056,  9:11.75429,  8:-14.03880,  7:-0.54804,  6:62.57944,  5:14.06488,  4:-13.82649,  3:-14.21823,
##                  2:-31.15477,  1:-13.92656
##     25 |      | 20:35.84281, 19:-31.83327, 18:-33.52740, 17: 7.88547, 16:-23.72048, 15:-24.41236, 14:36.01567, 13:37.40243, 12:-16.33773,
##                 11:-15.88420, 10:19.37509,  9:42.81319,  8:-7.29130,  7:10.05342,  6:-4.69724,  5:-11.28413,  4:-7.28304,  3:-7.42553,
##                  2:-7.40186,  1:-7.59370
##     26 |      | 25: 5.30307, 24:31.84159, 23:30.69779, 22:36.21242, 21:-7.03748

## -------|------|--------------------------------------------------------

正如对相对简单的数据集使用过于复杂的方法所暗示的那样，该模型的表现并不那么好。它在验证数据上的表现甚至更差。注意，由于residuals函数被一个必需的包屏蔽了，我们明确地要求residuals的基础R版本。

mean(stats::residuals(mlpModel)ˆ2)

## [1] 462

mean((predict(mlpModel, mlpDataValidation) -
                  mlpDataValidation$SPAD)ˆ2)

## [1] 407

同样，这种方法的一个挑战是任何特定模型本身的精确机制都足够复杂，以至于很难理解是什么驱动了预测。我们再次使用包DALEX恰当命名的explain函数来显示预测器如何与响应交互。

回想一下，explain函数语法将模型用作第一种形式，一个用于区分后面图形的标签(这里我们区分训练和验证)，一个指向我们的data的指针，以及一个我们的响应变量SPAD的断言。

explainMLPt <- explain(mlpModel, label = "mlpt",
               data = mlpDataTrain,
               y = mlpDataTrain$SPAD)

explainMLPv <- explain(mlpModel, label = "mlpv",
               data = mlpDataValidation,
               y = mlpDataValidation$SPAD)

还是像以前一样，explain物体本身并不特别有趣。感兴趣的是能从他们身上找到的信息，函数model_performance是这些中的第一个。重用cowplot包中的plot_grid函数，绘制残差的分布和箱线图。图 8-13 中最左边的图表是残差绝对值的曲线图。记住正态分布残差的一般假设，然后想象绝对值变换将使正态分布看起来像两倍高度的半个分布，我们看到验证集看起来基本上仍然是正态的，尽管它比定型集更容易出错。我们还看到前面章节中的gbm方法不容易出错。第二张图表继续显示同样的事实，箱线图上的范围更大。在这两种情况下，图表也显示了过度训练的永久风险。模型数据看不到的验证数据具有更大的残差。

img/439480_1_En_8_Fig13_HTML.png

图 8-13

对比 SGB 和 MLP 方法的模型性能

performanceMLPt <- model_performance(explainMLPt)
performanceMLPv <- model_performance(explainMLPv)

plot_grid(
plot(performanceMLPt, performanceMLPv, performanceSGBt, performanceSGBv),
plot(performanceMLPt, performanceMLPv, performanceSGBt, performanceSGBv, geom = "boxplot"),
ncol = 2
)

我们使用variable_importance函数来计算在没有各种变量信息的情况下的辍学损失。有趣的是，在这些图中——以及之前的gbm模型中的图——哪些变量是最关键的。回想一下退学后损失最大的变量，如图 8-14 所示。这表明我们的多层感知器模型这些相同的数据非常不同。在这种情况下，这似乎是一个弱点。然而，从其他数据来看，这种差异很可能是一种优势。

img/439480_1_En_8_Fig14_HTML.png

图 8-14

确定主要变量

importanceMLPt <- variable_importance(explainMLPt)
importanceMLPv <- variable_importance(explainMLPv)
plot(importanceMLPt, importanceMLPv, importanceSGBt, importanceSGBv)

如前所述，我们以DALEX函数variable_response结束，它接受一个单变量的附加形式参数。在这种情况下，我们选择部分相关图类型，并在图 8-15 中看到结果图。小学以外的女生人数与模型结果相对照。该图的价值仍然在于，尽管模型本身可能不容易理解(不像简单的回归方程)，但青少年生育率和小学出勤率之间的关系是可以探索的。

img/439480_1_En_8_Fig15_HTML.png

图 8-15

了解小学入学率对少女怀孕的影响

responseMLPprmt <- variable_response(explainMLPt, variable = "SEPR", type = "pdp")
responseMLPprmv <- variable_response(explainMLPv, variable = "SEPR", type = "pdp")

plot(responseMLPprmt, responseMLPprmv, responseSGBprmt, responseSGBprmv)

我们使用如图 8-16 所示的每 1000 人死亡率来结束我们的DALEX探索。在这里，两种模式之间的对比更加鲜明。这再次证明了潜在的方法是完全不同的，因此mlpML可能适用于早期方法未能实现有效预测的其他数据。

img/439480_1_En_8_Fig16_HTML.png

图 8-16

DALEX 每 1，000 人死亡率与少女怀孕

responseMLPdynt <- variable_response(explainMLPt, variable = "SPDY", type = "pdp")
responseMLPdynv <- variable_response(explainMLPv, variable = "SPDY", type = "pdp")
plot(responseMLPdynt, responseMLPdynv, responseSGBdynt, responseSGBdynv)

在结束本节之前，我们考虑一下我们的模型是否调得不够好。由于其复杂性，多层感知器往往有许多调整参数。对于caret，尤其是mlpML，调整参数是隐藏层的数量，以及每个隐藏层中的节点数量。使用我们现在熟悉的tuneGride形式和expand.grid函数，我们让模型探索一千多个选项，以确定一个最佳模型。对于现实生活中的应用程序，感知器方法被认为是可能的最佳模型，拥有数百个节点并不罕见。这就产生了数以万计的变量，每个变量都被模型依次优化。这是对计算资源的重大投资，在这种情况下，将不会有回报。

set.seed(12345)

suppressWarnings(
  mlpModelb <- train(
    SPAD ~ .,
    data = mlpDataTrain,
    method = "mlpML",
    preProcess = c("scale", "center"),
    metric = "RMSE",
    verbose = FALSE,
    trControl = trainControl(method = "cv",
                             number = 5),
    tuneGrid = expand.grid(
      layer1 = 0:10,
      layer2 = 0:10,
      layer3 = 0:10
    )
  )
)
mlpModelb

## Multi-Layer Perceptron, with multiple layers
##
## 135 samples
##  20 predictor

##
## Pre-processing: scaled (20), centered (20)
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 108, 108, 108, 107, 109
## Resampling results across tuning parameters:
## 

##   layer1  layer2  layer3  RMSE  Rsquared  MAE
##    0       0       0       NaN      NaN      NaN
##    0       0       1        41  1.4e-01     30.4
##    0       0       2        36  3.0e-01     27.1
##    0       0       3        26  4.9e-01     17.5
##    0       0       4        18  7.4e-01     14.6
##    0       0       5        18  7.9e-01     14.2
##    0       0       6        16  7.7e-01     11.9
##    0       0       7        14  8.3e-01     10.7
##    0       0       8        16  8.0e-01     12.0
##    0       0       9        15  8.1e-01      9.8
##    0       0      10        11  8.8e-01      8.9
##    0       1       0        37  2.6e-01     29.9
##    0       1       1        33  3.0e-01     25.1
##    0       1       2        36  4.0e-01     28.5
##    0       1       3        38  3.2e-01     28.7
##    0       1       4        35  6.7e-02     24.7
##    0       1       5        33  2.3e-01     24.4
##    0       1       6        35  1.4e-01     26.1
##    0       1       7        34  2.0e-01     28.5
##    0       1       8        56  3.0e-01     50.3
##    0       1       9        41  3.7e-01     36.8
##    0       1      10        41  1.3e-01     32.9
##    0       2       0        28  3.5e-01     18.8
##    0       2       1        42  2.5e-01     32.2
##    0       2       2        40  1.7e-01     33.7
##    0       2       3        36  4.5e-01     27.7
##    0       2       4        34  2.5e-01     24.6
##    0       2       5        34  4.1e-01     28.1
##    0       2       6        32  3.0e-01     23.2
##    0       2       7        35  3.8e-01     27.6
##    0       2       8        39  2.6e-01     29.9
##    0       2       9        40  2.3e-01     31.9
##    0       2      10       249  3.3e-01    243.2
##    0       3       0        24  5.8e-01     19.1
##    0       3       1        40  2.3e-01     30.7
##    0       3       2        40  3.9e-04     33.2
##    0       3       3        38  2.7e-01     30.7
##    0       3       4        35  4.4e-01     26.2
##    0       3       5        36  8.9e-02     30.0
##    0       3       6        32  4.3e-01     21.5
##    0       3       7        32  2.1e-01     25.8
##    0       3       8        46  2.3e-01     37.9
##    0       3       9        30  3.0e-01     21.6
##    0       3      10        48  3.3e-01     42.4
##    0       4       0        22  5.7e-01     17.2
##    0       4       1        51  2.9e-01     42.1
##    0       4       2        38  2.3e-01     30.9
##    0       4       3        35  5.0e-02     27.3
##    0       4       4        36  2.2e-01     24.4
##    0       4       5        35  2.1e-01     29.9

##    0       4       6        31  2.6e-01     23.2
##    0       4       7        38  2.2e-01     28.8
##    0       4       8        31  4.1e-01     23.2
##    0       4       9        33  2.8e-01     27.1
##    0       4      10        35  3.1e-01     27.5
##    0       5       0        24  5.6e-01     16.5
##    0       5       1        37  3.7e-01     29.4
##    0       5       2        32  2.8e-02     25.2
##    0       5       3        34  2.6e-01     25.3
##    0       5       4        31  2.3e-01     22.6
##    0       5       5        40  2.0e-01     31.4
##    0       5       6        33  8.7e-02     25.3
##    0       5       7        30  2.7e-01     22.3
##    0       5       8        35  1.9e-01     25.3
##    0       5       9        28  3.3e-01     21.1
##    0       5      10        34  3.9e-01     27.1
##    0       6       0        18  7.4e-01     14.7
##    0       6       1        34      NaN     24.0
##    0       6       2        37  1.3e-01     26.5
##    0       6       3        32  3.9e-01     22.3
##    0       6       4        35  2.5e-01     24.4
##    0       6       5        33  2.1e-01     26.0
##    0       6       6        52  1.9e-01     42.8
##    0       6       7        30  2.7e-01     23.8
##    0       6       8        36  3.3e-01     27.8
##    0       6       9        54  1.5e-01     45.9
##    0       6      10        30  2.8e-01     23.7
##    0       7       0        22  7.0e-01     17.0
##    0       7       1        38  4.4e-02     30.6
##    0       7       2        42  1.5e-01     35.7
##    0       7       3        35  1.2e-01     24.6
##    0       7       4        33  2.4e-01     25.3
##    0       7       5        39  1.5e-01     32.4
##    0       7       6        32  1.7e-01     24.4
##    0       7       7        32  2.7e-01     26.3
##    0       7       8        41  1.3e-01     33.6
##    0       7       9        33  1.4e-01     25.6
##    0       7      10        31  2.5e-01     22.1
##    0       8       0        15  8.3e-01     11.9
##    0       8       1        34      NaN     25.8
##    0       8       2        33  6.2e-02     25.1

##    0       8       3        30  3.2e-01     22.5
##    0       8       4        43  1.8e-01     37.1
##    0       8       5        39  3.3e-01     31.3
##    0       8       6        34  1.1e-01     26.0
##    0       8       7        34  1.3e-01     24.7
##    0       8       8        45  1.2e-01     38.6
##    0       8       9        32  3.1e-01     23.3
##    0       8      10        50  4.4e-01     42.3
##    0       9       0        15  8.4e-01     11.9
##    0       9       1        34      NaN     24.7
##    0       9       2        34  1.6e-01     26.6
##    0       9       3        34  5.2e-01     25.5
##    0       9       4        43  2.4e-01     33.8
##    0       9       5        44  2.2e-01     37.4
##    0       9       6        37  3.6e-01     30.3
##    0       9       7        39  2.8e-01     27.3
##    0       9       8        35  1.3e-01     27.1
##    0       9       9        31  2.9e-01     22.3
##    0       9      10        51  2.2e-01     41.2
##    0      10       0        19  7.6e-01     15.1
##    0      10       1        44      NaN     35.5
##    0      10       2        33      NaN     26.3
##    0      10       3        37  4.8e-01     29.8
##    0      10       4        33  9.2e-02     24.2
##    0      10       5        35  1.4e-01     25.9
##    0      10       6        35  1.7e-01     27.7
##    0      10       7        32  1.6e-01     23.0
##    0      10       8        67  5.1e-02     62.2
##    0      10       9        31  1.6e-01     23.7
##    0      10      10        32  3.1e-01     25.1
##    1       0       0        39  4.1e-01     31.2
##    1       0       1        37  5.3e-01     29.1
##    1       0       2        40  3.5e-01     31.7
##    1       0       3        34  7.9e-02     24.5
##    1       0       4        36  3.8e-01     24.6
##    1       0       5        33  3.8e-01     24.7
##    1       0       6        35  3.4e-01     27.3
##    1       0       7        37  2.3e-01     27.4

##    1       0       8        30  3.8e-01     21.4
##    1       0       9        38  2.7e-01     30.3
##    1       0      10        40  2.8e-01     32.9
##    1       1       0        37  2.2e-01     29.0
##    1       1       1        42  7.3e-01     32.5
##    1       1       2        38  6.4e-01     31.6
##    1       1       3        33      NaN     25.0
##    1       1       4        36  4.5e-01     24.4
##    1       1       5        32  7.1e-01     26.1
##    1       1       6        34  2.7e-01     25.7
##    1       1       7        39  3.2e-01     31.9
##    1       1       8        37  5.4e-01     30.0
##    1       1       9        37  2.5e-01     28.4
##    1       1      10        35  9.0e-02     27.5
##    1       2       0        40  4.8e-01     34.1
##    1       2       1        34      NaN     25.7
##    1       2       2        33  5.0e-01     24.8
##    1       2       3        36  5.1e-01     26.6
##    1       2       4        40  4.6e-01     32.0
##    1       2       5        33  5.1e-01     23.7
##    1       2       6        41  5.5e-01     33.0
##    1       2       7        32  4.7e-01     23.3
##    1       2       8        33  3.5e-01     25.2
##    1       2       9        38  4.5e-01     29.5
##    1       2      10        39  4.5e-01     30.5
##    1       3       0        32  4.1e-01     24.1
##    1       3       1        34      NaN     26.3
##    1       3       2        34  2.8e-01     27.0
##    1       3       3        41      NaN     31.2
##    1       3       4        33  6.5e-01     23.4
##    1       3       5        31  5.4e-01     23.4
##    1       3       6        41  6.8e-01     33.8
##    1       3       7        44  5.0e-01     32.6
##    1       3       8        57  4.2e-01     47.5
##    1       3       9        41  4.7e-01     34.1
##    1       3      10        42  2.8e-01     32.6
##    1       4       0        38  4.3e-01     28.8
##  [ reached getOption("max.print") -- omitted 1165 rows ]
##
## RMSE was used to select the optimal model using the smallest value.

## The final values used for the model were layer1 = 0, layer2 = 0
##  and layer3 = 10.

mean(stats::residuals(mlpModelb)²)

## [1] 668

mean((predict(mlpModelb, mlpDataValidation) -
                  mlpDataValidation$SPAD)²)

## [1] 552

summary(mlpModelb)

## SNNS network definition file V1.4-3D
## generated at Fri Nov 02 19:34:18 2018
##
## network name : RSNNS_untitled
## source files :
## no. of units : 31

## no. of connections : 210
## no. of unit types : 0
## no. of site types : 0
##
##
## learning function : Std_Backpropagation
## update function   : Topological_Order
##
##
## unit default section :
##
## act      | bias     | st | subnet | layer | act func     | out func
## ---------|----------|----|--------|-------|--------------|-------------
##  0.00000 |  0.00000 | i  |      0 |     1 | Act_Logistic | Out_Identity
## ---------|----------|----|--------|-------|--------------|-------------
##
##
## unit definition section :

##
## no. | typeName | unitName          | act      | bias     | st | position | act func     | out func | sites
## ----|----------|-------------------|----------|----------|----|----------|--------------|----------|-------
##   1 |          | Input_CntNArbWr   | -0.35224 |  0.27237 | i  |  1, 0, 0 | Act_Identity |          |
##   2 |          | Input_CntNCEatB   | -0.35224 |  0.12640 | i  |  2, 0, 0 | Act_Identity |          |
##   3 |          | Input_`CntNEr&CA` | -0.35224 |  0.14994 | i  |  3, 0, 0 | Act_Identity |          |
##   4 |          | Input_CntNErpnU   | -0.35224 |  0.05916 | i  |  4, 0, 0 | Act_Identity |          |
##   5 |          | Input_`CntNEsA&P` | -0.35224 | -0.03508 | i  |  5, 0, 0 | Act_Identity |          |
##   6 |          | Input_`CntNLtA&C` | -0.35224 |  0.20488 | i  |  6, 0, 0 | Act_Identity |          |
##   7 |          | Input_`CntNME&NA` | -0.35224 | -0.18422 | i  |  7, 0, 0 | Act_Identity |          |
##   8 |          | Input_CntNNrthA   | -0.35224 | -0.24506 | i  |  8, 0, 0 | Act_Identity |          |
##   9 |          | Input_`CntNSb-SA` |  2.81793 | -0.11938 | i  |  9, 0, 0 | Act_Identity |          |
##  10 |          | Input_Year        |  1.70822 |  0.19864 | i  | 10, 0, 0 | Act_Identity |          |
##  11 |          | Input_NYGD        | -0.84501 |  0.20640 | i  | 11, 0, 0 | Act_Identity |          |
##  12 |          | Input_NYGN        | -0.83288 |  0.20374 | i  | 12, 0, 0 | Act_Identity |          |
##  13 |          | Input_SEPR        |  2.38957 |  0.21969 | i  | 13, 0, 0 | Act_Identity |          |
##  14 |          | Input_ERMA        |  2.33470 | -0.14782 | i  | 14, 0, 0 | Act_Identity |          |
##  15 |          | Input_SESC        | -1.32473 | -0.08605 | i  | 15, 0, 0 | Act_Identity |          |
##  16 |          | Input_FEMA        | -1.37682 |  0.28955 | i  | 16, 0, 0 | Act_Identity |          |
##  17 |          | Input_SPDY        |  0.44706 |  0.01856 | i  | 17, 0, 0 | Act_Identity |          |
##  18 |          | Input_FEIN        | -1.72852 | -0.10129 | i  | 18, 0, 0 | Act_Identity |          |
##  19 |          | Input_MAIN        | -1.69223 | -0.26429 | i  | 19, 0, 0 | Act_Identity |          |
##  20 |          | Input_SPPO        |  2.06062 | -0.17451 | i  | 20, 0, 0 | Act_Identity |          | 

##  21 |          | Hidden_2_1        |  1.00000 | -8.20578 | h  |  1, 2, 0 |              |          |
##  22 |          | Hidden_2_2        |  0.00000 | -61.29456| h  |  2, 2, 0 |              |          |
##  23 |          | Hidden_2_3        |  1.00000 | -4.93293 | h  |  3, 2, 0 |              |          |
##  24 |          | Hidden_2_4        |  0.00000 | -1.26154 | h  |  4, 2, 0 |              |          |
##  25 |          | Hidden_2_5        |  1.00000 | -136.45082| h |  5, 2, 0 |              |          |
##  26 |          | Hidden_2_6        |  1.00000 | -3.98742 | h  |  6, 2, 0 |              |          |
##  27 |          | Hidden_2_7        |  1.00000 | -38.50706| h  |  7, 2, 0 |              |          |
##  28 |          | Hidden_2_8        |  1.00000 | -59.23545| h  |  8, 2, 0 |              |          |
##  29 |          | Hidden_2_9        |  1.00000 | -13.07257| h  |  9, 2, 0 |              |          |
##  30 |          | Hidden_2_10       |  0.00000 | -3.80823 | h  | 10, 2, 0 |              |          |
##  31 |          | Output_1          | 80.51889 | 165.28026| o  |  1, 4, 0 | Act_Identity |          |
## ----|----------|-------------------|----------|----------|----|----------|--------------|----------|-------
## 

##
## connection definition section :
##
## target | site | source:weight
## -------|------|--------------------------------------------------------
##     21 |      | 20:14.99080, 19:-4.37922, 18:-5.64107, 17:-14.21278, 16:-7.40044, 15:-6.96982, 14: 2.04649, 13: 3.28454, 12:-1.09398,

##                 11:-1.05998, 10:-10.35237,  9: 3.07458,  8: 2.81771,  7: 7.14501,  6:22.43020,  5:-17.89252,  4: 2.94234,  3:-3.41989,
##                 2:-20.86507,  1: 2.99437
##     22 |      | 20:-42.11395, 19:46.16928, 18:46.41003, 17: 5.73816, 16:50.23483, 15:47.74510, 14:-48.54859, 13:-49.08794, 12:49.66853,
##                 11:51.15318, 10:-5.34949,  9:-55.80005,  8:25.68831,  7:-2.84146,  6:-12.38087,  5:-27.17203,  4:23.60743,  3:24.90088,
##                 2: 1.37566,  1:22.42043
##     23 |      | 20: 3.55224, 19:-3.82663, 18:-2.81083, 17:-8.62280, 16:-6.84271, 15:-6.68200, 14: 2.13178, 13: 1.19267, 12:-12.25461,
##                 11:-12.00026, 10: 7.13982,  9:-0.63003,  8:-19.36786,  7: 1.56885,  6:18.87510,  5: 1.15033,  4: 1.62183,  3: 1.71615,
##                 2:-6.58669,  1: 1.57223
##     24 |      | 20:-3.03815, 19: 2.09218, 18: 5.45140, 17: 8.87992, 16: 8.22070, 15:10.87528, 14:-0.88254, 13:-2.19428, 12: 8.49697,
##                 11: 8.60248, 10:-5.41809,  9: 0.47726,  8:10.84176,  7:-27.30257,  6:14.88415,  5:-4.98278,  4: 0.67941,  3: 1.06026,

##                 2: 5.48360,  1:-0.97088
##     25 |      | 0:115.12606, 19:-66.18334, 18:-81.21451, 17:59.74724, 16:-65.24387, 15:-91.23738, 14:48.93630, 13:63.63233, 12:17.89186,
##                 11:13.69802, 10:-49.68809,  9:48.28717,  8:-4.37396,  7:36.57324,  6:-239.25703,  5:-116.16022,  4:45.37873,  3:47.11736,
##                 2:-11.51299,  1:193.68028
##     26 |      | 20: 1.62858, 19:-6.50968, 18:-10.44102, 17:-22.89452, 16:-21.50499, 15:-24.28332, 14:12.23182, 13: 8.47606, 12:-39.59196,
##                 11:-38.13202, 10:14.99837,  9: 1.17484,  8:-42.70610,  7: 0.45940,  6:19.33571,  5:48.32096,  4: 2.15939,  3: 1.45809,
##                 2:-34.17036,  1: 4.24288
##     27 |      | 20:24.32948, 19:-21.69843, 18:-29.03406, 17:-39.08598, 16:-39.70897, 15:-33.39420, 14:22.44779, 13:21.58632, 12:-34.10506,
##                 11:-30.81281, 10: 8.56867,  9:13.75277,  8:15.13938,  7: 4.94741,  6:29.65086,  5:20.66949,  4:-30.40738,  3:-89.47778,

##                 2: 7.78840,  1:27.43818
##     28 |      | 20:74.58337, 19:-73.31054, 18:-54.84992, 17:38.25743, 16:-26.25908, 15:-6.00562, 14:51.08411, 13:57.09294, 12:-2.95093,
##                 11: 5.12013, 10:-112.35419,  9:81.15020,  8:53.54121,  7:63.02877,  6:169.16539,  5:-121.10607,  4:-34.08242,  3:-29.48601,
##                 2:-13.01993,  1:-169.10889
##     29 |      | 20:29.63905, 19:-10.05235, 18:-26.69251, 17:-51.13666, 16:-14.93525, 15:-15.09192, 14:20.62878, 13:20.32225, 12:-9.60404,
##                 11:-9.00413, 10:72.53555,  9:19.84532,  8: 7.09636,  7:60.42725,  6:35.26074,  5:-6.58941,  4: 4.21469,  3:-123.86588,
##                 2:-1.78124,  1: 5.16048
##     30 |      | 20:-1.49977, 19: 0.78230, 18: 3.44946, 17: 9.52544, 16: 5.21607, 15: 7.46949, 14: 2.12706, 13: 0.74737, 12: 7.23410,
##                 11: 7.26661, 10:-4.33287,  9: 1.54910,  8: 7.26920,  7:-28.82655,  6:10.88533,  5: 1.27544,  4: 1.88801,  3: 1.09380,
##                 2: 3.79257,  1: 1.51486
##     31 |      | 30: 9.60220, 29:-8.94521, 28:33.58144, 27: 1.55787, 26: 8.52473, 25:45.79420, 24:-4.24323, 23:-18.14175, 22: 5.18716,
##                 21:18.14762
## -------|------|--------------------------------------------------------

不仅没有回报，使用几个多达十个节点的隐藏层的大胆尝试产生了一个最佳估计模型，该模型只包括一个只有八个节点的层。尽管在这种情况下感觉令人失望，但神经网络领域是机器学习的一个迷人和不断增长的领域。

多层感知器的介绍到此结束。它还总结了我们的监督机器学习方法的介绍。虽然在这一章中，我们只探讨了少数几个模型，我们已经探讨了几种不同的模型类型。最重要的是，通过使用caret，而不是每次练习一个新的结构，你有能力轻松地尝试几十个可能的模型。请记住，每种模型类型都倾向于拥有最适合的特定类型的数据，并且在处理或不处理分类或数字数据的能力方面可能有不同的标准。此外，一些模型对主成分分析有要求或限制。最后，记住模型可能如何处理缺失数据是很重要的。有些方法需要完整的数据，在这种情况下，关于缺失数据的章节可能会有所帮助。其他方法对缺失数据更稳健。

最后，我们委婉地提醒我们的读者，在确定哪种方法是最佳的之后，正确的最后一步是根据所有可用的数据对模型进行最后一次训练——尤其是在可用数据不多的情况下。对于模型调整，使用交叉验证来阻止过度拟合仍然是有帮助的。

8.3 总结

本章介绍并探索了作为多个模型的公共接口的caret包。通过这种权宜之计，检查最佳模型拟合的多种算法变得更加简单。此外，还研究了为建模做准备的数据预处理方法。最后，虽然没有明确编码，但是讨论了将原始数据分为训练集、验证集和测试集的原则。特别关注的概念是，所有模型都根据训练数据进行训练，使用验证数据选择最终的最佳模型，并通过原始的、未使用的测试数据对最终模型的真实性能进行评估。本章使用的功能汇总在表 8-2 中。

表 8-2

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| boxplot() | 生成箱线图，允许目视检查异常值和其他畸形数据。 |
| cbind() | 通过列将数据绑定在一起。 |
| colnames() | 列出数据集中列标题的名称。 |
| confusionMatrix() | 显示分类预测的实际输出与预测输出的实例。 |
| copy() | 创建数据的完整副本，而不是使用指针。这可以防止对副本的编辑级联到原始数据集。它确实能加倍记忆。 |
| cor() | 计算相关性。 |
| createDataPartition() | Caret 软件包功能，创建注意数据分段的训练/测试数据。在这种情况下，这一点很重要，因为数据是区域性的。 |
| dummyVars() | 一个热点编码回归分类数据。 |
| expand.grid() | 使用所有可能组合的所有输入来创建数据框。 |
| explain() | 在使用其他 DALEX 方法之前需要 DALEX 函数。 |
| fancyRpartPlot() | 更丰富多彩的树形图以及额外的有用数据。 |
| gbm | 插入符号的梯度增强机器形式。 |
| hist() | 绘制直方图。 |
| lapply() | 列表应用功能。 |
| mlpML | 多层感知器(多层)形式插入符号。 |
| model_performance() | 创建可绘制剩余对象的 DALEX 函数。 |
| par() | 可用于通过 R 的默认图形包设置图形参数(如用于绘制图形的列或行)。 |
| pca() | pcaMethods 软件包的主成分分析。 |
| plot_grid() | Cowplot 函数用于设置绘制多个图形的列和行—与 base R 的图形包函数 par()形成对比。 |
| prcomp() | 主成分分析从基地 R 统计软件包。 |
| predict() | 给定一个模型，从给定的输入预测输出。 |
| qqnorm() | 绘制 Q-Q 图。 |
| ranger | 插入符号的随机森林形式。 |
| rpart | 脱字符号的分类和回归树形式。 |
| sapply() | 简化应用功能。 |
| scale() | 基数 R 函数缩放和居中数据。 |
| shapiro.test() | 计算夏皮罗-威尔基的常态标准。 |
| stats::residuals() | 根据模型计算残差(base R stats 包版本)。 |
| summary() | 尽可能提供给定输入的摘要。 |
| svmLinear | 插入符号的支持向量机(线性)形式。 |
| svmPoly | 插入符号的支持向量机(多项式)形式。 |
| train() | 通过给定的训练数据训练指定模型的插入符号函数。 |
| trainControl() | 为所提供的培训方法提供输入的形式(和功能)(例如，交叉验证和折叠次数)。 |
| variable_importance() | 计算压差损失的 DALEX 函数。 |
| variable_response() | 计算部分相关性的 DALEX 函数。 |
| View() | 在新的查看窗口中打开数据框/表进行交互式查看。 |

九、缺失数据

缺失数据在几乎所有现实世界的分析中都很常见。本章正式介绍缺失数据的概念，包括描述缺失的常用方法。然后，我们讨论在分析中处理缺失数据的一些潜在方法。我们将在本章中使用的主要软件包是mice软件包，该软件包提供了处理缺失数据和最小化缺失数据对分析结果的影响的强大功能[95]。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(lattice)
library(viridis)
library(VIM)

library(mice)
library(micemd)
library(parallel)

library(data.table)
library(xtable)
library(JWileymisc) # has data

options(width = 70, digits = 2)

9.1 概念背景

当一个或多个变量的观测值缺失时，就会出现数据缺失。丢失数据的潜在原因有很多。缺失数据还会导致数据分析中的问题:

  • 仅从非缺失数据获得的估计值可能有偏差。

  • 丢失数据会减少信息，从而降低效率。

  • 许多工具和软件不具备处理缺失数据的能力。

当数据并非完全随机缺失时，就会出现偏差，因此从观察数据点获得的估计值与所有情况都观察到的估计值存在系统性差异。发生效率损失是因为丢失了一些数据，数据中的信息更少了。此外，许多处理缺失数据的简单技术，如完全病例分析(列表式删除),会丢弃任何变量缺失的病例，即使有其他变量的数据，也会导致效率损失。最后，由于许多工具无法直接处理缺失数据，因此使用缺失数据进行分析通常更加耗时和复杂，因为在使用标准工具之前，可能需要首先处理缺失数据。

有多种方法可以解决所讨论的三个缺失数据问题。但是，在实现特定的方法之前，有一些一般的注意事项。基本上，我们假设目标是估计某个参数， θ ，并获得我们估计的不确定性的估计， V AR ( θ )。我们假设数据是从我们感兴趣的人群中抽取的，尽管这不一定是整个人群。基本的问题是在什么条件和假设下, θ 的无偏估计存在，以及我们如何获得它？

数据通常被分类为

  • 当缺失机制完全独立于 θ 的估计时，完全随机缺失(MCAR)

  • 当缺失机制有条件地独立于 θ 的估计时，随机缺失(MAR)

  • 当缺失机制与 θ 的估计相关联时，非随机缺失(MNAR)

当且仅当数据是 MCAR 时，完整的病例分析(列表式删除)将产生对 θ 的无偏估计。在所有其他情况下，我们必须考虑我们将对缺失过程做出什么样的假设，以及利用我们假设的缺失过程下的可用数据，我们是否可以获得 θ 的无偏估计。

一种表示预期模型和解释假设的因果和缺失过程的系统方法是通过使用图形模型，例如有向无环图(Dag)。Mohan、Pearl 和 Tian [66]使用 Dag 开发了识别无偏估计的方法，并将其扩展到 Mohan 和 Pearl [64]的进一步因果查询，以及测试数据是否为 MCAR 或变量水平 MAR+ [65]。

这项研究有一些实际意义。首先，根据因果过程和缺失机制， θ 的无偏估计可能可恢复，也可能不可恢复，即使是从相同的数据中。因此，考虑模型规格至关重要。简单地调整所有可能的变量是不够的，因为其他工作表明，当向 DAG [73]添加不适当的变量或路径(“后门标准”)时，先前对 θ 的无偏估计可能会变得有偏差。第二，严格解释模型和能够或不能获得无偏估计的条件是复杂的，需要比大多数研究人员和现有科学水平更详细的关于因果过程和遗漏机制的知识或期望。随着所考虑的变量数量的增加，复杂性呈指数增长，尤其是当多个变量缺失时。

虽然在 Mohan 和 Pearl 的理论工作中没有详细说明，但在实际应用时，不仅需要指定正确的变量和路径，而且需要正确指定关系的函数形式。因此，对于P(Y | f(X)，f ( X )可能是一个线性或其他一些非线性函数，而对 θ 的无偏估计将取决于正确指定这种形式。在实践中，至少应该检查观察值的关系形式，并且在必要时允许是非线性的。

虽然提供特定变量的必要背景以确定缺失的数据机制超出了本章的范围，但它们值得考虑，至少如果没有证据来指导决策，这应被视为研究中的一个限制。下一节讨论多重插补作为处理缺失数据的一种方法，并至少提供一些处理未知函数形式的选择。

多重插补

一般

存在许多插补方法。不鼓励使用单一插补(如平均值和热卡插补)和条件平均值插补，不做进一步讨论。无论采用何种插补模型，单一插补的问题在于，它们假设缺失值的预测没有错误。这导致基于估算数据的模型的不确定性估计过低，增加了 1 型错误率。影响程度将取决于缺失数据的数量以及插补模型的准确(或不准确)程度。

除了一次性输入数据集，还可以多次输入。多重插补背后的原理是，多重插补不是为插补生成单一预测值，而是从预测分布中随机抽取。预测分布的分布捕捉了预测中的不确定性，这导致了每个估算数据集中的可变性。

生成多重估算数据的一般过程如下:

  • 有缺失数据的初始数据集。

  • 用初始估计值填充缺失的数据值。初始估计通常很容易生成，例如每个变量的平均值或中值，或者从变量中抽取的随机值。

  • 对于每个变量，建立一个模型，从剩余的变量中预测它。使用模型来预测缺失的数据。对于参数模型，如线性回归，从预测分布中提取随机值(例如，基于预测值和标准偏差的均值正态分布)或从贝叶斯模型的后验分布中提取样本。对于非参数模型，如随机森林模型[28]，不确定性可能通过其他方式引入，如 bootstrapping，以围绕预测值建立经验分布，并从中取样。

  • 重复上一步，直到预测的完整数据集与上一次迭代没有实质性的不同，表明模型已经收敛。这一步是必需的，因为随着初始估计(通常相当糟糕)变得更加准确，所建立的模型可能会随着时间而改变。

  • 重复所有这些步骤，以生成所需数量的多重估算数据集(例如，5，100)。

生成多个估算数据集后，分析会与无遗漏地分析单个数据集略有不同。多重估算数据分别进行分析，结果使用鲁宾规则进行汇总[58]。简单来说:

  • 模型在每个估算数据集中单独进行估计。

  • 对每个模型的许多参数进行平均，包括回归系数、平均差异和预测值。一些值不是通过平均直接组合的，例如残差方差或相关的估计，其通常在平均之前被转换。

  • 汇总结果的不确定性估计(例如，标准误差)包括两个可变性来源:

    • 每个模型参数的平均不确定性

    • 模型之间参数估计的可变性

  • 基于平均参数和不确定性估计的统计测试，从模型和不同的数据集获取不确定性。

一般来说，任何分析都应该在单个数据集上进行，只有在最后一步，结果才应该跨数据集进行汇总。例如，如果目标不仅仅是回归模型，而是生成预测值的图表，那么应该为每个估算数据集单独生成预测值，然后将预测值组合起来。不要首先合并回归模型结果，然后使用合并的模型来生成预测。关于多重插补的一个常见误解是，只应插补自变量，而不应插补因变量。模拟表明，不输入因变量会增加偏差[67]，建议输入所有变量[38]

多重插补方法

一般来说，乘以估算数据的模型采用两种形式之一:

  • JM:一种联合模型(JM ),其中指定了所有变量的联合多元分布。通过从条件分布中提取来估算值。

  • FCS:一个完全条件规范(FCS ),其中为每个缺失变量建立一个单独的模型，使用所有其他变量作为预测因子。每个缺失变量的值通过从该特定变量的模型的条件密度中提取来估算。

可以证明 JM 方法在理论上是有效的【85】，这是相对于 FCS 方法的一个优势，FCS 方法目前缺乏强有力的理论依据来解释为什么它们可以产生有效的结果。

JM 方法的一个挑战是，它要求多元分布(1)是特定的，(2)是数据的合理表示，以及(3)在分析上是易处理的。通常，这些条件中的一些(但不是全部)很容易满足。例如，使用多元正态(MVN)模型是相对容易指定的，并且在分析上易于估计和借鉴。然而，只有在研究案例的子集里，所有带有缺失数据的变量才能被合理地解释为正态分布。例如，一旦引入一个二元协变量(如性别)，MVN 模型就开始变得不现实。在数据不太可能真实 MVN 的情况下，MVN 模型有时仍被用作近似值，但这凸显了 JM 的一个缺点。MVN 模型不是唯一可以指定的多元分布类型。然而，涉及正态分布和二分或计数型变量的多元分布变得非常难以估计和提取，通常使它们难以分析。

我们认为，JM 方法在实际环境中特别困难，因为许多带有缺失数据的应用研究问题(如流行病学研究、纵向研究)通常具有包含许多协变量和焦点预测因子的模型，更不用说退出或缺失的潜在决定因素了，尽管这些因素不是最终分析模型的一部分，但可能是改善缺失数据模型的关键因素。如此多的不同变量都遵循任何方便的多元分布似乎很少见，这使得 JM 方法在许多情况下不切实际。

尽管缺乏强有力的理论基础来支持它作为一种合适的技术，但 FCS 方法是 JM 方法的一种令人信服的替代方法。FCS 方法也称为通过链式方程的多重插补(MICE ),因为有一系列独立的方程。在有 k 个变量的地方，不是定义一个 k 维的多元密度，而是定义 k 维的单变量密度。这既简化了计算方面，又使得使用任何可用的分布相对容易，从而适应各种各样的结果(例如，正态连续、泊松计数、二项式二元、伽玛严格正连续、结果等)。).FCS 的另一个优点是可以为预测因子和每个结果之间的关系指定非常灵活的函数形式。

进行 FCS 的一种标准方式是从每个变量的(条件)后验分布中获取 Gibbs 样本，通常形式为P(YI|Y—I，θ i )对于 1 中的 i ，… ，k 。这些可用于“填充”每个 k 结果的缺失数据。一旦所有结果都被填入，现在可以使用每个结果的预测因子的观察和填入信息重复该过程，并且该过程反复重复直到达到收敛。一旦实现收敛，就可以从条件后验分布中抽取所需数量的样本，以生成所需数量的多重估算数据集。

Van Buuren、Brand、Groothuis-Oudshoorn 和 Rubin [94]以及 Van Buuren 和 Groothuis-Oudshoorn [95]对 FCS (MICE)进行了详细描述。FCS 的一个问题是条件分布可能不兼容。当条件分布不相容时，可变插补的顺序很重要，尽管这些影响可能相对较小。Hughes 及其同事[46]已经讨论了条件分布相容的条件，从而产生了与联合分布相同的收益，他们还提供了一个模拟来检验分布相容和不相容时 FCS 的性能。总的来说，虽然理论上不如 JM 方法合理，但在模拟和实践中，FCS 似乎表现得非常好，并且，由于其限制较少的假设，当 JM 假设不成立时，它可以胜过 JM 方法。由于增加了灵活性，这一章集中于估算的 FCS 方法。

非线性效应和非正常结果

在许多应用中，默认的假设是变量之间是线性相关的。然而，这种假设应该检查，非线性函数形式是允许的，如理论或数据所规定的。即使当数据是 MAR 时，为了使估计无偏，必须正确地指定模型，包括正确的变量和正确的函数形式。

以前，所谓的被动插补用于非线性项。例如，对于两个变量之间的相互作用， X 1 ，X 2 ，每个变量将被单独插补，然后经过分析中的多重插补后，基于插补的 X 1 和 X 将形成乘积项，X1X2模拟表明，这种被动插补会导致有偏估计[101]。相反，应将这些非线性转换纳入多重插补，首先创建变量，然后将其作为附加变量纳入插补模型。交互作用、平方或其他转换变量有时被称为“另一个变量”(JAV)。然而，这种方法的一个限制是，X1 和$$ {X}_1² $$之间的关系(或交互)丢失了。Vink 和 van Buuren [100]开发了另一种方法，称为多项式组合方法，既能产生无偏估计，又能保持X1 和$$ {X}_1² $$之间的关系。然而，据我们所知，它目前只适用于平方项，不适用于不同变量之间的相互作用，也不适用于高阶多项式，尽管理论上这项工作可能会推广。

一个相关的问题是偏斜或非正态分布变量。一种直观的方法是尝试一些规范化转换；然而，von Hippel [102]表明，这导致了不太理想的结果，并且在许多情况下建议简单地使用正常模型。备选方案是对每个结果使用(正确的)分布(例如，伽玛、贝塔等。).目前，大多数模拟和研究仅检查了正态、二项式结果的多重插补的特性，检查有序结果的较少；因此，对于来自替代分布的变量几乎没有指导。此外，大多数软件实现允许相当有限的一组已知发行版。

正如交互作用或其他非线性项应该在需要的地方被估算一样，如果一些其他变量 Y 不仅取决于 X 1 ， X 2 ，而且还取决于它们的交互作用X1X2，为了正确地指定模型，交互作用项必须作为预测项包含在 FCS 中。如果 Y 依赖于X1，X2，X1X2，但是X1X2在插补模型中被省略，结果将但是，如果 Y 依赖于 X 1 ， X 2 ，而是 X 1 ， X 2 ，X1X2Bartlett、Seaman、White 和 Carpenter [3]对此进行了更详细的探讨，他们表明实质性分析模型可以是插补模型的限制性版本，但反之则不然。具体来说，他们建议确保插补模型与实体模型兼容，或者至少是半兼容的(即实体模型是插补模型的限制版本)。

用于插补的 GLMs

FCS 方法不需要任何特定的模型，但最常用的一类模型是广义线性模型(GLMs ),如连续、近似正态分布变量的线性回归或二分变量的逻辑回归。对于感兴趣的读者，GLMs 在第 3 和 4 章节中有更深入的介绍。GLMs 的一个好处是，它们是许多分析师熟悉的分析模型，更容易理解它们如何用于多重插补。此外，大多数 glm 在现代计算机上的估计速度非常快，这使得它成为一种计算成本相对较低的模型。尽管 GLMs 很受欢迎，速度也很快，但它也有缺点。

首先，GLMs 默认所有变量和链接函数尺度上的结果之间的线性关系。尽管对任何 GLM 模型来说都是如此，但多重插补通常涉及许多关系，这一事实加剧了这一问题。例如，考虑一个相对简单的研究问题:肥胖与血压有关吗？血压本身有两个组成部分:收缩压和舒张压。此外，许多因素可能会混淆这种关联，相关的协变量也是如此，两个可能的候选因素是年龄和社会经济地位。最后，还应包括与缺失数据相关的因素。例如，如果已知被雇佣的参与者更有可能丢失数据，那么在插补模型中包括这一点是有意义的。在这个例子中，我们刚刚开始考虑与肥胖、血压和潜在缺失相关的无数因素，我们正在处理六个变量。归根结底，我们关心的只是压力、年龄和社会经济地位(三个变量)与血压(两个变量)的关系，所以我们只需要担心六个独特的两两关联。然而，对于插补模型，我们有 15 独特的成对关联。如果其中任何一个不是线性的，要么我们的插补模型将是错误的，要么我们需要识别哪个不是线性的，并包括适当的函数形式(例如，二次函数等。).许多应用研究问题将包括更多的变量，要么是因为基础研究问题涉及更多的变量，要么是因为有更多的相关协变量或更多的因素可能与遗漏有关。让分析师手动决定每个可能的成对关联的函数形式很快变得不切实际(例如，10 个变量有 45 个唯一的对；20 个变量的 190 个唯一对，等等。) .

第二，默认情况下，GLMs 不包括变量之间的任何交互。同样，随着插补模型中变量数量的增加，分析师手动指定可能的交互次数很快变得不切实际。

第三，特别是在较小的数据集或某些应用中，要包含的变量的数量相对于观察值的数量可能很大。在这些情况下，GLMs 将倾向于过度拟合数据，特别是对于二分结果，可能导致完全分离和可估计性挑战，基本问题是 GLMs 默认不包括任何变量选择方法。

插补游戏

面对未知函数形式的挑战，一个自然的解决方案是利用试图根据经验逼近未知形式的模型。一类这样的模型是广义加性模型(gam)[40，122]，它使用平滑器和罚函数来试图逼近函数形式，而不会(非常)过度拟合数据。“基本”GAM 的扩展是位置、比例和形状参数的 GAM(GAMLSS)。GAMLSS 不仅允许对位置(如正态分布中的平均值)进行建模，还允许分布的规模(方差)作为预测值以及分布形状的函数[78，88]。尽管 gam 通常发展良好(如[40，122，123])，但很少有研究检验它们在多重插补中的特性。

de Jong、van Buuren 和 Spiess [27]进行的一项模拟研究表明，在多重插补中使用 GAMLSS 可以获得良好的结果，从而允许出现偏斜和非正态分布的结果以及非线性效应。总的来说，使用 GAMLSS 的插补比使用 GLMs 提供了更好的覆盖面；然而，值得注意的是，模拟研究[27]只检查了几个变量。不收敛和其他计算挑战可能会出现在应用研究设置与许多预测。

估算的 RFs

随机森林(RFs)是一种机器学习类型，广泛用于预测建模，因为它们往往会提供出色的结果[16]。就插补而言，RFs 比之前讨论的替代方法有几个优势。

我们在插补中注意到的一个挑战是需要正确捕捉所有变量之间的函数形式，它可能不是线性的。gam 对此提供了一个可能的解决方案，但是 RFs 也可以解决这个问题，因为树允许在变量的不同点进行分割，从而允许非线性关联。

与 gam 或 GLMs 不同，RFs 还可以识别变量之间的重要交互。即使系统地筛选所有可能性是不切实际的，RFs 也能有效地识别交互。RFs 的这一特性提供了一个很大的优势，因为有十个或更多的变量，研究人员实际上不可能指定相关变量之间的所有相互作用，即使包括所有的相互作用也会导致一个复杂的模型，可能需要非常大的样本量。

最后，RFs 是有利的，因为它们本质上具有一定程度的内置变量选择。RFs 只在有助于预测结果的变量上分裂。因此，与 GLMs 或 GAMs 不同，RFs 可以更好地处理相对于数据集中的病例数而言插补模型中存在大量变量的病例。

虽然随机森林在预测和机器学习文献中非常常用，但评估其插补性能的研究相对较少。Stekhoven 和 Bühlmann [90]在较早的一篇研究 RF 插补的论文中提出了一个生物信息学领域的 RF 模型插补以及一个R包missForest。然而，Stekhoven 和 Bühlmann [90]建议仅使用 RFs 进行单一插补，如前所述，这会因缺失数据而导致低估不确定性。最近，另外两个团队独立开发了一种使用 RFs 进行多重插补的方法，并展示了这些技术的良好性能[28，86]。在这两种情况下，模型都依赖于自举来传播输入缺失值的不确定性，以生成多个估算数据集。

其他情况

除了到目前为止讨论的多种插补情况之外，还有一些更特殊的情况需要其他方法。在事件发生时间或生存结果的情况下，多重插补是复杂的，White 和 Royston [108]讨论了这些情况下协变量的插补。对于多级数据的多重插补，van Buuren [93]提供了一份最新概述。虽然不是直接多重插补，但 Goldstein、Carpenter 和 Browne [37]描述了一个多水平模型，该模型考虑了反应和协变量(包括非正态结果/协变量和交互项)中的缺失数据。然而，这种分析的复杂性在许多情况下可能令人望而却步。

9.2 R示例

为了应用所讨论的缺失数据方法，我们将使用模拟数据来密切匹配日常研究。讨论的大多数插补模型仅适用于单水平数据，因此我们将从将每日数据折叠成整个研究的平均值开始。

## load example dataset
data("aces_daily")
draw <- as.data.table(aces_daily)[order(UserID)]
davg <- na.omit(draw[, .(
  Female = na.omit(Female)[1],
  Age = na.omit(Age)[1],
  SES_1 = na.omit(SES_1)[1],
  EDU = na.omit(EDU)[1],
  STRESS = mean(STRESS, na.rm = TRUE),
  SUPPORT = mean(SUPPORT, na.rm = TRUE),
  PosAff = mean(PosAff, na.rm = TRUE),
  NegAff = mean(NegAff, na.rm = TRUE)),
  by = UserID])

接下来，我们想在数据中添加一些缺失。对于这个例子，我们将让失踪的概率取决于感知的支持和压力水平的组合。然后，对于一些变量，我们基于这些概率产生缺失。我们随机设置压力和支持为缺失。

## missing depending on support and stress
davg[, MissingProb := ifelse(
         SUPPORT < 5,
           ifelse(STRESS > 2.5, .4, .0),
           ifelse(STRESS > 2.5, 0, .4))]

set.seed(1234)
davgmiss <- copy(davg)
davgmiss[, PosAff := ifelse(rbinom(
             .N, size = 1, prob = MissingProb) == 1,
             NA, PosAff)]
davgmiss[, NegAff := ifelse(rbinom(
             .N, size = 1, prob = MissingProb) == 1,
             NA, NegAff)]
## random missingness on stress and support
davgmiss[, STRESS := ifelse(rbinom(
             .N, size = 1, prob = .1) == 1,
             NA, STRESS)]
davgmiss[, SUPPORT := ifelse(rbinom(
             .N, size = 1, prob = .1) == 1,
             NA, SUPPORT)]
davgmiss[, Age := ifelse(rbinom(
             .N, size = 1, prob = .1) == 1,
             NA, Age)]
davgmiss[, SES_1 := ifelse(rbinom(
             .N, size = 1, prob = .1) == 1,
             NA, SES_1)]
davgmiss[, Female := factor(ifelse(rbinom(
             .N, size = 1, prob = .1) == 1,
             NA, Female), levels = 0:1,
             labels = c("Male", "Female"))]
davgmiss[, EDU := factor(ifelse(rbinom(
             .N, size = 1, prob = .1) == 1,
             NA, EDU), levels = 0:1,
             labels = c("< Uni Graduate", "Uni Graduate +"))]
## drop unneeded variables to make analysis easier
davgmiss[, MissingProb := NULL]
davgmiss[, UserID := NULL]

现在开始，直观地检查数据集中缺失的数据模式是有帮助的。这可以使用图 9-1 所示的VIM包和aggr()函数来完成。左侧显示每个变量总计中缺失数据的百分比。右侧显示了不同研究变量的不同遗漏模式，以及它们的比例。至关重要的是，我们可以看到，尽管总体数据缺失率并不高(约 15%)，但只有大约三分之一的参与者实际上拥有所有变量的完整数据。这将使一个完整的案件分析有大量的信息和权力的损失。

img/439480_1_En_9_Fig1_HTML.png

图 9-1

通过变量和缺失模式对缺失进行可视化总结

ggr(davgmiss, prop = TRUE,
     numbers = TRUE)

VIM包还有一个功能，使用marginplot()函数帮助识别缺失是否依赖于另一个变量。图 9-2 中显示的这些图表包含了相当多的信息。中心是成对呈现数据的基本散点图。空白显示缺失数据的分布，箱线图显示每个变量的分布，根据另一个变量是否缺失进行分层。这些图表明，当情感缺失时，压力会更大，支持会更低。

img/439480_1_En_9_Fig2_HTML.png

图 9-2

缺失数据的二元图。中间的点表示没有丢失的数据。空白点表示缺失的数据。箱线图根据另一个变量是否存在来总结每个变量。

par(mfrow = c(2, 2))
marginplot(davgmiss[,.(STRESS, NegAff)])
marginplot(davgmiss[,.(SUPPORT, NegAff)])
marginplot(davgmiss[,.(STRESS, PosAff)])
marginplot(davgmiss[,.(SUPPORT, PosAff)])

我们可以应用统计检验来检查一个变量的缺失是否与另一个变量相关，例如，使用如下所示的 t 检验。我们没有看到压力和情感支持的显著差异。然而，一般来说，不鼓励依赖统计显著性来确定是否将一个变量纳入插补模型，因为根据影响的大小和样本大小，结果可能不具有统计显著性，但可能会对基于多重插补数据分析的模型的结果产生影响。

## does age differ by missing on negative affect?
t.test(Age ~ is.na(NegAff), data = davgmiss)$p.value

## [1] 0.9

## does age differ by missing on positive affect?
t.test(Age ~ is.na(PosAff), data = davgmiss)$p.value

## [1] 0.14

## does stress differ by missing on negative affect?
t.test(STRESS ~ is.na(NegAff), data = davgmiss)$p.value

## [1] 0.89

## does stress differ by missing on positive affect?
t.test(STRESS ~ is.na(PosAff), data = davgmiss)$p.value

## [1] 0.17

## does social support differ by missing on negative affect?
t.test(SUPPORT ~ is.na(NegAff), data = davgmiss)$p.value

## [1] 0.49

## does social support differ by missing on positive affect?
t.test(SUPPORT ~ is.na(PosAff), data = davgmiss)$p.value

## [1] 0.17

带回归的多重插补

在本例中，我们将使用回归方法对数据进行乘法估算。由于多重插补包含随机成分(如 bootstrapping)，每次进行插补时，最终结果都会随机变化。为了使结果可重复，可以设置随机种子。为了举例和加快速度，我们只生成六个估算数据集。对于实际研究，使用更多(例如，50，100)可能有助于确保即使使用不同的种子，合并模型的最终结果也将或多或少相同。

下面的代码使用来自mice包的mice()函数来估算数据集中任何缺失的数据，davgmiss。我们要求六个插补，用m = 6。默认方法指定用于连续(?? 中的数字)变量、二进制变量、名义(多进制)变量和有序分类变量的模型类型。我们从算法的十次迭代开始，为可重复性设置种子，并在插补期间关闭消息。对system.time()的调用将返回插补所用的秒数。注意mice()的结果是一个mids类对象，它包含原始数据和所有多重插补，在一个对象中。

system.time(mi.1 <- mice(
  davgmiss,
  m = 6,   maxit = 10,
  defaultMethod = c("norm", "logreg", "polyreg", "polr"),
  seed = 1234, printFlag = FALSE)
)

##    user  system elapsed
##     2.9     0.0     3.0

使用有限次数的迭代，模型可能不会收敛。收敛可以通过图来检查，类似于贝叶斯方法。每个插补用单独的颜色绘制，如果结果变得稳定，则结果收敛，并且每个单独的插补与另一个插补没有系统的不同(这可能表明收敛到单独的局部最大值)。如果对收敛性有疑问，我们可以使用mice.mids()进行进一步的迭代，而不必重新运行最初的十次迭代。结果似乎相当稳定，没有明确的迹象表明系统差异提供了合理的证据收敛。

img/439480_1_En_9_Fig3_HTML.png

图 9-3

会聚的 Mice 诊断

## plot convergence diagnostics
plot(mi.1, PosAff + NegAff + SUPPORT ~ .it | .ms)

## run an additional iterations
system.time(mi.1 <- mice.mids(
  mi.1, maxit = 10,
  printFlag = FALSE)
)

##    user  system elapsed
##       3       0       3

## plot convergence diagnostics
plot(mi.1, PosAff + NegAff + SUPPORT ~ .it | .ms)

除了检查模型是否收敛之外，评估估算值是否合理也很有帮助。这可以通过使用mice包中的densityplot()绘制观察值和估算值的分布图来完成。除了单变量评估，还可以使用mice包中的xyplot()函数测试双变量关系。蓝色用于原始观察数据，红色用于估算数据。一个小问题是，使用基于回归的方法，插补是在数据范围之外产生的，特别是预测影响值低于 1，这超出了范围。虽然这可能看起来不理想，但建议保留这些值，因为排除它们或强制它们为 1 会减少预测中的可变性，并会使模型看起来比它应有的更确定。

img/439480_1_En_9_Fig5_HTML.png

图 9-5

观察数据和估算数据的单变量密度图，通过插补分开

img/439480_1_En_9_Fig4_HTML.png

图 9-4

在更多次迭代后对收敛进行 Mice 诊断

densityplot(mi.1, ˜ PosAff + NegAff + SUPPORT + STRESS)

xyplot(mi.1, NegAff + PosAff ˜ STRESS + SUPPORT)

如果在这个阶段，我们确信插补模型中没有发生任何问题，我们可以继续拟合我们的主要分析。mice包包含了with()函数的方法，当与从mice()返回的mids类对象一起使用时，该函数将给定的R表达式应用于每个估算数据集。首先，我们将运行一个线性回归模型，以积极情感作为结果，压力作为主要解释因素，其他因素作为协变量。结果是一个mira类对象，它是一个包含在单独的多重估算数据集上重复的相同分析的对象类。如果我们打印这个对象，我们会得到每个回归模型的结果。

img/439480_1_En_9_Fig6_HTML.png

图 9-6

带有估算数据的二元散点图，由观察数据和估算数据分别着色

lm.1 <- with(mi.1, lm(PosAff ~ STRESS + Age + EDU + Female))

lm.1

## call :
## with.mids(data = mi.1, expr = lm(PosAff ~ STRESS + Age + EDU +
##     Female))
##
## call1 :
## mice.mids(obj = mi.1, maxit = 10, printFlag = FALSE)
##
## nmis :
##  Female     Age   SES_1     EDU  STRESS SUPPORT  PosAff  NegAff
##      22      24      23      15      23      21      32      45
##
## analyses :
## [[1]]
##
## Call:
## lm(formula = PosAff ~ STRESS + Age + EDU + Female)
##
## Coefficients:
##       (Intercept)             STRESS                Age
##            4.1174            -0.2194            -0.0459
## EDUUni Graduate +       FemaleFemale
##           -0.0715             0.0450
##
##
## [[2]]
##
## Call:
## lm(formula = PosAff ~ STRESS + Age + EDU + Female)
##
## Coefficients:
##       (Intercept)             STRESS                Age
##            4.0037            -0.1697            -0.0415
## EDUUni Graduate +       FemaleFemale
##           -0.0967            -0.0464 

##
##
## [[3]]
##
## Call:
## lm(formula = PosAff ~ STRESS + Age + EDU + Female)
##
## Coefficients:
##       (Intercept)             STRESS                Age
##            3.8330            -0.2022            -0.0266
## EDUUni Graduate +       FemaleFemale
##           -0.0267            -0.2389
##
##
## [[4]]
##
## Call:
## lm(formula = PosAff ~ STRESS + Age + EDU + Female)
##
## Coefficients:
##       (Intercept)             STRESS                Age
##            4.2129            -0.2214            -0.0466
## EDUUni Graduate +       FemaleFemale
##           -0.0529            -0.0799
##
##
## [[5]]
##
## Call:
## lm(formula = PosAff ~ STRESS + Age + EDU + Female)
##
## Coefficients:
##       (Intercept)             STRESS                Age 

##            3.6608            -0.1867            -0.0221
## EDUUni Graduate +       FemaleFemale
##           -0.1658            -0.0691
##
##
## [[6]]
##
## Call:
## lm(formula = PosAff ~ STRESS + Age + EDU + Female)
##
## Coefficients:
##       (Intercept)             STRESS                Age
##            3.6097            -0.1872            -0.0232
## EDUUni Graduate +       FemaleFemale
##           -0.0190            -0.0252

我们可以检查单个模型进行模型诊断，如图 9-7 所示。

img/439480_1_En_9_Fig7_HTML.png

图 9-7

来自第一个估算数据集的线性回归模型诊断

par(mfcol = c(2,2 ))
plot(lm.1$analyses[[1]]) 

par(mfcol = c(1,1))

然而，一般来说，我们对单个模型不太感兴趣，相反，我们希望看到跨模型的总体结果。mice包中的pool()函数就是用来做这件事的。与summary()结合，我们可以得到通常的线性回归汇总表，但基于来自多重估算数据的汇总结果。结果是汇集的回归系数、它们的标准误差、t 值、估计的自由度、p 值和置信区间。为了很好地为这本书格式化，我们使用了xtable()函数，结果在表 9-1 中。为此，不使用LaTeX，只需运行summary(pool(lm.1), conf.int = TRUE)。

表 9-1

多个估算数据的回归结果汇总

|   |

估计

|

Std。错误

|

统计的

|

df

|

p 值

|

2.5%

|

97.5%

|
| --- | --- | --- | --- | --- | --- | --- | --- |
| (截取) | Three point nine one | Zero point six eight | Five point seven one | Eighty-nine point eight nine | Zero | Two point five five | Five point two seven |
| 强调 | −0.20 | Zero point zero four | −4.48 | Fifty point five three | Zero | −0.29 | −0.11 |
| 年龄 | −0.03 | Zero point zero three | −1.07 | Eighty-eight point eight eight | Zero point two nine | −0.10 | Zero point zero three |
| 我的优势是毕业+ | −0.07 | Zero point one five | −0.50 | Eighty-three point seven eight | Zero point six two | −0.36 | Zero point two two |
| 女性女性 | −0.07 | Zero point one five | −0.45 | Nineteen point nine eight | Zero point six five | −0.39 | Zero point two five |

xtable(summary(pool(lm.1), conf.int=TRUE),
  digits = 2,
  caption = "Regression results pooled across multiply imputed data",
  label = "tmd-pooledres1")

为了从模型中得到汇集的 R 2 ，我们可以使用pool.r.squared()函数。

pool.r.squared(lm.1)

##      est lo 95 hi 95 fmi
## R² 0.14 0.054  0.26 NaN

一些额外的列通过指定参数type = "all"提供关于缺失量和缺失信息部分的信息，这是缺失数据对特定系数影响程度的指标。这些结果见表 9-2 。

表 9-2

包含附加信息的多重估算数据的回归结果汇总

|   |

估计

|

Std。错误

|

统计的

|

df

|

p 值

|

2.5%

|

97.5%

|

里弗

|

希腊字母的第 11 个

|

fonds mon é taire international 国际货币基金组织

|

取消栏

|

b

|
| --- | --- | --- | --- | --- | --- | --- | --- | --- | --- | --- | --- | --- |
| (截取) | Three point nine one | Zero point six eight | Five point seven one | Eighty-nine point eight nine | Zero | Two point five five | Five point two seven | Zero point one eight | Zero point one five | Zero point one seven | Zero point four | Zero point zero six |
| 强调 | −0.20 | Zero point zero four | −4.48 | Fifty point five three | Zero | −0.29 | −0.11 | Zero point three three | Zero point two five | Zero point two eight | Zero | Zero |
| 年龄 | −0.03 | Zero point zero three | −1.07 | Eighty-eight point eight eight | Zero point two nine | −0.10 | Zero point zero three | Zero point one eight | Zero point one five | Zero point one seven | Zero | Zero |
| 我的优势是毕业+ | −0.07 | Zero point one five | −0.50 | Eighty-three point seven eight | Zero point six two | −0.36 | Zero point two two | Zero point one nine | Zero point one six | Zero point one eight | Zero point zero two | Zero |
| 女性女性 | −0.07 | Zero point one five | −0.45 | Nineteen point nine eight | Zero point six five | −0.39 | Zero point two five | Zero point eight one | Zero point four five | Zero point four nine | Zero point zero one | Zero point zero one |

xtable(summary(pool(lm.1), type = "all", conf.int=TRUE),
  digits = 2,
  caption = "Regression results pooled across multiply imputed data with additional information",
  label = "tmd-pooledres1alt")

最后，假设我们想要得到压力和积极情感之间关系的预测回归线。我们首先建立一个数据集，然后从每个独立的回归模型中生成预测，然后对结果进行平均。

img/439480_1_En_9_Fig8_HTML.png

图 9-8

压力和积极情感之间关联的线性回归模型的汇总预测

newdat <- data.frame(
  STRESS = seq(from = 0, to = 6, length.out = 100),
  Age = mean(davg$Age),
  EDU = factor("< Uni Graduate", levels = levels(davgmiss$EDU)),
  Female = factor("Female", levels = levels(davgmiss$Female)))

newdat$PosAff <- rowMeans(sapply(1:6, function(i) {
  predict(lm.1$analyses[[i]], newdata = newdat) 

}))

ggplot(newdat, aes(STRESS, PosAff)) +
  geom_line()

并行处理的多重插补

虽然基于回归的插补往往相当快，但随着更多的案例、更多的变量、更多的插补，特别是使用更复杂的插补方法(如随机森林),多重插补可能需要大量的计算和时间。幸运的是，如果可以的话，并行化可以直接利用多个内核。

此示例显示了如何使用一种在 Windows、Linux 和 Mac 操作系统上都适用的方法来并行化多重插补。在 Linux 和 Mac 上有更简单的策略，但是这种方法是最具交叉兼容性的。

首先，我们创建一个包含两个工作进程的本地集群。如果您有更多的内核，您可以将此设置得更高。如果只有两个内核，则设置为两个，以此类推。接下来，我们确保将包加载到每个工作进程中。由于我们将让每个工人只进行一次插补，为了使结果可复制，我们需要为每次插补单独随机种子。最后，我们需要将数据集和随机种子导出到每个工作者进行处理。

cl <- makeCluster(2)
clusterExport(cl, c("book_directory", "checkpoint_directory" ))

clusterEvalQ(cl, {
  library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)
  library(mice)
  library(randomForest)
  library(data.table)
})

## [[1]]
##  [1] "data.table"    "randomForest"  "mice"          "lattice"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"
##
## [[2]]
##  [1] "data.table"    "randomForest"  "mice"          "lattice"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      

"RevoUtilsMath"
## [13] "methods"       "base"

imputation_seeds <- c(
  403L, 2L, 2118700268L, 1567504751L,
  -161759579L, -1822093220L)

clusterExport(cl, c("davgmiss", "imputation_seeds"))

现在一切都设置好了，我们可以从 1 到 6 循环，得到我们的 6 个多重估算数据集。每一个都被传递给一个实际运行的工作进程，使用parLapplyLB()函数。

system.time(mi.par <- parLapplyLB(cl, 1:6, function(i) {
mice(
  davgmiss,
  m = 1,   maxit = 20,
  defaultMethod = c("norm", "logreg", "polyreg", "polr"),
  seed = imputation_seeds[i])
}))

##    user  system elapsed
##     0.0     0.0     3.5

最后，之前因为我们要求mice()直接做多重插补，所以插补已经合并成一个大对象了。为了分开并行处理，我们每次只要求一个插补，所以我们需要手动合并它们，我们用ibind()函数创建一个具有六个插补的mids类对象。当我们打印结果时，我们可以看到多重插补的数量是 6。

## combine the separate imputations into a single object
mi.par2 <- ibind(mi.par[[1]], mi.par[[2]]) 

for (i in 3:6) {
  mi.par2 <- ibind(mi.par2, mi.par[[i]])
}

mi.par2

## Class: mids
## Number of multiple imputations:  6
## Imputation methods:
##   Female      Age    SES_1      EDU   STRESS  SUPPORT   PosAff
## "logreg"   "norm"   "norm" "logreg"  "norm"  "norm"   "norm"
##   NegAff
##   "norm"
## PredictorMatrix:
##         Female Age SES_1 EDU STRESS SUPPORT PosAff NegAff
## Female       0   1     1   1      1       1      1      1
## Age          1   0     1   1      1       1      1      1
## SES_1        1   1     0   1      1       1      1      1
## EDU          1   1     1   0      1       1      1      1
## STRESS       1   1     1   1      0       1      1      1

## SUPPORT      1   1     1   1      1       0      1      1

使用随机森林的多重插补

使用随机森林输入数据的工作原理与使用更简单的回归方法基本相同。同样，基本函数调用是对mice()的调用。主要区别在于指定了不同的方法“rf”。由于 RFs 可以处理连续变量和分类变量，我们不需要为不同类型的变量指定不同的方法。最后，对于 RFs，我们可以设置一些额外的选项。首先是每片森林中应该有多少棵树。在本例中，我们将其设置为 100。一些估算表明可能需要更少的树，但这将取决于问题，在某些情况下，为了获得良好的预测模型，可能需要 100 多棵树。我们还指定了 RF 的节点大小，在本例中为 10。迭代次数设置为 20，以匹配回归插补的总迭代次数。实际上，并不总是清楚应该使用多少次迭代。模型收敛需要足够的迭代。

首先要注意的是，回归方法只需要几秒钟，而 RF 插补则需要很长时间，甚至是并行运行。该模型似乎已经收敛。最后，在检查诊断时，使用 RF 插补，分布与观察数据更加匹配，并且影响值不会被插补到可能性范围之外(低于 1)。

system.time(mi.rfpar <- parLapplyLB(cl, 1:6, function(i) 

{
  mice(
    davgmiss,
    m = 1, maxit = 30,
    method = "rf",
    seed = imputation_seeds[i],
    ntree = 500, nodesize = 10)
}))

##    user  system elapsed
##    0.16    0.11  850.27

## combine into a single object
mi.rf <- ibind(mi.rfpar[[1]], mi.rfpar[[2]])
for (i in 3:6) {
  mi.rf <- ibind(mi.rf, mi.rfpar[[i]]) 

}

## plot convergence diagnostics
plot(mi.rf, PosAff + NegAff + SUPPORT ~ .it | .ms)

## model diagnostics
densityplot(mi.rf, ~ PosAff + NegAff + SUPPORT + STRESS)

xyplot(mi.rf, NegAff + PosAff ~ STRESS + SUPPORT)

请注意，无论数据是如何多重估算的(GLMs、GAMs、RFs)，一旦它们被估算，我们将以同样的方式对它们进行分析。我们可以比较不同模型的结果来看影响。因为我们生成了缺失，所以在这个例子中，我们不仅可以将插补模型与完整的病例结果进行比较，还可以将它们与“真相”进行比较以下代码运行了一个结果为积极影响的 GLM，模型中包含一些社会人口统计协变量，压力作为焦点预测因子。使用真实数据、仅完整案例、基于链式方程和线性模型的估算数据以及随机森林多重估算来重复该模型。估计值和置信区间绘制在图 9-12 中。在这个虚构的例子中，我们可以看到完全案例方法产生了更大的置信区间和通常不太准确的结果。不同的插补方法具有比“真实”模型更具可比性的置信区间。不幸的是，虽然可以在已知条件下评估不同插补模型的性能，但在实践中，不可能知道真相或确切的缺失数据机制，因此很难判断哪种特定方法最准确。这些结果还表明，根据对发现的解释，许多结果可能被认为是非常相似的。鉴于这种相似性和哪种模型最好的不确定性，考虑与不同方法相关的计算成本是合理的，这可能导致一些人选择比随机森林更简单的插补模型。

img/439480_1_En_9_Fig12_HTML.png

图 9-12

压力和积极情感之间关联的线性回归模型的汇总预测

img/439480_1_En_9_Fig11_HTML.png

图 9-11

观察值和估算值的情感与压力和社会支持散点图

img/439480_1_En_9_Fig10_HTML.png

图 9-10

随机森林模型中观测值和估算值的密度图

img/439480_1_En_9_Fig9_HTML.png

图 9-9

随机森林插补模型的收敛诊断

m.true <- lm(PosAff ~ STRESS + Age + EDU + Female, data = davg)
m.cc <- lm(PosAff ~ STRESS + Age + EDU + Female, data = davgmiss)
m.mireg <- summary(pool(with(mi.1,
  lm(PosAff ~ STRESS + Age + EDU + Female))),
  conf.int = TRUE)
m.mirf <- summary(pool(with(mi.rf,
  lm(PosAff ~ STRESS + Age + EDU + Female))),
  conf.int = TRUE)

res.true <- as.data.table(cbind(coef(m.true), confint(m.true)))
res.cc <- as.data.table(cbind(coef(m.cc), confint(m.cc)))
res.mireg <- as.data.table(m.mireg[, c("estimate", "2.5 %", "97.5 %")])
res.mirf <- as.data.table(m.mirf[, c("estimate", "2.5 %", "97.5 %")])
setnames(res.true, c("B", "LL", "UL"))
setnames(res.cc, c("B", "LL", "UL"))
setnames(res.mireg, c("B", "LL", "UL"))
setnames(res.mirf, c("B", "LL", "UL"))

res.compare <- rbind(
  cbind(Type = "Truth", Param = names(coef(m.true)), res.true),
  cbind(Type = "CC", Param = names(coef(m.true)), res.cc),
  cbind(Type = "MI Reg", Param = names(coef(m.true)), res.mireg),
  cbind(Type = "MI RF", Param = names(coef(m.true)), res.mirf))

ggplot(res.compare, aes(factor(""),
   y = B, ymin = LL, ymax = UL, colour = Type)) +
  geom_pointrange(position = position_dodge(.4)) +
  scale_color_viridis(discrete = TRUE) +
  facet_wrap(~Param, scales = "free") +
  theme(
    legend.position = c(1, 0),
    legend.justification = c("right", "bottom"))

## clean up cluster
stopCluster(cl)
rm(cl)

9.3 案例研究:RFs 的多重插补

为了结束这一章，我们将检查一个使用随机森林多重插补的完整工作示例。随机森林多重插补往往非常耗时，因此在几乎所有情况下，您都应该考虑使用并行处理。下面的代码设置了一个本地集群，并加载了所有必需的包。正如我们在介绍中提到的，我们使用checkpoint包来确保我们可以通过指定R的版本和日期来精确地控制和指定使用哪个版本的R包。这有助于使结果具有可重复性，并确保如果您在以后回到您的代码，您确切地知道您使用了什么软件来运行它。

cl <- makeCluster(2)
clusterExport(cl, c("book_directory", "checkpoint_directory" ))

clusterEvalQ(cl, {
  library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)
  library(mice)
  library(randomForest)
  library(data.table)
})

## [[1]]
##  [1] "data.table"    "randomForest"  "mice"          "lattice"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"
##
## [[2]]
##  [1] "data.table"    "randomForest"  "mice"          "lattice"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"

因为多重插补包含随机成分，所以如果您想在重新运行多重插补模型时获得相同的结果，也需要设置随机种子。获得许多随机种子的一个简单方法是使用R中内置的.Random.seed变量。因为这可能会随着时间的推移而改变，而不是直接依赖于结果，所以使用dput()函数将它们导出为可复制可粘贴的R代码。在下面的代码中，我们展示了一个简单的例子，然后展示了重用种子，以便我们可以确定使用哪些种子。为了在并行处理中使用，我们必须使用clusterExport()将结果导出到本地集群。

## example of how to have R return some seed values
dput(.Random.seed[1:5])

## c(403L, 148L, -1767993668L, 1417792552L, 298386660L)

## random seeds
imputation_seeds <- c(403L, 148L, -1767993668L,
  1417792552L, 298386660L, 1360311820L,
1356573822L, -1472988872L, 1215046494L, 759520201L,
1399305648L, -455288776L, 969619279L, 518793662L,
-383967014L, -1983801345L, -698559309L, 1957301883L,
-1457959076L, 1321574932L, -537238757L,
11573466L, 1466816383L, -2113923363L, 1663041018L)

clusterExport(cl, c("davgmiss", "imputation_seeds"))

实际运行随机森林多重插补的代码相当简单。随机森林模型中的预测因子几乎不需要设置，因为模型容易适应分类和连续预测因子，并且不强加关于关联函数形式的假设。因此，对转换数据的关注不是特别相关。尽管异常值可能会有一些影响，因为随机森林依赖于数据的分割，但异常值或预测值中的极值也往往影响较小。连续结果的异常值可能会带来一些挑战，因此检查这些异常值是一个好主意。以下代码和图 9-13 显示了数据快速诊断的示例。图表显示数据可能足够好，可以继续进行。

img/439480_1_En_9_Fig13_HTML.png

图 9-13

插补模型中包含的连续变量的密度图

ggplot(melt(davgmiss[, sapply(davgmiss, is.numeric),
              with = FALSE], measure.vars = 1:6), aes(value)) +
         geom_density() + geom_rug() +
         facet_wrap(~variable, scales = "free")

## Warning: Removed 168 rows containing non-finite values (stat_density) 

.

首先，运行相对简单的模型并生成少量多重估算数据集通常是个好主意。总之，这意味着获得初步结果所需的时间更少，这将有助于识别设置中的任何错误，确保插补模型的结果看起来合理，并可以形成一个基础来估计完成全部插补需要多长时间。下面的代码就是这样一个简单的例子。因为我们设置了一个只有两个处理器的本地集群，所以我们创建了四个估算数据集，所以每个处理器只需要生成两个数据集。我们还将迭代次数限制为五次，这大大提高了速度。我们在开始和结束时都使用了proc.time()函数，这样我们就可以获得总共运行了多长时间的日志。

start.time <- proc.time()

mi.rfpar1 <- parLapplyLB(cl, 1:4, function(i) {
  mice(
    davgmiss,
    m = 1, maxit = 5,
    method = "rf",
    seed = imputation_seeds[i],
    ntree = 100, nodesize = 10)
})
stop.time <- proc.time()

## estimate of how long it took
stop.time - start.time

##    user  system elapsed
##       0       0      15

## combine into a single object
mi.rf1 <- ibind(mi.rfpar1[[1]], mi.rfpar1[[2]])
for (i in 3:4) {
  mi.rf1 <- ibind(mi.rf1, mi.rfpar1[[i]])
}

我们可以看到大约过了 15.5 秒。随着每个核心插补的增加，以及迭代次数的增加，这一数字将大致呈线性增加。我们还应该检查来自这个简单模型的诊断，看看是否有任何异常或可能暗示模型中的问题。我们首先来看看图 9-14 中的一些收敛诊断。

img/439480_1_En_9_Fig14_HTML.png

图 9-14

随机森林插补模型的收敛诊断

## plot convergence diagnostics

plot(mi.rf1, NegAff + STRESS + Age ˜ .it | .ms)

接下来，我们将插补与图 9-15 中观察到的分布进行比较。

img/439480_1_En_9_Fig15_HTML.png

图 9-15

随机森林模型中观测值和估算值的密度图

## model diagnostics for continuous study variables
densityplot(mi.rf1, ˜ NegAff + STRESS + Age)

现在我们可以拟合我们的目标模型，一个线性回归，从每个估算数据集中提取残差，并检查这些假设、异常值等。因为有多个回归模型(每个估算数据集一个)，我们使用lapply()循环遍历这些模型，组合成标准化残差的单个向量，并绘制。结果如图 9-16 所示。虽然分布有些偏斜，并且有一些相对极端的值，但它们并不太可怕，残差分布也没有严重偏斜。

img/439480_1_En_9_Fig16_HTML.png

图 9-16

模型残差的分布图(密度和 Q-Q 偏差)

## fit the models
fit.mirf1 <- with(mi.rf1,
  lm(NegAff ~ STRESS + Age + EDU + Female + SES_1))

testdistr(unlist(lapply(fit.mirf1$analyses, rstandard)))

最后，我们可以汇总和总结结果，然后在表 9-3 中查看它们。这有助于早期识别数据、编码或最终分析模型中的任何明显问题。如果有问题，可以通过这种方式更快地解决，而不是运行整个插补模型，这可能很耗时，而且只有到那时才意识到有问题。有趣的是，我们的经验是，通常在最初几次会发现一些数据问题，直到后来才发现，因为插补依赖于正确的数据，所以数据中的任何问题都需要重新运行插补模型和所有后续分析。

表 9-3

多次估算数据测试运行中汇集的回归结果

|   |

估计

|

Std。错误

|

统计的

|

df

|

p 值

|

2.5%

|

97.5%

|
| --- | --- | --- | --- | --- | --- | --- | --- |
| (截取) | One point zero five | Zero point three two | Three point three | Seventy-five point five eight | Zero | Zero point four two | One point six nine |
| 强调 | Zero point one nine | Zero point zero two | Ten point four one | One hundred and eighteen point nine seven | Zero | Zero point one five | Zero point two two |
| 年龄 | Zero point zero one | Zero point zero one | Zero point six | One hundred and three point eight eight | Zero point five five | −0.02 | Zero point zero three |
| 我的优势是毕业+ | Zero point zero two | Zero point zero seven | Zero point three four | Twenty-five point three one | Zero point seven three | −0.12 | Zero point one six |
| 女性女性 | −0.01 | Zero point zero six | −0.19 | Twenty-four point eight six | Zero point eight five | −0.14 | Zero point one one |
| SES_1 | −0.02 | Zero point zero two | −0.97 | Sixty point three nine | Zero point three three | −0.06 | Zero point zero two |

## pool results and summarize
m.mirf1 <- summary(pool(fit.mirf1), conf.int = TRUE)

xtable(m.mirf1,
  digits = 2,
  caption = "Regression results pooled across multiply imputed data test run",
  label = "tmd-pooledres2")

一旦我们合理地认为插补模型有效，没有需要解决的数据问题，并且我们的最终分析模型可能有效，那么我们就进入最终插补。在本例中，我们将最大迭代次数从 5 次增加到 30 次，以帮助确保收敛。我们还将估算数据集的数量从 4 个增加到 10 个。在实践中，更常见的是使用 25-100 个估算数据集，但我们保持它的简洁性，以使示例不会运行太长时间。

之前，我们看到每个内核进行 2 次插补需要 5 次迭代，耗时 15.5 秒。当使用 30 次而不是 5 次最大迭代时，我们预计需要大约 6 倍的时间，如果我们进行 10 次插补(每个内核 5 次)，插补次数大约需要 2.5 倍的时间。总之，我们估计完成这个更长的插补大约需要 232.5 秒。如果我们计划 50 个估算数据集，它将会是现在的 5 倍。

start.time2 <- proc.time()
mi.rfpar2 <- parLapplyLB(cl, 1:10, function(i) {
  mice(
    davgmiss,
    m = 1, maxit = 30,
    method = "rf",
    seed = imputation_seeds[i],
    ntree = 100, nodesize = 10)
})
stop.time2 <- proc.time()

## time taken
stop.time2 - start.time2

##    user  system elapsed
##    0.04    0.02  274.58

## combine into a single object
mi.rf2 <- ibind(mi.rfpar2[[1]], mi.rfpar2[[2]])
for (i in 3:10) {
  mi.rf2 <- ibind(mi.rf2, mi.rfpar2[[i]])
}

我们可以看到，与我们预测的 232.5 秒相比，大约过去了 274.6 秒。与更简单的模型一样，我们应该检查诊断。这些如图 9-17 所示。

img/439480_1_En_9_Fig17_HTML.png

图 9-17

随机森林插补模型的收敛诊断

## plot convergence diagnostics
plot(mi.rf2, NegAff + STRESS + Age ˜ .it | .ms)

接下来，我们将插补与图 9-18 中观察到的分布进行比较。

img/439480_1_En_9_Fig18_HTML.png

图 9-18

随机森林模型中观测值和估算值的密度图

## model diagnostics for continuous study variables
densityplot(mi.rf2, ˜ NegAff + STRESS + Age)

现在我们拟合我们的目标模型，线性回归，并检查图 9-19 中的标准化残差。

img/439480_1_En_9_Fig19_HTML.png

图 9-19

模型残差的分布图(密度和 Q-Q 偏差)

## fit the models
fit.mirf2 <- with(mi.rf2,
  lm(NegAff ~ STRESS + Age + EDU + Female + SES_1))

testdistr(unlist(lapply(fit.mirf2$analyses, rstandard)))

最后，我们可以汇总和总结结果，然后在表 9-4 中查看它们。

## pool results and summarize
m.mirf2 <- summary(pool(fit.mirf2), conf.int = TRUE)

xtable(m.mirf2,
  digits = 2,
  caption = "Regression results pooled across multiply imputed data final run",
  label = "tmd-pooledres3")

如果你将表 9-3 与表 9-4 进行比较，你会发现有一些不同。如果我们进行更多的估算，可能会有更多的差异。选择 50 至 100 个插补的一个原因是，数字越大，一组随机插补与另一组插补之间的差异往往越小。由于只有 5 到 10 次插补，随机概率可能会导致相对较大的变化。

表 9-4

多次估算数据最终运行的回归结果汇总

|   |

估计

|

Std。错误

|

统计的

|

df

|

p 值

|

2.5%

|

97.5%

|
| --- | --- | --- | --- | --- | --- | --- | --- |
| (截取) | One point one one | Zero point three three | Three point three nine | Ninety-five point five two | Zero | Zero point four six | One point seven six |
| 强调 | Zero point one eight | Zero point zero two | Eight point nine four | Sixty-nine point seven four | Zero | Zero point one four | Zero point two two |
| 年龄 | Zero point zero one | Zero point zero two | Zero point four six | Forty-four point zero three | Zero point six five | −0.02 | Zero point zero four |
| 我的优势是毕业+ | Zero point zero three | Zero point zero eight | Zero point four four | Thirty-one point one | Zero point six six | −0.12 | Zero point one nine |
| 女性女性 | −0.01 | Zero point zero seven | −0.12 | Twenty-seven point eight six | Zero point nine one | −0.15 | Zero point one four |
| SES_1 | −0.02 | Zero point zero two | −1.03 | Sixty-two point six five | Zero point three one | −0.07 | Zero point zero two |

9.4 总结

本章介绍了通过链式方程(MICE)的多重插补，这是一种解决缺失数据的灵活技术。与更容易但往往不是最佳的完整病例分析相比，MICE 可以通过使用所有可用数据来提高效率。如果与缺失相关的必要变量可以包括在 MICE 模型中，MICE 还可以减少由于缺失数据而导致的估计偏差。在许多分析中，解决缺失数据通常是关键的第一步。此外，尽管我们在本章中仅展示了一些后续分析，但 MICE 可以用作几乎任何后续分析的第一步，包括本书其他章节中讨论的所有分析。最后，表 9-5 显示了本章中用于解决缺失数据的一些关键函数的简要总结。

表 9-5

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| aggr() | 通过变量可视化数据集中的缺失数据，并检查缺失数据的不同模式 |
| marginplot() | 可视化一个变量的缺失是否依赖于另一个变量 |
| mice() | 使用完全条件规格方法运行多重插补 |
| mice.mids() | 对先前运行的mice中的mids类对象运行额外的迭代，以检查收敛性 |
| densityplot() | 一个mids类对象绘制观察和估算数据密度的方法；有助于了解估算数据的分布是否与观测数据相似或不同 |
| xyplot() | 一个mids类对象创建两个变量散点图的方法，分别显示观察值和估算值 |
| with() | 一个mids类对象对每个估算数据集分别运行指定分析的方法 |
| pool() | 汇集对不同估算数据集分别运行的分析结果 |
| ibind() | 用所有多重插补将单独的mids对象合并成一个对象 |
| complete() | 从一个mids类对象中提取完整的数据集 |

十、GLMMs：简介

广义线性混合模型(glmm)扩展了前面章节中介绍的广义线性模型(GLMs ),以统计方式说明聚集的数据(例如，学校中的儿童、特定医院诊所中的个人、对同一个人的重复测量)并使这些非独立观察值有条件地独立。

考虑观察值之间的关系是至关重要的，无论是由于阶层(如班级、学校、工作场所)内的聚类，还是由于家庭内的相似性或重复测量，因为许多统计模型假设观察值是独立的，或者至少是有条件独立的。在许多情况下，这可能是一个站得住脚的假设，特别是当观察的基本单位(例如，个人等。)每个人都对我们的数据贡献了一个观察值。本章介绍了观测值可能不独立的情况。当处理观察值可能不独立的数据时，不仅需要调整最终模型和统计推断，还必须调整数据可视化、探索和描述性统计。因此，本章涵盖了处理非独立数据的各个方面，后续章节涵盖了此类数据的统计建模。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(viridis)
library(JWileymisc)
library(data.table)
library(lme4)
library(lmerTest)
library(chron)
library(zoo)
library(pander)
library(texreg)

options(width = 70, digits = 2)

10.1 多级数据

观察值不独立的两种常见情况是对每个个体进行重复测量，如纵向研究或重复测量实验，以及对个体进行聚类或分组，如家庭、学校、公司等。，然后将个体参与者聚集或嵌套在这些高阶单元中。例如，如果家族被招募，来自同一家族的兄弟姐妹的观察结果可能比来自其他家族的兄弟姐妹的观察结果更相似，这是由于共有的遗传因素和共有的环境影响。类似地，如果对个人进行一段时间的跟踪，并在一周内每天进行评估，来自同一个人的观察结果自然更有可能彼此相关，而不是与其他人的观察结果相关。

在这一章中，我们将关注一个重复测量数据的例子。尽管重复测量数据可能与家庭内兄弟姐妹或公司内多名员工的数据有很大不同，但它们带来了许多相同的挑战，并有共同的解决方案。主要区别在于，重复测量数据自然地按时间排序，而聚类数据通常是无序的(例如，如果从 100 家公司中抽取 10 名员工，通常没有自然的方法对员工进行排序或排序)。

多级数据的第一个区别是有两种常见的数据组织方式。一种方法，有时称为宽数据集，类似于单级数据。每一行代表一个观察单位(例如，一个人，一所学校)，并添加额外的变量(列)用于单位内的重复测量。例如，假设高血压患者在研究开始时(??)、6 个月后(??)和 1 年随访时(??)纵向测量血压。表 10-1 给出了这些数据的一个示例。在这个例子中，ID 3 错过了最后的时间点。

表 10-1

在三个时间点测量的收缩压(SBP)的示例宽数据集

|

身份

|

SBPT1 型

|

SBPT2 型

|

SBPT3 型

|
| --- | --- | --- | --- |
| 1 | One hundred and thirty-five | One hundred and thirty | One hundred and twenty-five |
| 2 | One hundred and twenty | One hundred and twenty-five | One hundred and twenty-one |
| 3 | One hundred and twenty-one | One hundred and twenty-five | 。 |

虽然宽数据在某些情况下很方便，但它通常不是多级数据的理想结构。首先，对于纵向数据，比如表 10-1 中的例子，部分信息实际上编码在变量名中:??，??，??。一般来说，变量名最好只描述变量或测量值，而附加信息(如时间)要被捕获并编码到另一个变量(如时间点)中。第二，如果在一个单元内有不同数量的评估，如不同长度的纵向随访或学校内不同数量的学生，宽格式变得非常低效。例如，想象一个数据集，其中从一所大型学校招聘了 600 名学生，而从一所较小的学校招聘了 15 名学生。要将这些数据以宽格式放置，每个测量需要 600 个变量(最大学校的每个学生一个变量)。在这个小学校里，这 600 个变量中除了 15 个之外，其他都将丢失。

构建多级数据集的另一种方法有时称为长格式。在长格式中，多行可能属于任何一个单元，这由一个标识(ID)变量来表示。表 10-2 显示了一个使用相同的血压假设纵向研究的长数据示例。在这种情况下，如果一个特定的单元错过了一个观测值或者比其他单元的观测值少(例如，一所小学校对一所大学校)，则可以省略这些行。例如，在表 10-2 中，ID 3 没有时间 3 血压读数，因此该行完全不在数据中。

表 10-2

示例在三个时间点测量的收缩压(SBP)的长数据集

|

身份

|

自发性腹膜炎

|

时间

|
| --- | --- | --- |
| 1 | One hundred and thirty-five | one |
| 1 | One hundred and thirty | Two |
| 1 | One hundred and twenty-five | three |
| 2 | One hundred and twenty | one |
| 2 | One hundred and twenty-five | Two |
| 2 | One hundred and twenty-one | three |
| 3 | One hundred and twenty-one | one |
| 3 | One hundred and twenty-five | Two |

重塑数据

如果数据是以一种格式存储的，就有可能，有时也有必要将其转换成另一种格式。下面的代码创建一个宽数据集，然后使用reshape()函数将其从宽格式转换为长格式。varying参数表示随时间变化的宽数据中的变量。v.names参数表示长数据集中每组可变变量的名称。在这个例子中，我们只有 SBP，但如果有更多的变量，这些可以添加。方向参数指示数据是应该由宽到长，还是由长到宽。

ex.wide <- data.table(
  ID = c(1, 2, 3),
  SBPT1 = c(135, 120, 121),
  SBPT2 = c(130, 125, 125),
  SBPT3 = c(125, 121, NA))

print(ex.wide)

##    ID SBPT1 SBPT2 SBPT3
## 1:  1   135   130   125
## 2:  2   120   125   121
## 3:  3   121   125    NA

reshape(
  data = ex.wide,
  varying = list(paste0("SBPT", 1:3)),
  v.names = c("SBP"),
  idvar = "ID",
  direction = "long")

##    ID time SBP
## 1:  1    1 135
## 2:  2    1 120
## 3:  3    1 121
## 4:  1    2 130
## 5:  2    2 125
## 6:  3    2 125
## 7:  1    3 125
## 8:  2    3 121
## 9:  3    3  NA

相反，如果数据已经是长格式，就可以将它们转换成宽格式。下面的代码创建了一个长数据，并再次使用reshape()函数将其转换为宽数据。sep参数指示如何使用宽变量名。在这种情况下，基数是 SBP，然后是分隔符 T，后面是时间:1、2、3。

ex.long <- data.table(
  ID = c(1, 1, 1, 2, 2, 2, 3, 3),
  SBP = c(135, 130, 125, 120, 125, 121, 121, 125),
  Time = c(1, 2, 3, 1, 2, 3, 1, 2))

print(ex.long)

##    ID SBP Time
## 1:  1 135    1
## 2:  1 130    2
## 3:  1 125    3
## 4:  2 120    1
## 5:  2 125    2
## 6:  2 121    3
## 7:  3 121    1
## 8:  3 125    2

reshape(
  data = ex.long,
  v.names = "SBP",
  timevar = "Time",
  sep = "T",
  idvar = "ID",
  direction = "wide")

##    ID SBPT1 SBPT2 SBPT3
## 1:  1   135   130   125
## 2:  2   120   125   121
## 3:  3   121   125    NA

每日数据集

在开始之前，我们将介绍一个新的数据集。这些数据来自 2017 年在莫纳什大学进行的每日日记研究，年轻成年人在大约 12 天的时间里每天完成多达三次(早上、下午和晚上)的测量。因此，每个参与者对数据集贡献了大约 36 次观察。为了保护参与者的保密性和匿名性，这里使用的数据是从原始数据模拟的，但是以这样的方式保留了变量之间的关系和原始数据的大部分特征。

表 10-3 中列出了变量名和每个变量名的简要描述。

模拟数据作为JWileymisc包的一部分，可以使用data()功能加载。

表 10-3

每日日记研究数据中的变量名称列表

|

变量名

|

描述

|
| --- | --- |
| UserID | 每个人的唯一标识符 |
| SurveyDay | 每次观察发生的日期 |
| SurveyInteger | 调查编码为整数(1 =上午，2 =下午，3 =晚上) |
| SurveyStartTimec11 | 调查开始时间，从上午 11:00 开始以小时为中心 |
| Female | 0 或 1 变量，其中 1 =女性，0 =男性 |
| Age | 参与者的年龄，最高编码为 25 岁 |
| BornAUS | 一个 0 或 1 变量，其中 1 =出生在澳大利亚，0 =出生在澳大利亚以外 |
| SES_1 | 参与者的主观 SES，底部编码为 4，顶部编码为 8 |
| EDU | 教育水平，其中 1 =大学毕业或以上，0 =大学毕业以下 |
| SOLs | 自我报告的睡眠开始潜伏期(分钟),仅限早晨调查 |
| WASONs | 自我报告的睡眠开始后醒来的次数，最高编码为 4，仅早晨调查 |
| STRESS | 总体压力等级为 0-10，每天重复 3 次 |
| SUPPORT | 总体社会支持评分为 0-10 分，每天重复 3 次 |
| PosAff | 正面影响评分为 1-5 分，每天重复 3 次 |
| NegAff | 负面影响评分为 1-5 分，每天重复 3 次 |
| COPEPrb | 问题集中在 1-4 级的应对上，在晚上的调查中每天重复 1 次 |
| COPEPrc | 情绪处理应对等级为 1-4，在晚间调查中每天重复 1 次 |
| COPEExp | 情绪表达应对等级为 1-4，在晚间调查中每天重复 1 次 |
| COPEDis | 精神解脱应对在 1-4 的范围内，在晚上的调查中每天重复 1 次 |

data(aces_daily)
str(aces_daily)

## 'data.frame':        6599 obs. of  19 variables:
##  $ UserID            : int  1 1 1 1 1 1 1 1 1 1 ...
##  $ SurveyDay         : Date, format: "2017-02-24" ...
##  $ SurveyInteger     : int  2 3 1 2 3 1 2 3 1 2 ...
##  $ SurveyStartTimec11: num  1.93e-01 4.86e-01 1.16e-05 1.93e-01 4.06e-01 ...
##  $ Female            : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Age               : num  21 21 21 21 21 21 21 21 21 21 ...
##  $ BornAUS           : int  0 0 0 0 0 0 0 0 0 0 ... 

##  $ SES_1             : num  5 5 5 5 5 5 5 5 5 5 ...
##  $ EDU               : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ SOLs              : num  NA 0 NA NA 6.92 ...
##  $ WASONs            : num  NA 0 NA NA 0 NA NA 1 NA NA ...
##  $ STRESS            : num  5 1 1 2 0 0 3 1 0 3 ...
##  $ SUPPORT           : num  NA 7.02 NA NA 6.15 ...
##  $ PosAff            : num  1.52 1.51 1.56 1.56 1.13 ...
##  $ NegAff            : num  1.67 1 NA 1.36 1 ...
##  $ COPEPrb           : num  NA 2.26 NA NA NA ...
##  $ COPEPrc           : num  NA 2.38 NA NA NA ...
##  $ COPEExp           : num  NA 2.41 NA NA 2.03 ...
##  $ COPEDis           : num  NA 2.18 NA NA NA ...

数据是长格式的，因此每一行代表一个人在某一天的一次调查中的观察结果。在长格式中，每个人贡献大约 36 行数据。虽然长格式是存储具有许多重复测量值的数据的有效方式，但它会使识别缺失数据变得困难，因为缺失的调查不会被注册为一行缺失数据，而是整行缺失。第一步有助于确定缺失数据的比率，并且对未来的几项分析非常有用，这就是添加任何缺失的调查，只需将观测值设置为缺失即可。为此，我们可以创建一个临时数据集，其中包含从个人的第一次调查/日期到最后一次调查/日期的所有调查和日期，然后对原始数据执行完全连接(或合并，保留所有行)。

下面的代码通过查找最小和最大日期以及这些日期中每一天的最早和最晚调查来创建这样一个临时数据集。然后，使用这些信息，我们可以创建一个“完整”的数据集，包含第一天的第一次调查和最后一天的最后一次调查之间的所有调查和所有天数。最后，我们可以将两个数据集合并在一起，保留所有将根据需要填充缺失值的行。

draw <- as.data.table(aces_daily)
draw <- draw[order(UserID, SurveyDay, SurveyInteger)]
draw[, UserID := factor(UserID)]

tmpdata <- draw[!is.na(SurveyDay) & !is.na(SurveyInteger)][, .(
  MinD = min(SurveyDay),
  MinS = min(SurveyInteger[SurveyDay == min(SurveyDay)]),
  MaxD = max(SurveyDay),
  MaxS = max(SurveyInteger[SurveyDay == max(SurveyDay)])),
  by = UserID]

tmpdata <- tmpdata[, .( 

  SurveyInteger = c(
    MinS:3L, #first day
    rep(1L:3L, times = MaxD - MinD - 1), #all days between first/last
    1L:MaxS), #last day
  SurveyDay = as.Date(rep(MinD:MaxD, c(
      4L - MinS, #first day
      rep(3, MaxD - MinD - 1), #all days between first/last
      MaxS)), origin = "1970-01-01")), #lastday
  by = UserID]

d <- merge(draw, tmpdata, by = c("UserID", "SurveyDay", "SurveyInteger"),
           all = TRUE)

nrow(draw)

## [1] 6599

nrow(d)

## [1] 6927

nrow(draw)/nrow(d)

## [1] 0.95

在添加丢失的行后，数据中的行数从原始数据开始增加，反映了丢失的数据。

10.2 描述性统计

对于非独立数据，基本描述性统计也可以用不同的方法计算。为了开始理解这些差异，以及多级结构意味着什么，检查图 10-1 中的两个图。该图显示了在不同条件下对四个不同的人进行十次评估的虚构数据。实线表示每个人的平均值，圆点表示观察到的数据。

对于长格式的多级数据，如果我们计算一个变量y的平均值和方差，这将是所有人和所有时间的平均值。方差将包括人与人之间的差异(线与线之间的距离)和人与人之间的方差(数据点围绕每个人的平均值变化的程度)。相反，如果我们首先对一个人在不同时间的观察进行平均，那么平均值将是四条线的平均值，方差将只是个体平均值之间的可变性，如图 10-1 中的线。

此外，计算所有数据点的描述符与计算人平均数据的描述符会导致参与者的权重不同。当计算所有观察的汇总时，有十个观察的参与者将得到只有一个观察的参与者的十倍权重(例如，由于缺失数据)。加权的问题往往不太重要，因为所有聚类的大小都差不多，并且如果所有聚类都相同(例如，每个人正好有 10 个观察值)，那么加权也没有什么区别。

set.seed(1234)
ex.data.1 <- data.table(
  ID = factor(rep(1:4, each = 10)),
  time = rep(1:10, times = 4),
  y = rnorm(40, rep(1:4, each = 10), .2))

ex.data.2 <- data.table(
  ID = factor(rep(1:4, each = 10)),
  time = rep(1:10, times = 4),
  y = rnorm(40, 2.5, 1))

plot_grid(
 ggplot(ex.data.1,
        aes(time, y, colour = ID, shape = ID)) +
  stat_smooth(method = "lm", formula = y ~ 1, se=FALSE) +
  geom_point() +
  scale_color_viridis(discrete = TRUE),
 ggplot(ex.data.2,
        aes(time, y, colour = ID, shape = ID)) +
  stat_smooth(method = "lm", formula = y ~ 1, se=FALSE) +
  geom_point() +
  scale_color_viridis(discrete = TRUE),
 ncol = 1,
 labels = c(
   "High Between Variance",
   "Low Between Variance"),
 align = "hv")

对于多级数据，计算描述性统计数据没有简单的正确或错误的方法，但理解差异并准确描述所使用的方法是很重要的。一般来说，三种常见的方法如下:

  • 忽略结构并计算所有观察值的描述符。如果它们具有不同数量的观察值，这可能会对单元进行不同的加权。它还将提供一个方差估计值，该值结合了人与人之间以及人与人之间的差异。也就是说，可变性是变量的总可变性。

  • 首先平均(或合并)一个单元内的观察值，然后计算描述符。这使得每个单元重量相等。方差估计只会捕获变量在人与人之间的方差，因此它可能更有助于描述样本特征，而不是变量的总可变性。

  • 仅计算第一个时间点的描述性统计数据。这将仍然倾向于包括一些个人之间和个人内部的可变性，因为个人内部的可变性没有被平均。如果随着时间的推移出现有意义的变化，平均值可能不代表研究的整体平均值。这种方法只对纵向数据有意义。对于其他多级结构(例如，嵌套在教室中的学生)，没有合理的方法来选择使用哪个学生。

基本描述

计算描述性统计数据的每种方法的例子在我们前面为正面影响加载的每日数据示例中显示。使用data.table()直接在数据集中动态地执行必要的数据管理，而不是创建新的变量或新的数据集。为了通过 ID 获得第一个观察，我们按照 ID、星期几和调查(上午、下午、晚上)进行排序，然后通过 ID 选择第一个观察。

img/439480_1_En_10_Fig1_HTML.png

图 10-1

显示高方差和低方差假设数据的图。在高方差中，一个人的观察值变化很小，但个体差异很大。在低间方差中，个体差异不多，但每个人内部的变异性很大。

## mean and SD on all observations
egltable("PosAff", data = d)

##                M (SD)
## 1: PosAff 2.68 (1.07)

## mean and SD first averaging within ID
egltable("PosAff",
  data = d[, .(
    PosAff = mean(PosAff, na.rm = TRUE)) 

,
    by = UserID])

##                M (SD)
## 1: PosAff 2.68 (0.80)

## mean and SD on first observations
egltable("PosAff", data = d[
  order(UserID, SurveyDay, SurveyInteger)][,
    .(PosAff = PosAff[1]), by = UserID])

##                M (SD)
## 1: PosAff 2.71 (1.02)

对于长数据集，为了计算时不变变量的汇总度量，而不是在参与者中求平均值，我们必须首先对数据进行子集化以删除重复的行，以便它回到单级结构。这可以通过要求数据删除任何重复的 id 来实现。

tab <- egltable(c("Female", "Age", "BornAUS", "SES_1", "EDU"),
                data = d[!duplicated(UserID)],
                strict = FALSE)
tab

##             M (SD)/N (%)
##  1:  Female
##  2:       0    28 (40.6)
##  3:       1    41 (59.4)
##  4:     Age 21.91 (2.38)
##  5: BornAUS
##  6:       0    41 (60.3)
##  7:       1    27 (39.7)
##  8:   SES_1  6.05 (1.21)
##  9:     EDU
## 10:       0    45 (66.2)
## 11:       1    23 (33.8)

绘图是一种显示描述性统计数据的有用方式，例如按不同的组。图 10-2 显示了女性和男性的平均应对能力。平均值标绘为点，并添加了标度中的锚点，以便于解释。

img/439480_1_En_10_Fig2_HTML.png

图 10-2

显示男女平均应对评级的图表

## create a dataset of the means and labels by gender
copeplotdata <- d[!is.na(Female), .(
  M = c(
    mean(COPEPrb, na.rm = TRUE),
    mean(COPEPrc, na.rm = TRUE),
    mean(COPEExp, na.rm = TRUE),
    mean(COPEDis, na.rm = TRUE)),
  Var = 1:4,
  Low = sprintf("I usually don’t do this at all\n[%s]",
                c("Problem Focused", "Emotional Processing",
                  "Emotional Expression", "Disengagement")),
  High = sprintf("I usually do this a lot\n[%s]",
                 c("Problem Focused", "Emotional Processing",
                   "Emotional Expression", "Disengagement"))),
  by = Female]

## coded 0/1 but for plotting, R needs to know
## it is discrete not a continuous number
copeplotdata[, Female := factor(Female)]

## create a plot

gglikert(x = "M", y = "Var", leftLab = "Low", rightLab = "High",
         data = copeplotdata, colour = "Female",
  xlim = c(1, 4), title = "Average Coping") +
  scale_colour_manual(values =
    c("1" = "grey70", "0" = "grey30"))

描述性统计也可以被其他变量分解。例如，以下代码根据当时报告的压力水平计算并绘制了图 10-3 中积极和消极影响的平均水平。请注意，由于这是通过调查得出的，因此将在调查而非人员层面进行解释。也就是说，在调查中，人们给自己的压力评分在 5 分以上，他们平均给自己的影响评分是多少？平均来说，它并没有告诉我们压力大或小的人的平均影响。事实上，如果同一个人有时报告的压力高于 5，而有时报告的压力低于 5，那么他可能会将一些调查贡献给高压力的平均值，而将一些调查贡献给低压力的平均值。

## create a dataset of the means and labels by stress
afplotdata <- d[!is.na(STRESS), .(
  M = c(
    mean(PosAff, na.rm = TRUE),
    mean(NegAff, na.rm = TRUE)),
  Var = 1:2,
  Low = sprintf("Very Slightly or\nNot at all\n[%s]",
                c("Positive Affect", "Negative Affect")),
  High = sprintf("Extremely\n\n[%s]",
                c("Positive Affect", "Negative Affect"))),
  by = .(Stress = STRESS > 5)]

## add labels to understand stress
afplotdata[, Stress := factor(Stress, levels = c(FALSE, TRUE),
                              labels = c("<= 5", "> 5"))]

## create a plot
gglikert(x = "M", y = "Var", leftLab = "Low", rightLab = "High",
         data = afplotdata, colour = "Stress",
  xlim = c(1, 5), title = "Affect by Stress") +
  scale_colour_manual(values =
    c("<= 5" = "grey70", "> 5" = "grey30"))

当观察值可以有意义地排序时，比如按一天中的时间排序，我们也可能希望按时间点分别计算描述性统计数据。在下面的代码中，我们为带有更好标签的调查创建了一个新变量，然后对参与者的回答进行平均，但根据调查分别进行，最后计算描述性统计数据。为了得到一个好的分组摘要，我们可以将Survey作为分组变量传递。但是，请注意，在这种情况下，组间差异的统计测试将是不准确的，因为它假设了独立的组。我们忽略测试，专注于仍然准确的描述性统计。这个例子还展示了一次获取多个变量的描述性统计数据。

img/439480_1_En_10_Fig3_HTML.png

图 10-3

显示男女平均应对评级的图表

d[, Survey := factor(SurveyInteger, levels = 1:3,
    labels = c("Morning", "Afternoon", "Evening"))]

egltable(c("PosAff", "NegAff", "STRESS"), g = "Survey",
  data = d[, .(
    PosAff = mean(PosAff, na.rm = TRUE),
    NegAff = mean(NegAff, na.rm = TRUE),
    STRESS = mean(STRESS, na.rm = TRUE)
    ), by = .(UserID, Survey)])

##           Morning M (SD) Afternoon M (SD) Evening M (SD)
## 1: PosAff    2.67 (0.84)      2.69 (0.81)    2.67 (0.81)
## 2: NegAff    1.53 (0.46)      1.57 (0.49)    1.56 (0.49)
## 3: STRESS    2.14 (1.47)      2.52 (1.60)    2.39 (1.56)
##                          Test
## 1: F(2, 570) = 0.05, p = .947
## 2: F(2, 570) = 0.33, p = .720
## 3: F(2, 570) = 3.01, p = .050

附加选项(参与者平均与否，按时间点分别报告等。)的出现是因为对于重复测量或非独立数据，观测值可以分解到不同的层次。具体来说，我们可以想象具体的积极情绪观察是参与者的典型或平均积极情绪加上特定日期或时间的影响的组合。

我们可以通过计算每个参与者的平均值(即，中间部分)，然后取观察值和每个参与者自己的平均值之间的差值(即，内部部分)，将变量分解为“中间”和“内部”两个方面。下面的代码展示了一个有积极影响的例子。在计算了这两个分量之后，我们还可以分别得到每个分量的描述性统计数据。注意，对于每个参与者的平均值，我们应该首先删除重复的值；否则，它将更倾向于具有更多重复测量的参与者，这对于级别间或时间不变性变量是不合适的。

d[, BPosAff := mean(PosAff, na.rm = TRUE), by = UserID]
d[, WPosAff := PosAff - BPosAff]

egltable("BPosAff", data = d[!duplicated(UserID)])

##                 M (SD)
## 1: BPosAff 2.68 (0.80)

egltable("WPosAff", data = d)

##                 M (SD)
## 1: WPosAff 0.00 (0.72)

分解变量通常不仅对描述性统计有用，而且对分析人们希望了解变量在人与人之间以及人与人之间的关系也有用。为了便于这样的工作，我们可以对所有时变变量进行变量间和变量内转换。为了减少我们编写的代码量，我们可以定义一个函数，bwmean(),来计算平均值和与平均值的偏差，然后使用data.table()通过 ID 来应用这个函数。

## define a new function
bwmean <- function(x, na.rm = TRUE) {
  m <- mean(x, na.rm = na.rm)
  list(m, x - m)
}

## apply it to affect, support, and stress, by ID
d[, c("BNegAff", "WNegAff") := bwmean(NegAff), by = UserID]
d[, c("BSUPPORT", "WSUPPORT") := bwmean(SUPPORT), by = UserID]
d[, c("BSTRESS", "WSTRESS") := bwmean(STRESS), by = UserID]

我们还可以为睡眠和应对措施制定一个介于和内部变量。然而，它们的工作方式略有不同。睡眠只在早上测量，应对只在晚上测量，作为当天的整体应对。如果我们通过调查统计非缺失观测值的数量，这一点很容易看出，首先使用is.na()函数根据是否缺失将每个值转换为 0 或 1，然后使用sum()求和，所有这些都通过调查分解。注意is.na()返回 TRUE 或 1 表示缺失，返回 FALSE 或 0 表示不缺失。为了扭转这种情况，我们添加了感叹号，这意味着代码已被读取，并通过调查对非缺失值求和。

d[, .(
  NCope = sum(!is.na(COPEPrb)),
  NSOLs = sum(!is.na(SOLs))),
  by = Survey]

##       Survey NCope NSOLs
## 1: Afternoon     0     0
## 2:   Evening  2090  2097
## 3:   Morning     0     0

尽管睡眠和应对能力只在特定的调查中进行评估，但它们适用于一整天，所以我们可以在其他调查中填写它们。对于参与者之间的变量，很容易做到这一点:我们只需填写所有调查的平均值。填写其他调查时间点更复杂。关键是传递一个值，这个值R将根据需要回收。我们可以通过让data.table()应用 ID 和调查日的操作来实现这一点，然后忽略任何缺失的应对值(每天最多留下一个)，并减去人与人之间的应对变量。因为我们已经填写了，人与人之间的应对变量在每次调查时都会有值，所以内部应对变量也会有值。

d[, BCOPEPrb := mean(COPEPrb, na.rm = TRUE), by = UserID]
d[, WCOPEPrb := na.omit(COPEPrb) - BCOPEPrb,
  by = .(UserID, SurveyDay)]
d[, BCOPEPrc := mean(COPEPrc, na.rm = TRUE), by = UserID]
d[, WCOPEPrc := na.omit(COPEPrc) - BCOPEPrc,
  by = .(UserID, SurveyDay)]
d[, BCOPEExp := mean(COPEExp, na.rm = TRUE), by = UserID]
d[, WCOPEExp := na.omit(COPEExp) - BCOPEExp,
  by = .(UserID, SurveyDay)]
d[, BCOPEDis := mean(COPEDis, na.rm = TRUE), by = UserID]
d[, WCOPEDis := na.omit(COPEDis) - BCOPEDis,
  by = .(UserID, SurveyDay)]

d[, BSOLs := mean(SOLs, na.rm = TRUE), by = UserID]
d[, WSOLs := na.omit(SOLs) - BSOLs,
  by = .(UserID, SurveyDay)]
d[, BWASONs := mean(WASONs, na.rm = TRUE), by = UserID]
d[, WWASONs := na.omit(WASONs) - BWASONs,
  by = .(UserID, SurveyDay)]

组内相关系数

另一种对多水平模型有用的描述性统计称为组内相关系数或 ICC。在多层次的背景下，ICC 基于将可变性分解为两个来源:个体之间的可变性和个体内部的可变性。计算变量的 ICC 的可靠方法是使用最简单类型的多级模型:只有随机截距的模型，即只包含截距但允许截距随 ID 随机变化的模型。随机截距的方差是两者之间的方差，因为它本质上是个体均值的方差，而剩余方差是个体内部的方差，它不能用个体自身的均值来解释。这两个方差来源共同构成总方差。

$$ TotalVariance={\sigma}_{between}²+{\sigma}_{within}²={\sigma}_{randomintercept}²+{\sigma}_{residual}² $$

(10.1)

使用这两个方差来源，我们可以计算个体之间的变异性与总变异性的比率。该比率在 0 和 1 之间变化，并提供关于个体之间发生的总可变性的多少的信息。值为 0 表示所有个体平均值彼此相等，因此所有可变性都发生在个体内部。相反，值为 1 表示在个体中所有值都是相同的，个体之间存在所有可变性。该比率被称为组内相关系数(ICC ),可通过下式计算:

$$ ICC=\frac{\sigma_{between}²}{\sigma_{between}²+{\sigma}_{within}²}=\frac{\sigma_{randomintercept}²}{\sigma_{randomintercept}²+{\sigma}_{residual}²} $$

(10.2)

ICC 可以通过拟合随机截距模型手动计算，或者更方便地使用iccMixed()函数。iccMixed()需要变量名、ID 变量(或者多个 ID 的变量)的名称和数据集。它返回每个级别的估计方差，称为适马，以及每个级别的方差与总方差的比率，即 ICC。虽然 ICC 通常用于两级结构，但该函数可以推广到更高阶的结构，如学生内部的观察和有班级的学生。如果学生和班级 id 可用，则可以计算每个级别的方差，ICC 将是每个级别的方差与总方差的比率。

iccMixed("NegAff", "UserID", d)

##         Var Sigma  ICC
## 1:   UserID  0.21 0.44
## 2: Residual  0.27 0.56

iccMixed("PosAff", "UserID", d)

##         Var Sigma  ICC
## 1:   UserID  0.63 0.54
## 2: Residual  0.53 0.46

除了提供个体之间或个体内部变异程度的指标外，ICC 还用于计算“有效”样本量。“有效”样本量是对数据提供的独立样本数量的近似估计。例如，如果连续 10 天每天收集 10 个人的数据，则总共有 100 个观察值，但是这些数据不太可能提供与 100 个人测量一次(独立样本)相同的有效信息。

为了更好地理解有效样本量，通常称为 NEffective，考虑两个极端。首先，假设在一个个体中，每个观察都是相同的。比如，想象一下测量一个成年人的身高。一旦在第一天测量了身高，另外 9 天的评估不太可能提供任何进一步的有用信息。在这个例子中，ICC 将是 1:所有的可变性发生在个体之间，个体内部没有可变性。也就是说，成年人有许多不同的身高(可变性之间)，但同一成年人每天的身高基本相同(可变性之内没有)。

在另一个极端，一些变量可能每天都在变化，就像人与人之间一样。想象一下评估同一城市不同成年人的通勤时间。忽略不同的路线，就目前而言，变异可能只是因为不同的日子和交通状况而存在。因此，平均而言，他们的所有通勤时间可能是相同的(可变性之间没有差异)，所有可变性都发生在日常基础上(可变性之内)。在后一个例子中，对 10 个人进行 10 天的测量提供了 100 个观察结果和等同于在一天中对 100 个人进行评估的信息。

计算 NEffective 试图提供关于等效独立样本大小的估计。该公式取决于参与者或真正独立单元的数量，N；个人(单位)人均考核次数，k；和 ICC，如下所示:

$$ N\kern0.125em Effective=\frac{N^{\ast}\kern0.125em k}{\left(\left(1+{\left(k-1\right)}^{\ast}\kern0.125em ICC\right)\right)} $$

(10.3)

也可以使用nEffective()功能在R中计算有效样本量。这也有助于凸显国际刑事法院的影响力有多大。ICC 越高，无效性越低。下面的R代码显示了消极和积极影响的 NEffective。尽管观察次数相似，但由于 ICC 的差异，消极和积极影响的效果却大不相同，ICC 由nEffective()函数自动计算。

## number of units
n <- length(unique(d$UserID))

## average observations per unit
k <- nrow(d[!is.na(NegAff)])/n

## effective sample size
nEffective(n, k, dv = "NegAff", id = "UserID", data = d)

##                     Type    N
## 1: Effective Sample Size  420
## 2:     Independent Units  191
## 3:    Total Observations 6389

k <- nrow(d[!is.na(PosAff)])/n
nEffective(n, k, dv = "PosAff", id = "UserID", data = d)

##                     Type    N
## 1: Effective Sample Size  343
## 2:     Independent Units  191
## 3:    Total Observations 6399

10.3 探索和假设

分布和异常值

在本书的开始，我们检查了多种方法来可视化单变量和多变量数据，为分析做准备。对于非独立或重复的测量数据，类似的方法适用，除了它们可以应用于不同的水平或不同的单位(例如，观察值、人与人之间的平均值等)。).为了便于分解和图形化检查，我们可以使用meanDecompose()函数。它使用一个公式界面，左侧是主要变量，右侧是要分解的 id 或其他变量。它的工作方式类似于我们在变量之间和变量内部创建的方式，只是它创建了单独的数据集，因此在变量之间的级别上，没有重复。

tmp <- meanDecompose(PosAff ~ UserID, data = d)
str(tmp, max.level = 1)

## List of 2
##  $ PosAff by UserID  :Classes 'data.table' and 'data.frame': 191 obs. of 2 variables:
##   ..- attr(*, "sorted")= chr "UserID"
##   ..- attr(*, ".internal.selfref")=<externalptr>
##  $ PosAff by residual:Classes 'data.table' and 'data.frame': 6927 obs. of  1 variable:
##   ..- attr(*, ".internal.selfref")=<externalptr>

单独的数据集存储在一个列表中，它们由变量和级别命名。这里的“用户标识”和“剩余”对应于级别之间和级别之内。如前几章所述，我们可以对照正态(或其他)分布检查每个变量。在下面的代码中，我们只关注人与人之间的积极影响值，如图 10-4 所示。

img/439480_1_En_10_Fig4_HTML.png

图 10-4

与正态分布相反的人与人之间的积极影响

testdistr(tmp[[1]]$X, varlab = names(tmp)[1],
          extremevalues = "theoretical", robust=TRUE)

我们可以让R遍历所有级别的数据并绘制它们，而不是为每个级别编写代码。我们不单独绘制它们，而是在最后使用plot_grid()将它们组合起来，如图 10-5 所示。

img/439480_1_En_10_Fig5_HTML.png

图 10-5

与正态分布相反的个人之间和个人内部的积极影响

plots <- lapply(names(tmp), function(x) {
  testdistr(tmp[[x]]$X, plot = FALSE, varlab = x,
            extremevalues = "theoretical", robust=TRUE)[1:2]
})

do.call(plot_grid, c(unlist(plots, FALSE), ncol = 2))

meanDecompose()功能的另一个特点是我们可以添加更多的级别。例如，我们可以查看参与者之间、参与者内部的每日差异，以及参与者和日期的最终残差。图 10-6 显示了一个例子。

img/439480_1_En_10_Fig6_HTML.png

图 10-6

对正态分布的不同程度的负面影响

tmp <- meanDecompose(NegAff ~ UserID + SurveyDay, data = d)
do.call(plot_grid, c(unlist(lapply(names(tmp), function(x) {
  testdistr(tmp[[x]]$X, plot = FALSE, varlab = x,
            extremevalues = "theoretical", robust=TRUE)[1:2]
}), FALSE), ncol = 2))

这些图表(图 10-6 )显示，尽管参与者和日或残差的负面影响是对称的，但人与人之间的负面影响是相当偏斜的。我们可以尝试对数转换。结果如图 10-7 所示。尽管参与者之间负面情绪的偏差有所改善，但它仍然存在。按 ID 和日期划分的级别大致呈正态分布。然而，残差的分布虽然是对称的，但却是稀疏的。这些结果表明，我们应该谨慎假设负面情绪的常态。

img/439480_1_En_10_Fig7_HTML.png

图 10-7

不同水平的自然对数对正态分布的负面影响

d[, logNegAff := log(NegAff)]
tmp <- meanDecompose(logNegAff ~ UserID + SurveyDay, data = d)
do.call(plot_grid, c(unlist(lapply(names(tmp), function(x) {
  testdistr(tmp[[x]]$X, plot = FALSE, varlab = x,
            extremevalues = "theoretical", robust=TRUE)[1:2]
}), FALSE), ncol = 2))

时间趋势

除了探索分布和异常值，纵向重复测量数据还有其他有用的诊断。如果数据中没有预期的时间趋势，或者时间趋势不是研究的重点，那么根据经验证明没有时间趋势是有用的。这一点很重要，因为许多分析都假设过程是稳定的(即过程不会随着时间的推移而发生实质性变化)。

一个简单的开始方式是绘制不同时间的方法。为此，我们将使用参与者内部变量，以忽略仅由不同参与者驱动的任何潜在差异。为了一次绘制许多变量，我们可以将数据按变量融合成一个长数据集。结果如图 10-8 所示。

img/439480_1_En_10_Fig8_HTML.png

图 10-8

gam 平滑下变量随时间变化的趋势

dt <- d[, .(
  WPosAff = mean(WPosAff, na.rm = TRUE),
  WNegAff = mean(WNegAff, na.rm = TRUE),
  WSTRESS = mean(WSTRESS, na.rm = TRUE),
  WSUPPORT = mean(WSUPPORT, na.rm = TRUE),
  WSOLs = mean(WSOLs, na.rm = TRUE),
  WWASONs = mean(WWASONs, na.rm = TRUE)) , by = SurveyDay]
dt <- melt(dt, id.var = "SurveyDay")

ggplot(dt, aes(SurveyDay, value)) +
  geom_point() +
  stat_smooth(method = "gam", formula = y ~ s(x, k = 10)) +
  facet_wrap(~ variable, scales = "free")

除了系统的时间趋势之外，我们还可以看看一周中不同的日子，或者最常见的工作日与周末的差异。我们可以使用weekdays()函数将日期转换成星期几，然后测试这些日期是否与星期六或星期天相匹配，从而得到一个逻辑比较，显示今天是否是周末。结果如图 10-9 所示。

img/439480_1_En_10_Fig9_HTML.png

图 10-9

gam 平滑下变量随时间变化的趋势

dt[, Weekend := weekdays(SurveyDay) %in% c("Saturday", "Sunday")]
ggplot(dt, aes(Weekend, value)) +
  stat_summary(fun.data = mean_cl_boot) +
  facet_wrap(~ variable, scales = "free")

## Warning: Removed 2 rows containing non-finite values (stat_summary).

总的来说，时间趋势和一些工作日与周末的差异都出现了。这些初步结果表明，未来的分析应该调整这种差异，或者我们可以计算新的变量，这些变量是去除任何时间趋势后的残差。

自相关

除了时间趋势之外，观察变量之间的相关程度也很有帮助。这被称为自相关。使用默认自相关工具时，通常假设观测值在时间上间隔相等，并且不会有任何缺失值。现在，作为一种快速而粗略的探索方法，我们将分两步填充缺失的数据。首先，我们将估计任何遗漏的调查开始时间，作为每个人在每个调查时间(上午、下午、晚上)的平均时间。然后我们可以将日期和时间结合起来，得到一个日期和时间变量，如下面的代码所示。

d[, StartTimec11Alt := ifelse(is.na(SurveyStartTimec11),
                              mean(SurveyStartTimec11, na.rm = TRUE),
                              SurveyStartTimec11),
  by = .(UserID, Survey)]
d[, StartDayTimec11Alt := chron(
      dates. = format(SurveyDay, "%m/%d/%Y"),
     times. = StartTimec11Alt)]

大多数自相关函数是为单个时间序列设计的，因此我们将一次操作一个参与者。为了看一个例子，我们从单个参与者的图开始。我们先把数据做成时间序列对象，使用zoo()函数(其中“zoo”代表 Z 的有序观测值，“Z”是作者姓氏的第一个字母)。接下来，我们使用na.approx()函数通过插值来填充缺失值。最后，我们准备使用acf()函数计算自相关。结果如图 10-10 所示，显示积极影响在滞后 0 时(即同一时间点)完全相关，并且显示自相关性在较晚滞后时减小。由于我们每天有三次调查，也有可能滞后 3 的观测值具有更高的自相关性，因为这些观测值代表不同日期的相同时间。然而，数据并不支持这一点，相反，这表明绝对时间的流逝可能是最显著的因素。

img/439480_1_En_10_Fig10_HTML.png

图 10-10

一个参与者的自相关

tmpd <- d[UserID == 1]
acf(na.approx(zoo(tmpd$PosAff,
    order.by = tmpd$StartDayTimec11Alt)),
    lag.max = 10)

前面的代码显示了一个参与者的结果，但是我们有很多参与者。接下来的代码使用了一个扩展，acfByID()用来计算 ID 的自相关。我们可以用它来生成一个数据集，用于从 0 到 10 的积极影响和每个 ID 的自相关。我们可以对负面影响和压力重复这个过程，然后使用箱线图可视化结果，如图 10-11 所示。箱线图显示了每个滞后的自相关 id 的分布。在 0(无自相关)和0.5处添加线条，作为相对较强自相关的粗略指示。

acf.posaff <- acfByID("PosAff", "StartDayTimec11Alt",
                      "UserID", d)

print(acf.posaff)

##       UserID Variable Lag AutoCorrelation
##    1:      1   PosAff   0          1.0000
##    2:      1   PosAff   1          0.0016
##    3:      1   PosAff   2          0.1249
##   ---
## 2099:    191   PosAff   8         -0.0199
## 2100:    191   PosAff   9          0.1337
## 2101:    191   PosAff  10          0.1828

## make for other measures
acf.negaff <- acfByID("NegAff", "StartDayTimec11Alt",
                      "UserID", d)
acf.stress <- acfByID("STRESS", "StartDayTimec11Alt",
                      "UserID", d)

## put into one dataset for plotting a panel
acf.all <- rbind(
  acf.posaff, acf.negaff,
  acf.stress)

ggplot(acf.all,
    aes(factor(Lag), y = AutoCorrelation)) +
  geom_hline(yintercept = 0, colour = "grey50", size = 1) +
  geom_hline(yintercept = c(-.5, .5),
             linetype = 2, colour = "grey50", size = 1) +
  geom_boxplot() + ylab("Auto Correlation") +
  facet_wrap(~ Variable, ncol = 1)

图 10-11 的结果表明，滞后 1 秒后，自相关性相当小。因此，对于分析，我们将探索 lag1 预测。为此，我们需要创建包含 lag 1 值的变量，我们在下面的代码中就是这样做的。首先，因为滞后 1 是一个调查差异，我们需要一个新的衡量标准，对每个参与者的调查从开始到结束进行排序。请注意，以下代码仅适用于没有遗漏调查或遗漏调查已经添加的情况，就像我们在本章开始时所做的那样。然后，我们可以用它来计算滞后值。对于应对和睡眠，我们只能滞后一天，因为它们是每天测量的。

最后，我们可以将处理后的数据压缩并保存为 RDS 文件，以便在后面的章节中使用。

img/439480_1_En_10_Fig11_HTML.png

图 10-11

所有参与者积极和消极影响和压力的自相关

## ensure data ordered by ID, date, and time
d <- d[order(UserID, SurveyDay, SurveyInteger)]
## calculate a number for the survey from 1 to total
d[, USURVEYID := 1:.N, by = .(UserID)]

d[,
  c("NegAffLag1", "WNegAffLag1",
    "PosAffLag1", "WPosAffLag1",
    "STRESSLag1", "WSTRESSLag1") :=
    .SD[.(UserID = UserID, USURVEYID = USURVEYID - 1),
    .(NegAff, WNegAff,
      PosAff, WPosAff,
      STRESS, WSTRESS),
      on = c("UserID", "USURVEYID")]]

d[,
  c("WCOPEPrbLag1", "WCOPEPrcLag1",
    "WCOPEExpLag1", "WCOPEDisLag1",
    "WSOLsLag1", "WWASONsLag1") :=
  .SD[.(UserID = UserID, Survey = Survey, SurveyDay = SurveyDay - 1),
      .(WCOPEPrb, WCOPEPrc, WCOPEExp, WCOPEDis,
        WSOLs, WWASONs),
      on = c("UserID", "Survey", "SurveyDay")]]

## save data after processing, with compression
## for use in subsequent chapters
saveRDS(d, file = "aces_daily_sim_processed.RDS",
        compress = "xz")

假设

GLMMs 与其他回归模型有相似的假设。他们认为

  • 用于随机效果的单位是独立的

  • 在预测因素和结果之间有一个线性关系

  • 对于正态分布的结果，剩余方差是齐次的

  • 随机效应遵循(多元)正态分布

  • 结果来自预期分布(正态、泊松等。)

虽然没有很好的独立性测试，但其余的假设可以通过视觉进行评估。对于具有非正态结果的 GLMMs，评估结果的残差和分布可能更棘手。对于具有(至少假设的)正态分布结果的 GLMMs，可以检查残差和拟合与残差值的标准图，以检查残差方差是否同质，以及是否满足所有分布假设。在plotDiagnosticsLMER()功能中，这些诊断图被捆绑在一起。为了说明这些，我们拟合了一个模型，预测人与人之间和人与人之间压力的负面影响，包括随机截距和斜率。我们将等到以后再解释模型本身。目前，重点是检查假设。图 10-12 中的曲线显示残差过于集中，不符合正态分布。

img/439480_1_En_10_Fig12_HTML.png

图 10-12

负面影响混合效应模型诊断图，显示残差分布(左上)、残差与用于评估方差同质性的拟合值(右上)、随机截距分布(左中)、随机斜率分布(右中)以及随机效应是否为多元正态(左下)。

m.negaff <- lmer(NegAff ~ 1 + BSTRESS + WSTRESS +
            (1 + WSTRESS | UserID), data = d)
assumptiontests <- plotDiagnosticsLMER(m.negaff, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot, ncol = 2))

图 10-13 中的曲线显示，总体而言，正态性假设大致得到满足。确实有一个明显的多元异常值。

img/439480_1_En_10_Fig13_HTML.png

图 10-13

正面影响混合效应模型诊断图，显示残差分布(左上)、残差与用于评估方差同质性的拟合值(右上)、随机截距分布(左中)、随机斜率分布(右中)以及随机效应是否为多元正态(左下)。

m.posaff <- lmer(PosAff ~ 1 + BSTRESS + WSTRESS +
            (1 + WSTRESS | UserID), data = d)

assumptiontests <- plotDiagnosticsLMER(m.posaff, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot, ncol = 2))

为了进一步探索多元异常值，我们可以检查极值。这些按类型分开:Residuals, Random Effect UserID : WSTRESS和Multivariate Random Effect UserID。根据这些图，我们可能不太担心残差，因为我们有如此大的样本量。我们可以检查出多元异常值。在这种情况下，我们看到 id57 和 123 似乎是罪魁祸首。要查看没有这些多元异常值影响的结果，我们可以删除它们并重新估计模型。图 10-14 中的曲线显示，总体而言，正态假设大致得到满足，不再有任何单个随机效应的明显异常值，也不再有多元异常值。

img/439480_1_En_10_Fig14_HTML.png

图 10-14

正面影响混合效应模型诊断图，显示残差分布(左上)、残差与用于评估方差同质性的拟合值(右上)、随机截距分布(左中)、随机斜率分布(右中)以及随机效应是否为多元正态(左下)。结果去除两个多元异常值，IDs 57 和 123。

assumptiontests$ExtremeValues[
  EffectType == "Multivariate Random Effect UserID"]

##     PosAff UserID                        EffectType
##  1:    4.7    123 Multivariate Random Effect UserID
##  2:    3.9    123 Multivariate Random Effect UserID
##  3:    3.8    123 Multivariate Random Effect UserID
## ---
## 20:    3.7    123 Multivariate Random Effect UserID
## 21:    4.9    123 Multivariate Random Effect UserID
## 22:    4.6    123 Multivariate Random Effect UserID

m.posaff <- lmer(PosAff ~ 1 + BSTRESS + WSTRESS +
            (1 + WSTRESS | UserID),
            data = d[!UserID %in% c(57, 123)])

assumptiontests <- plotDiagnosticsLMER(m.posaff, plot = FALSE)
do.call(plot_grid, c(

  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot, ncol = 2))

为了更好地理解这些多元异常值的不同寻常之处，我们还可以将他们的数据与其他人在积极情感和压力方面的数据进行比较。一种方法是为数据集中的每个人绘制压力和积极影响关系的斜率，然后单独突出显示极端情况下的关系。我们也可以绘制数据点，只是为了极端的 id，以确保单个极端的观察不会驱动效果。这在图 10-15 中完成，该图显示 IDs 57 和 123 确实是极端的，尽管观察值似乎与估计的斜率一致。

img/439480_1_En_10_Fig15_HTML.png

图 10-15

积极的情感和压力联系突出了极端的情况。

ggplot() +
  stat_smooth(aes(WSTRESS, PosAff, group = UserID),
    data = d[!UserID %in% c(123)], method = "lm",
   se = FALSE, colour = "grey50") +
  stat_smooth(aes(WSTRESS, PosAff, group = UserID),
    data = d[UserID %in% c(123)], method = "lm",
   se = FALSE, colour = "blue", size = 2) +
  geom_point(aes(WSTRESS, PosAff),
    data = d[UserID %in% c(123)], colour = "blue", size = 2) +
  stat_smooth(aes(WSTRESS, PosAff, group = UserID),
  data = d[UserID %in% c(57)], method = "lm",
 se = FALSE, colour = "orange", size = 2) +
geom_point(aes(WSTRESS, PosAff),
  data = d[UserID %in% c(57)], colour = "orange", size = 2)

10.4 总结

本章介绍了多级数据结构以及它们通常是如何格式化或存储的(宽或长)。它展示了在处理多级数据和单级数据时，描述性统计的基本数据探索和报告会发生怎样的变化。它还展示了如何通过一次绘制一个级别的数据来可视化和评估广义线性混合模型(GLMMs)的一些常见假设。最后，它涵盖了纵向数据的具体情况，在这种情况下，额外的诊断，如是否有一致的时间趋势和变量本身随时间的自相关是重要的。表 10-4 总结了所使用的功能。

表 10-4

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| [] | 在data.table对象中执行数据管理，以计算缺失的数据，并对所有数据执行操作，或首先跨 id 合并，然后计算结果；处理多级数据时常用的操作 |
| acfByID() | 按 ID 计算各种滞后的自相关系数，并返回适用于汇总或绘图的数据集 |
| egltable() | 计算描述性统计数据，可选地按另一个变量的分组级别 |
| gglikert() | 显示描述性统计数据，如平均值，响应锚点位于图表的左侧和右侧 |
| iccMixed() | 计算变量的组内相关系数 |
| meanDecompose() | 获取一个变量，并将其分解为不同级别的平均值和残差，以便在多级数据的每个级别快速绘图 |
| nEffective() | 计算多级数据中变量的有效样本量 |
| plotDiagnosticsLMER() | 为线性混合模型创建各种诊断图 |
| reshape() | 将数据从宽格式调整为长格式或从长格式调整为宽格式 |

十一、GLMMs：线性

本章建立在处理多级数据的基础上，并介绍了一类适用于此类数据的统计模型——广义线性混合模型(GLMMs)。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(viridis)
library(JWileymisc)
library(data.table)
library(lme4)
library(lmerTest)
library(chron)
library(zoo)
library(pander)
library(texreg)
library(xtable)
library(splines)
library(parallel)
library(boot)

options(width = 70, digits = 2)

11.1 理论

本节更正式地介绍 GLMMs。glm 扩展了固定效果——仅扩展了前几章讨论过的 glm。提醒一下，对于 GLMs，我们将预期线性结果 η 定义为

$$ \eta = X\beta $$

(11.1)

期望的线性结果 η 通过链接函数 g( ) 映射到原始结果 y。

$$ \eta =g\left(\mu \right)=g\left(E(y)\right) $$

(11.2)

反向链接函数，g—1()，将的比例η 反向转换为 y 的比例

$$ E(y)=\mu ={g}^{-1}\left(\eta \right) $$

(11.3)

GLMMs 建立在这个结构上，增加了一些在只包含固定效果的 GLMs 中不必要的组件。

广义线性混合模型

对于 GLMs，期望值是预测值的函数，该预测值与参数估计值 Xβ 加权(相乘)。这些被称为固定效应，尽管在 GLMs 中通常没有明确说明，因为只有固定效应。在参数估计值 β 不变的意义上，它们是固定效应；它们不是随机变量。

对于重复测量或非独立数据，我们需要某种方法来捕捉观察值中的相关性。另一种思考方式是，非独立数据暗示着单位(人、学校、医院等)之间存在系统性差异。).GLMMs 通过向模型中添加另一个组件来解决这个问题，该组件显式地捕捉单元之间的这些差异。至于固定效应，这个分量有两个部分，一个数据矩阵，习惯上称为 Z，一个参数分量，习惯上称为γ。捕捉单元之间系统差异的最基本方法是允许每个单元有自己的截距。在对人的纵向研究中，这相当于每个参与者都有自己的截距。在这种情况下，Z 将是 0 和 1 值的块对角矩阵(想象一下在纵向数据集中对参与者 ID 变量进行虚拟编码)。这比描述起来容易。首先，我们可以为每个 ID 创建一个虚拟代码矩阵，存储为mat。然后我们可以为前 10 个参与者和前 300 个值绘制矩阵，如图 11-1 。在图像中，黑色区域表示 1，白色区域表示 0。注意我们使用data()函数从JWileymisc包中加载原始数据，然后读入我们在前面介绍 LMMs 基础知识的章节中制作并保存的处理过的数据。

img/439480_1_En_11_Fig1_HTML.png

图 11-1

UserID 的块对角伪码矩阵图。黑色值表示属于特定参与者的数据行。不同的列代表不同的参与者。

data(aces_daily)
draw <- as.data.table(aces_daily)
d <- readRDS("aces_daily_sim_processed.RDS")

mat <- model.matrix(~ 0 + factor(UserID), data = d)

image(t(mat[1:300, 1:10]), col = c("white", "black"),
      xlab = "Participants", ylab = "Observation",
      xaxt = "n", yaxt = "n")

在这个简单的例子中，γ向量对于每个参与者都有一个元素，这是该特定参与者的估计截距。对于当前数据集，有 191 个参与者，因此γ将包含 191 个参数估计。

将这个额外的部分与我们已经学习过的 GLM 模型放在一起，总 GLMM 被定义为

$$ \eta = X\beta + Z\gamma $$

(11.4)

对于这些特定的数据，使用仅截距模型，191 个参与者，总共 6599 个观察值，每个向量/矩阵的维数如下:img/439480_1_En_11_Figa_HTML.gif

在这种方法下变得清楚的一个方面是，如果我们单独估计γ中的每个参数，我们将最终得到至少与参与者一样多的参数，加上模型其余部分所需的任何其他参数。事实上，如果我们单独估计γ中的每个参数，我们目前描述的可以被估计为 GLM。虽然我们在概念上把 Zγ 和 Xβ 分开了，但是 GLM 可以同时估计两者。使 GLMMs 混合模型而不是 GLMs 具有大量伪代码的原因是我们不直接估计γ。在 GLMMs 中，我们不是估计γ中的每个参数，而是将γ视为随机变量或随机效应(因此混合效应，因为既有固定效应又有随机效应)。我们假设随机变量γ来自某种分布。具体来说，除了少数例外，我们假设γ来自一个正态分布。

为方便起见，我们使用 N 来表示正态或高斯分布。正态分布由两个参数决定，均值(或位置)、、μ 和标准差(或标度)、σ。从形式上来说，我们可以说γ分布为具有平均值和标准偏差的正态分布，或者为一个等式:

$$ \gamma \sim N\left(\mu, \sigma \right) $$

(11.5)

这种方法的好处是，无论我们有多少参与者，都不必单独估计γ的每个参数，仅截距 GLMM 只需要估计两个额外的参数， μ 和σ，即正态分布的参数。事实上，我们甚至不需要两个额外的参数。因为模型的固定效应部分， Xβ ，包括对截距的估计，我们已经知道均值(截距)将是多少。通常，γ被定义为固定效应捕捉到的与总体均值的偏差。平均来说，这些偏差总是为零，所以实际上只需要估计一个额外的参数，σ，我们写下

$$ \gamma \sim N\left(0,\sigma \right) $$

(11.6)

我们注意到，在几乎所有情况下，γ都被假定为服从正态分布。直观地看，对于 GLMMs，可能会使用其他分布。然而，即使在 GLMMs 中，我们可以假设结果遵循不同的分布(正态、伯努利、泊松等。)，随机效应通常仍被假定为正态分布。虽然严格来说不是 GLMMs 的要求，但大多数软件只实现正态分布的随机效应，唯一常见的例外是贝叶斯 GLMMs 的软件，通常允许更大的灵活性。

最后重要的一点。随机效应可能不止一个。如果有多个随机效应，那么γ将被假设为多元正态分布。这通过使用粗体 0 表示它是 0 处的均值向量，大写σ表示它是方差-协方差矩阵，而不是单个方差或标准差。

$$ \gamma \sim N\left(0,\sum \limits_{\theta}\right) $$

(11.7)

为了了解这些模型如何转化为具体的模型，我们可以估计一个只拦截 GLM 和一个只拦截 GLMM。在这个例子中，我们在每日日记研究中看到了积极的影响。我们将在后面的R中关注如何实际编码分析，因为现在我们只展示模型结果来关注模型的概念方面。表 11-1 比较了 GLM 和 GLMM 拦截模型的正面影响。

表 11-1

统计模型

|   |

全球语言监测机构

|

格勒姆

|
| --- | --- | --- |
| (截取) | 2.68(0.01) | 2.68(0.06) |
| R 2 | Zero |   |
| 调整 R 2 | Zero |   |
| 编号 obs。 | Six thousand three hundred and ninety-nine | Six thousand three hundred and ninety-nine |
| 均方根误差 | One point zero seven |   |
| 美国化学师学会(American Institute of Chemists) |   | Fourteen thousand eight hundred point five six |
| 比克 |   | Fourteen thousand eight hundred and twenty point eight five |
| 对数可能性 |   | –7397.28 |
| 民数记组:用户 ID |   | One hundred and ninety-one |
| Var: UserID(截距) |   | Zero point six three |
| Var:残差 |   | Zero point five three |

【p】<【0.001】<【0.01】

第一行显示固定效果截距。我们可以看到，估计值是可比的，但 GLMM 的标准误差(括号内)比 GLM 大。在 GLM，唯一的另一个参数是剩余标准差，标为“RMSE”。在 GLMM，有一个残差方差，标为“Var:Residual”；还有随机截取的方差，标记为“Var: UserID (Intercept)”。

GLM 有一个熟悉的解释。在 GLMM 中，截距估计值可以解释为参与者的平均截距。截距的方差让我们了解到个体参与者的截距有多分散。因为我们假设截距来自正态分布，所以标准的经验法则适用。也就是说，大约三分之二的参与者将落在平均值的一个标准差内。取截距方差的平方根，就可以求出截距标准差。据此，我们可以计算出大约三分之二的参与者的截距应该在

## 2.68 - 0.63 = 2.05

## 2.68 + 0.63 = 3.31

混合效应与多级模型术语

在继续之前，值得注意一个术语上的常见区别。这本书从混合效果模型的角度和使用术语介绍 GLMMs。然而，相同的模型也通常从多级模型的角度被调用和呈现。多级模型不使用矩阵，而是使用下标来表示哪些参数因参与者而异。首先，回到 GLM，我们可以用代数而不是矩阵来写这个模型，如下所示:

$$ {\eta}_i={b}_0 $$

(11.8)

下标表示第 i 个参与者的期望值。对于 GLMMs 或多水平模型，我们至少需要两个下标:一个用于参与者，一个用于参与者内部的观察。按照惯例，我们谈论来自第 j 位参与者的第 i 次观察。我们可以把 GLMM 模型写成如下:

$$ {\eta}_{ij}={b}_0+{\gamma}_{0j} $$

(11.9)

这个等式强调，任何特定的观察都是平均截距、 b 0 加上特定参与者与平均值的偏差、 γ 0j 的组合。在多级模型中，观察值的嵌套被称为不同的级别。因此，在我们的日常研究中，参与者内部的观察结果为 1 级，参与者层面的影响为 2 级。当只有两个级别时，人们通常将第一级称为“内部”，将第二级称为“之间”这对于我们的日常数据是有意义的，因为 1 级观察是单个参与者内部的观察或差异，2 级或参与者级别捕捉参与者之间的差异。

混合效果和多级术语和符号都很常见，所以知道它们是相同的底层模型是有帮助的。熟悉这两种符号将使习惯于这两种框架的人更容易工作。

统计推断

在线性回归中，统计推断(p 值、置信区间)计算起来很简单。因为回归系数除以它们的标准误差可以显示为遵循 t 分布，其自由度等于观察值的数量减去估计参数的数量。在线性混合效果中，没有计算正确自由度的公式。

因此,“正确的”p 值和置信区间应该是什么是未知的。因此，R中的lme4包默认不打印 p 值，也不提供任何自由度。但是，有几种策略可以估计置信区间和 p 值。

最简单的方法是假设样本量足够大，使得 t 分布接近正态分布，这样就不需要 t 分布的自由度，正态分布可以用作“足够接近”的代理。这可以用来计算 p 值和置信区间。

计算置信区间的更准确的方法是描绘似然函数。事实上，这是在lme4中向模型询问置信区间时使用的默认方式。虽然轮廓置信区间更精确，但是它们在计算上要求很高，并且在某些情况下可能不收敛或不可估计。

另一种方法是尝试估计大概的自由度。库兹涅佐娃及其同事【54】在lmerTest包中提供了基于萨特思韦特近似的自由度。一旦加载了lmerTest包，它实际上屏蔽了我们使用的lmer函数，以便计算近似的自由度并默认报告(近似的)p 值。与描绘似然函数相比，近似统计推断的自由度具有较低的计算成本。对于线性混合效应模型，即结果是连续的并假设为正态分布的 GLMMs，这种方法很简单，并且可能代表合理的“默认”选择。

我们在本书中不会深入讨论的最后两种可能性是使用自举或贝叶斯估计。虽然我们将展示一些例子，但是我们将这些方法的理论证明的范围留给其他更详细的文本。对于贝叶斯方法的优秀，先进的报道，见 Gelman 和他的同事[36]。关于自举理论的深入报道，请参见[26]。

自举包括抽取数据点的随机样本、估计模型、存储结果以及多次重复该过程以建立参数值的经验分布。这种方法的好处是它根据经验估计分布，因此不需要对参数采样分布的形状进行假设。尽管自举置信区间有许多可取的特性，但它们对计算要求很高，并且除了最基本的模型之外，其他模型都需要很长时间才能完成。这使得自举推理在迭代模型构建过程中成为一个困难的选择，例如当尝试各种协变量、函数形式的关系(线性、非线性等)时。).然而，bootstrapping 可能是验证最终模型或“高风险”案例(如随机对照试验)结果的绝佳选择。贝叶斯估计通过一个完全不同的框架依赖于统计推断。贝叶斯方法是强大的，并提供了一个非常有用的替代经典的频率统计描述到目前为止，在这本书。

在选择统计推断的方法时，一个特殊的考虑是，是否要对随机效应方差分量进行推断。依赖近似正态分布或近似自由度不适合方差分量，因为它们不能小于零，所以对称置信区间是不合理的。对于方差分量，置信区间可以通过描绘似然函数、自举或贝叶斯方法来获得。

最后，尽管我们在本章中关注的是连续的、正态分布的结果，但对于其他类型的 GLMMs，如二元或计数结果，自由度无法近似，因此统计推断必须通过假设正态分布、描绘可能性、自举或贝叶斯方法进行。

效果尺寸

在线性回归中，一个常见的效应大小是模型所占方差的比例， R 2 。在线性回归中，R2 很容易计算出来。总方差是模型解释的方差和剩余方差的组合。

$$ {R}²=1-\frac{\sigma_{residual}²}{\sigma_{total}²} $$

(11.10)

在混合效果模型中，计算 R 2 并不那么简单。方差可以用固定效应和随机效应来解释。计算伪 ?? 的一种方法是计算预测值和实际值之间的平方相关。

m <- lmer(NegAff ~ 1 + (1 | UserID), data = d)
cor(na.omit(d$NegAff), fitted(m))ˆ2

## [1] 0.45

最近，Nakagawa 和 Schielzeth [69]提出了两个版本，称为随机截距模型的边际和条件 R 2 。边际R2 是固定效应解释的方差与总方差的比值。总方差被定义为由固定效应解释的方差、由随机效应解释的方差(可以是一个或多个随机截距)和剩余方差之和。边际R2 代表由固定(边际)效应解释的方差百分比。在他们最初的公式中，Nakagawa 和 Schielzeth [69]有一个稍微不同的等式，因为他们对误差和离差方差有单独的术语，但是这些对于连续的正态分布结果是相同的。正态分布变量的简化公式如下:

$$ Marginal\kern0.125em {R}²=\frac{\sigma_{fixedeffects}²}{\sigma_{fixedeffects}²+{\sum}_{i=1}^k{\sigma}_{rando{m}_i}²+{\sigma}_{residual}²} $$

(11.11)

条件 R 2 的定义类似，但它是固定效应和随机效应占方差的百分比，如下所示:

$$ Conditional\kern0.125em {R}²=\frac{\sigma_{fixedeffects}²+{\sum}_{i=1}k{\sigma}_{rando{m}_i}²}{\sigma_{fixedeffects}²+{\sum}_{i=1}k{\sigma}_{rando{m}_i}²+{\sigma}_{residual}²} $$

(11.12)

在仅随机截距模型中，唯一的固定效应是截距，如前一等式中定义的条件R2 将与 ICC 相同。R2LMER函数使用这些公式计算线性混合模型的边际和条件R2。以下示例还显示了在仅具有截距的模型的情况下，条件R2 与 ICC 相同。

m <- lmer(NegAff ~ 1 + (1 | UserID), data = d)
R2LMER(m, summary(m))

##    MarginalR2 ConditionalR2
##          0.00          0.44

iccMixed("NegAff", "UserID", d)

##         Var Sigma  ICC
## 1:   UserID  0.21 0.44
## 2: Residual  0.27 0.56

由于 Nakagawa 和 Schielzeth [69]导出了随机截距模型的方程，Johnson [48]扩展了他们的方法，将随机截距和斜率模型结合起来。R2LMER函数包含这些更新，以适应仅随机截距和随机截距和斜率模型。

随机截距模型

最简单的混合效应模型是仅随机截取模型。随机截距模型可以包括任意数量的固定效应，但是按照惯例，该名称指的是唯一的随机效应是随机截距的模型。

随机截距通过允许每个参与者截距的差异来捕捉观察值的相关性。这样，在考虑截距的个体差异后，残差将(有条件地)独立。除了随机截距，可以添加任意数量的固定效果。

除了支持混合效应模型的理论方面和方程，可视化不同的模型可以帮助理解“随机”效应的真正含义。

可视化随机效果

我们假设读者熟悉标准的线性回归模型(只有固定效应的模型)。在我们一直使用的每日日记研究数据中，每个参与者报告了长达 12 天的入睡时间。如果我们想研究是否是某人的第一次，第二次，等等。研究中的一天以及他们入睡需要多少分钟(睡眠开始潜伏期；SOL)，我们可以使用线性回归模型，如下所示。

## data setup
d[,
  SurveyDayCount := as.integer(SurveyDay - min(SurveyDay)),
  by = UserID]

## setup mini dataset
tmpd <- d[!is.na(SOLs) & !is.na(SurveyDayCount),
  .(SOLs, SurveyDayCount, UserID)]

## fixed effects, all people
mreg <- lm(SOLs ~ 1 + SurveyDayCount, data = tmpd)
## add predictions to the dataset
tmpd[, Fixed := predict(mreg, newdata = tmpd)]

这种线性回归提供了两个平均(固定)效应。截距是参与者在研究的第一个晚上，即第 0 天的预期 SOLs。斜率是学习日一天变化的预期 SOLs 变化。这两个数字是研究中每个参与者的平均值。它们没有捕捉到参与者之间的任何个体差异。像这样的模型的一个好处是，它结合了所有的参与者数据，所以它对于异常值是相对健壮的。如果一个特定的参与者只有很少的数据点也没有关系，因为所有参与者的数据都是组合在一起的。值得注意的最后一点是，虽然平均截距和斜率是精确的估计值，但它们相关的 p 值会向下偏移，因为数据违反了观测值相互独立的假设。

另一个简单的方法是运行一个固定效应线性回归模型，但是为每个参与者运行单独的模型，如下所示。因为我们只想关注截距的差异，所以我们使用一个固定的偏移量来强制SurveyDay的斜率与我们之前拟合的总体平均固定效应模型相同。

## fixed effects, individual models
tmpd[, Individual := fitted(lm(SOLs ~ 1 +
  offset(coef(mreg)[2] * SurveyDayCount))),
  by = UserID]

这些单独的模型为每个单独的参与者估计不同的截距，但是使用平均斜率。因为每个模型适合一个参与者的数据，所以它们对异常值更敏感，并且如果特定参与者只有很少的数据点(例如，只有 2 或 3 天)，这些模型可能变得非常不稳定。这种个体化方法的一个好处是统计测试可能是准确的，因为在一个参与者中，天数可能是独立的。

最后，我们可以为学习日运行一个固定斜率的随机截距模型，如下面的代码所示。

## random intercept model, all people
m <- lmer(SOLs ~ 1 + + SurveyDayCount + (1 | UserID), data = tmpd)

## add predictions to the dataset
tmpd[, Random := predict(m, newdata = tmpd)]

随机截距模型允许每个人有不同的截距，但不是单独估计每个截距，而是假设它们来自正态分布，并估计该分布的均值和方差。所有参与者的数据都包含在一个模型中，所以这个模型对异常值或极端值也相对稳健。同时，随机截距确保不会对每个参与者使用单一平均值。

考虑随机截距模型的另外两种方式是，随机模型的截距估计值是个体截距和总体平均截距的加权组合。特定参与者的可用数据越多，随机截距估计值就越接近他们各自的估计截距。相反，参与者拥有的数据越少，随机截距就越接近总体平均值。在极端情况下(没有参与者的数据)，该模型能做的最好的事情是估计参与者将具有总体平均值。这种方法具有将个体估计值拉向总体均值的效果，这被称为收缩:极端估计值向均值收缩。如果你来自机器学习背景，这也是一种形式的模型正则化，因为约束被置于个体估计上以近似正态分布。

为了直观地显示这些模型之间的差异，我们可以为一些参与者绘制研究日和 SOL 之间的预测关系图。图 11-2 显示了固定个体模型和随机模型的估计轨迹，蓝色粗线显示了所有参与者的线性回归模型的截距和斜率。

img/439480_1_En_11_Fig2_HTML.png

图 11-2

单个回归模型和随机截距模型的估计轨迹图。蓝色显示的是人口平均值。虽然所有线都具有相同的斜率，但每条线的截距比单个模型更接近随机模型的总体平均值，这表明了收缩效应。

## select a few example IDs to plot
tmpdselect <- melt(tmpd[UserID %in% unique(UserID)[107:115]],
     id.vars = c("UserID", "SurveyDayCount", "SOLs"))

ggplot(tmpdselect[variable != "Fixed"],
       aes(SurveyDayCount, value, group = UserID)) +
  geom_abline(intercept = coef(mreg)[1], slope = coef(mreg)[2],
              size = 2, colour = "blue") +
  geom_line() +
  facet_wrap(~ variable)

查看模型之间差异的另一种方法是对照原始数据绘制估计轨迹。如图 11-3 所示。这些数字表明，单个固定效应模型或随机截距模型与总体平均值一样准确，甚至更准确。这些数字还强调，在每一种情况下，随机截距线与固定效应相同或更接近总体平均值，永远不会比个体固定效应模型更极端。

img/439480_1_En_11_Fig3_HTML.png

图 11-3

九个参与者的不同模型估计线与原始数据值的关系图

## plots against individual data
ggplot(tmpdselect, aes(SurveyDayCount)) +
  geom_point(aes(y = SOLs), size = 1) +
  geom_line(aes(y = value,
                colour = variable,
                linetype = variable), size = 1.5) +
  facet_wrap(~UserID, scales = "free_y") +
  scale_color_viridis(discrete = TRUE) +
  theme(legend.position = "bottom",
        legend.title = element_blank(),
        legend.key.width = unit(2, "cm"))

通过绘制单个模型的截距和随机效应模型的截距并显示变化，可以更清楚地观察收缩。这在图 11-4 中完成。为此，我们绘制了所有参与者的数据，并从各个模型中平均值最高的数据到平均值最低的数据进行排序。这突出表明，向样本均值(垂直线)收缩最大的是那些个人估计值相差最远的人。

img/439480_1_En_11_Fig4_HTML.png

图 11-4

每个参与者的个体模型和随机效应模型中的估计截距图，用箭头表示总体平均截距的缩减。

tmpd <- tmpd[SurveyDayCount==0][order(Individual)]
tmpd[, UserID := factor(UserID, levels = UserID)]

ggplot(tmpd, aes(x = Individual, xend = Random,
                 y = UserID, yend = UserID)) +
  geom_segment(
    arrow = arrow(length = unit(0.01, "npc"))) +
  geom_vline(xintercept = tmpd[SurveyDayCount==0][1, Fixed]) +
  xlab("Estimated Intercept") +
  theme(axis.text.y = element_blank())

解读随机截距模型

通常，解释模型的第一步是评估诊断以确保模型是合理的。一些基本诊断标绘在图 11-5 中。他们表明，残差是对称分布的，尽管不完全是正态分布，有一些潜在的异常值。它们还表明，残差方差随着预测值的增加而增加。似乎有一些相当极端的随机截距，随机截距的分布通常是正偏的，这表明这里的变换可能是有帮助的。适用于调查日和睡眠开始潜伏期的广义加性模型没有选择任何非线性，这表明假设线性关联可能是这些数据的合理近似。

img/439480_1_En_11_Fig5_HTML.png

图 11-5

混合效应模型诊断图，显示了残差分布(左上)、残差与拟合值，以评估方差的均匀性(右上)、随机截距分布(左下)，以及调查日和睡眠开始潜伏期之间关联的简单单层广义加性模型平滑，以评估非线性(右下)。

assumptiontests <- plotDiagnosticsLMER(m, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot,
  list(ggplot(d, aes(SurveyDayCount, SOLs)) +
       stat_smooth()),
  ncol = 2))

## `geom_smooth()` using method = 'gam' and formula 'y␣~␣s(x,␣bs␣=␣"cs")'

因为结果中有一些零值，所以对数转换不会很好地工作，所以我们可以尝试平方根转换。这需要重新安装模型并再次检查诊断。这在以下代码中完成，并绘制在图 11-6 中。结果显示在几个方面有所改善。残差具有较少的极值。残差方差在预测范围内更加均匀，随机截距分布更接近正态分布。似乎在调查日和睡眠开始潜伏期之间在平方根尺度上也有近似线性的关联，所以这似乎是一个合理的模型来呈现和解释。

img/439480_1_En_11_Fig6_HTML.png

图 11-6

混合效应模型诊断图，显示了残差分布(左上)、残差与拟合值，以评估方差的均匀性(右上)、随机截距分布(左下)，以及调查日和睡眠开始潜伏期之间关联的简单单层广义加性模型平滑，以评估非线性(右下)。

d[, sqrtSOLs := sqrt(SOLs)]
m2 <- lmer(sqrtSOLs ~ SurveyDayCount + (1 | UserID),
           data = d)

assumptiontests <- plotDiagnosticsLMER(m2, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot,
  list(ggplot(d, aes(SurveyDayCount, sqrtSOLs)) +
       stat_smooth()),
  ncol = 2))

## `geom_smooth()` using method = 'gam' and formula 'y␣~␣s(x,␣bs␣=␣"cs")'

解释和表示模型的一个很好的起点是summary()函数，如下面的代码所示。因为我们加载了lmerTest包，所以结果包括基于这些包的 t 检验的近似自由度和 p 值。在随机效应标题下，我们可以看到它和残差的随机截距的估计标准偏差大致相等，表明每个水平的方差水平大致相等。还会显示模型中包含的观察数量和单位数量。在固定效应标题下，总平均截距显示为调查日和平方根转换睡眠开始潜伏期之间的平均关联。统计测试测试这些中的每一个是否在统计上显著不同于零。对于与调查日的关联来说，这可能是一个足够合理的问题，但对于截距来说并不特别有趣，因为平均睡眠开始潜伏期为零是不可信的。一般来说，固定效应可以被解释为类似于它们在单级广义线性模型中的解释。在这种情况下，在调查日和睡眠开始潜伏期的平方根之间存在统计学上显著的关联，因此研究中每增加一天，睡眠开始前的平方根分钟数就减少-0.02。

summary(m2)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: sqrtSOLs ~ SurveyDayCount + (1 | UserID)
##    Data: d
##
## REML criterion at convergence: 9552
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -3.486 -0.601 -0.012  0.490  4.878
##
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  UserID   (Intercept) 3.72     1.93
##  Residual             4.50     2.12
## Number of obs: 2097, groups:  UserID, 191
##
## Fixed effects:
##                 Estimate Std. Error        df t value Pr(>|t|)
## (Intercept)       4.4578     0.1639  289.5176   27.20   <2e-16 ***
## SurveyDayCount   -0.0223     0.0135 1914.7904   -1.65      0.1 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##             (Intr)
## SurveyDyCnt -0.438

最近，许多期刊希望置信区间与估计值一起呈现，而不是估计值和标准误差。正如本章前面讨论统计推断时提到的，有几种方法可以计算置信区间。一般来说，置信区间是使用confint函数获得的，但是这些方法可以有所不同，从简单的 Wald 方法(使用标准误差，基本上假设足够大的自由度，使得 t 分布接近正态分布)到更精确但耗时的 profile 和 bootstrap 方法。每一个都是定时的，以提供每种方法的相对强度的一些指示。

system.time(
  ci.wald <- confint(m2,
   method = "Wald", oldNames = FALSE))

##    user  system elapsed
##    0.02    0.00    0.01

system.time(
  ci.profile <- confint(m2,
   method = "profile", oldNames = FALSE))

## Computing profile confidence intervals ...

##    user  system elapsed
##    0.98    0.00    0.99

system.time(
  ci.boot <- confint(m2,
   method = "boot", oldNames = FALSE,
   nsim = 200, seed = 1234))

## Computing bootstrap confidence intervals ...

##    user  system elapsed
##     4.3     0.0     4.4

ci.compare <- data.table(
  Param = rownames(ci.wald),
  Wald = sprintf("%0.2f, %0.2f",
    ci.wald[,1], ci.wald[,2]),
  Profile = sprintf("%0.2f, %0.2f",
    ci.profile[,1], ci.profile[,2]),
  Boot = sprintf("%0.2f, %0.2f",
    ci.boot[,1], ci.boot[,2]))

print(ci.compare)

##                    Param        Wald     Profile        Boot
## 1: sd_(Intercept)|UserID      NA, NA  1.72, 2.16  1.70, 2.15
## 2:                 sigma      NA, NA  2.06, 2.19  2.05, 2.18
## 3:           (Intercept)  4.14, 4.78  4.14, 4.78  4.12, 4.80
## 4:        SurveyDayCount -0.05, 0.00 -0.05, 0.00 -0.05, 0.01

虽然存在微小的差异，但在这种情况下，通常三种方法具有高度的一致性，但 Wald 方法几乎是即时的，profile 方法需要很短的时间，bootstrap 需要足够长的时间才能被注意到，尤其是在交互式模型构建期间。

以下是基于 Wald 方法的完整结果。

testm2 <- detailedTests(m2, method = "Wald")

## Parameters and CIs are based on REML,
## but detailedTests requires ML not REML fit for comparisons,
## and these are used in effect sizes. Refitting.

formatLMER(list(testm2))

##                       Term                Model 1
##  1:          Fixed Effects
##  2:            (Intercept)  4.46*** [ 4.14, 4.78]
##  3:         SurveyDayCount    -0.02 [-0.05, 0.00]
##  4:         Random Effects
##  5:  sd_(Intercept)|UserID                   1.93
##  6:                  sigma                   2.12
##  7:          Overall Model
##  8:               Model DF                      4
##  9:             N (UserID)                    191
## 10:       N (Observations)                   2097
## 11:                 logLik               -4771.82
## 12:                    AIC                9551.65
## 13:                    BIC                9574.24
## 14:            Marginal R2                   0.00
## 15:         Conditional R2                   0.45
## 16:           Effect Sizes
## 17: SurveyDayCount (Fixed)    0.00/0.00, p = .099

以下是基于轮廓似然法的完整结果。固定效果不会改变。然而，轮廓似然能够估计随机效应的置信区间。

testm2b <- detailedTests(m2, method = "profile")

## Computing profile confidence intervals ...

## Parameters and CIs are based on REML,
## but detailedTests requires ML not REML fit for comparisons,
## and these are used in effect sizes. Refitting.

formatLMER(list(testm2b))

##                       Term                Model 1
##  1:          Fixed Effects
##  2:            (Intercept)  4.46*** [ 4.14, 4.78]
##  3:         SurveyDayCount    -0.02 [-0.05, 0.00]
##  4:         Random Effects
##  5:  sd_(Intercept)|UserID      1.93 [1.72, 2.16]
##  6:                  sigma      2.12 [2.06, 2.19]
##  7:          Overall Model
##  8:               Model DF                      4
##  9:             N (UserID)                    191
## 10:       N (Observations)                   2097
## 11:                 logLik               -4771.82
## 12:                    AIC                9551.65
## 13:                    BIC                9574.24
## 14:            Marginal R2                   0.00
## 15:         Conditional R2                   0.45
## 16:           Effect Sizes
## 17: SurveyDayCount (Fixed)    0.00/0.00, p = .099

随机截距和斜率模型

以前我们只介绍了随机截距模型。然而，混合效应模型可以允许包括一个或多个随机斜率参数。作为随机斜率包含的预测值的唯一要求是，它必须在参与者(或用于随机效应的任何高阶聚类单元)内部变化。

使用我们在本章中使用的数据，学习日、压力和睡眠都可能是随机斜率。年龄、教育程度以及参与者是否出生在澳大利亚境内或境外都不可能是随机的斜率。换句话说，要作为随机斜率包括在内，变量必须在单位(此处为参与者)内至少有一些可变性。只在单位之间(而不在单位内)变化的变量不能是随机斜率。

随机斜率的工作方式与随机截距相同。也就是说，我们可以想象估计每个参与者(或任何其他高阶单位)的预测值和结果之间的独立斜率。但是，随机斜率模型不是估计单个斜率，而是假设斜率来自某个分布，并估计该分布的参数。几乎所有的分布都是正态分布，因此均值和方差都是估计的。

就方程式而言，我们之前将 GLMMs 定义为

$$ \eta = X\beta + Z\gamma $$

(11.13)

对于这些特定数据，随机截距和斜率，191 个参与者，总共 6599 个观察值，每个向量/矩阵的维数如下:img/439480_1_En_11_Figb_HTML.gif

在这种情况下，Z 的列数是参与者的两倍，因为对于随机截距，每个参与者有一列，对于随机斜率，每个参与者有一列。

与只有一种随机效应的模型(如只有随机截距的模型)相比，这种随机截距和斜率模型的另一个变化是随机效应现在包括方差和协方差。协方差表示随机效应之间的相关程度。例如，如果参与者开始时较高(更正的随机截距)倾向于具有更负的斜率，截距和斜率之间会有负的关系。举一个实际的例子，如果一个参与者在第一天晚上睡了 12 个小时，第二天的睡眠不太可能会增加，因为这需要在晚上睡 12 个小时以上。相反，如果参与者在第一天彻夜未眠，睡眠时间为 0 小时，那么几乎可以肯定的是，在接下来的几天里睡眠时间会增加。关键在于，在许多情况下，随机截距和斜率可能相互关联是有意义的，并且在R,中建模随机效应的默认方式中，估计了随机效应的完整方差-协方差矩阵。可以将协方差固定为零，强制随机效应相互独立，但通常最好尽可能避免这种情况。

理论上，混合效应模型可以包括随机斜率，但不包括随机截距；然而，实际上这几乎从未发生过。只有在所有参与者都从同一点开始但斜率不同的情况下，具有随机斜率而非随机截距的模型才有意义。如果参与者实际上有不同的截距，强迫他们相同将会扭曲随机斜率，因为他们的斜率必须都通过相同的平均截距。相反，包含不必要的随机截距不会对模型或结果产生有意义的偏差。

为了探究随机截距和斜率模型与标准线性回归之间的差异，我们将遵循与随机截距相似的步骤。在我们一直使用的每日日记研究数据中，每个参与者报告了长达 12 天的入睡时间。如果我们想研究是否是某人的第一次，第二次，等等。研究中的一天以及他们入睡需要多少分钟(睡眠开始潜伏期；SOL)，首先，我们估计一个线性回归模型，如下。

## setup dataset
tmpd <- d[!is.na(sqrtSOLs) & !is.na(SurveyDayCount),
  .(sqrtSOLs, SurveyDayCount, UserID)]

## fixed effects, all people
mreg <- lm(sqrtSOLs ~ 1 + SurveyDayCount, data = tmpd)
## add predictions to the dataset
tmpd[, Fixed := predict(mreg, newdata = tmpd)]

这种线性回归提供了两个平均(固定)效应。截距是参与者在研究的第一个晚上，即第 0 天的预期 SOLs。斜率是学习日一天变化的预期 SOLs 变化。这两个数字是研究中每个参与者的平均值。它们没有捕捉到参与者之间的任何个体差异。像这样的模型的一个好处是，它结合了所有的参与者数据，所以它对于异常值是相对健壮的。如果一个特定的参与者只有很少的数据点也没有关系，因为所有参与者的数据都是组合在一起的。与随机截距模型一样，虽然线性回归可以精确估计截距和斜率，但标准误差、p 值和任何置信区间都会有偏差。

我们还可以为每个参与者运行单独的线性回归模型，如下所示。

## fixed effects, individual models
tmpd[, Individual := fitted(lm(sqrtSOLs ~ 1 + SurveyDayCount)),
  by = UserID]

这些单独的模型为每个单独的参与者估计不同的截距和不同的斜率。由于截距和斜率都是针对单个参与者单独估计的，截距和斜率对异常值都很敏感，并且在很少观察的参与者中不稳定。

最后，我们可以运行一个随机截距和斜率模型，如下面的代码所示。为了包括随机斜率，我们将SurveyDayCount添加到模型的随机部分(在括号内，在指示这些参数应该随机变化UserID的竖线之前)。注意，尽管我们想要一个SurveyDayCount的随机斜率，我们也包括了一个SurveyDayCount的固定效果。

## random intercept model, all people
m <- lmer(sqrtSOLs ~ 1 + SurveyDayCount +
          (1 + SurveyDayCount | UserID), data = tmpd)
## add predictions to the dataset
tmpd[, Random := predict(m, newdata = tmpd)]

随机模型允许每个个体具有不同的截距和斜率，但这些被假定来自多元正态分布，并且(多元)正态分布的参数是估计的。与我们之前检查的随机截距模型一样，我们可以通过绘制一些参与者的研究日和 SOL 之间的预测关系来可视化随机和固定效应模型之间的差异。图 11-7 显示了来自固定个体模型和随机模型的估计轨迹，以及来自所有参与者的线性回归模型的斜率。

img/439480_1_En_11_Fig7_HTML.png

图 11-7

单个回归模型和随机截距模型的估计轨迹图。蓝色显示的是人口平均值。随机模型将截距和斜率拉得更接近群体平均截距和斜率，显示了收缩效应。

## select a few example IDs to plot
tmpdselect <- melt(tmpd[UserID %in% unique(UserID)[107:115]],
     id.vars = c("UserID", "SurveyDayCount", "sqrtSOLs"))

ggplot(tmpdselect[variable != "Fixed"],
       aes(SurveyDayCount, value, group = UserID)) +
  geom_abline(intercept = coef(mreg)[1], slope = coef(mreg)[2],
              size = 2, colour = "blue") +
  geom_line() +
  facet_wrap(~ variable)

查看模型之间差异的另一种方法是对照原始数据绘制估计轨迹。如图 11-8 所示。这些数字表明，单个固定效应模型或随机效应模型与总体平均值一样准确，甚至更准确。这些数字还强调，在每一种情况下，随机截距线与固定效应相同或更接近总体平均值，永远不会比个体固定效应模型更极端。事实上，对于参与者 114，随机效应模型将斜率显著拉回到群体平均值，从而最小化研究开始时极端 SOL 的影响。

img/439480_1_En_11_Fig8_HTML.png

图 11-8

九个参与者的不同模型估计线与原始数据值的关系图

## plots against individual data
ggplot(tmpdselect, aes(SurveyDayCount)) +
  geom_point(aes(y = sqrtSOLs), size = 1) +
  geom_line(aes(y = value,
                colour = variable,
                linetype = variable), size = 1.5) +
  facet_wrap(~UserID, scales = "free_y") +
  scale_color_viridis(discrete = TRUE) +
  theme(legend.position = "bottom",
        legend.title = element_blank(),
        legend.key.width = unit(2, "cm"))

为了突出收缩与模型拟合的关系，我们可以绘制估计斜率的变化。

img/439480_1_En_11_Fig9_HTML.png

图 11-9

每个参与者的个体模型和随机效应模型中的估计斜率图，用箭头表示向总体平均斜率的收缩

tmpd <- d[, .(
  Individual = coef(lm(
    sqrtSOLs ~ 1 + SurveyDayCount))[2]),
  by = UserID]

## estimated random slope is deviation + average
tmpd$Random <- ranef(m)$UserID[, "SurveyDayCount"] + fixef(m)[2]
tmpd <- tmpd[order(Individual)]
tmpd[, UserID := factor(UserID, levels = UserID)]

ggplot(tmpd, aes(x = Individual, xend = Random,
                 y = UserID, yend = UserID)) +
  geom_segment(
    arrow = arrow(length = unit(0.01, "npc"))) +
  geom_vline(xintercept = coef(mreg)[2]) +
  xlab("Estimated Slope") +
  theme(axis.text.y = element_blank())

截距和斜率作为结果

随机截距和斜率允许每个个体(或单元)之间的水平(截距)和关联(斜率)不同。对于给定的人(单位)，即使可能有重复的测量，它们也只会有一个截距和一个斜率值。因此，尽管随机截距和斜率是从重复测量(水平内)数据估计的，截距和斜率本身是水平间变量。也就是说，个人的截距(或斜率)不会因评估而异。假设截距和斜率值确实因人而异，人们可能会对识别截距和斜率的预测因子感兴趣。为了更具体地说明这一点，我们可以用图表来表示这个问题。图 11-10 显示了具有随机截距和斜率的两级模型(内部和之间)的混合效应模型图。x使用随机斜率和随机截距在内部水平预测结果变量y。随机截距(I)和随机斜率(s)本身是中间水平的结果变量，由中间水平预测器w预测。

img/439480_1_En_11_Fig10_HTML.png

图 11-10

级别内和级别间的示例图。正方形表示观察到的变量(如结果、预测因素)。空心圆表示潜在变量(即较高水平的随机效应)。实心圆表示随机效应(即随机截距、斜率)。在内部级别，对于x上的y的斜率，存在随机截距(I)和随机斜率(s)。在中间水平，有两个潜在变量:一个是随机截距(I)，另一个是由中间水平变量w预测的随机斜率(s)。

作为一个具体的例子，之前我们检查了一个混合效应模型，该模型通过研究中的随机截距和随机斜率预测入睡时间(睡眠开始潜伏期)。假设我们想知道平均起来醒来更多的参与者是否也需要更长的时间才能入睡(即，醒来预测随机截距)，或者在研究期间醒来较少的参与者是否变化较少(即，更平坦的随机斜率)。平均醒来次数不变，所以是个人变量。从图表来看，如图 11-11 所示。在该图中，睡眠开始潜伏期(SOL)的随机截距和 SOL 在研究日的斜率均由水平间预测因子(平均觉醒)预测。

img/439480_1_En_11_Fig11_HTML.png

图 11-11

用随机截距和斜率预测睡眠开始潜伏期(SOL)的研究日内和水平间图，以及预测随机截距和斜率的平均觉醒次数。

如果将截距和斜率视为新的(潜在的、未观察到的)变量，那么根据混合效应模型的估计在数据集中创建新的变量可能会很有诱惑力。这可以在R中通过提取截距和斜率的随机系数估计相对容易地完成。以下代码创建一个具有 ID、性别和年龄的级别间数据集，并将其与混合效果模型中的截距和斜率估计值相结合，这些估计值是使用coef()函数提取的。

between_data <- cbind(
  d[, .(
  BWASONs = na.omit(BWASONs)[1]),
  by = UserID][order(UserID)],
  coef(m)$UserID)

截距和斜率的估计值有时被称为 BLUPs，用于个体截距和斜率的最佳线性无偏预测。利用这些，我们可以在中间水平运行一个常规的广义线性模型。结果如表 11-2 所示。他们揭示了更高的平均觉醒预测更高的截距，但不预测随机斜率。

表 11-2

统计模型

|   |

拦截

|

倾斜

|
| --- | --- | --- |
| (截取) | 4.093 | –0.022 |
|   | (0.218) | (0.001) |
| 屈臣氏 | 0.394 | Zero |
|   | (0.189) | (0.001) |
| R 2 | Zero point zero two two | Zero |
| 调整 R 2 | Zero point zero one seven | –0.005 |
| 编号 obs。 | One hundred and ninety-one | One hundred and ninety-one |
| 均方根误差 | One point eight | Zero point zero one |

【p】<【0.001】<【0.01】

between.int <- lm(`(Intercept)` ~ BWASONs,
                 data = between_data)
between.slope <- lm(SurveyDayCount ~ BWASONs,
             data = between_data)

texreg(list(
  Intercept = between.int,
  Slope = between.slope),
  digits = 3,
  label = "tglmml-blups",
  float.pos = "!hb")

虽然这是一种直观的吸引人的方法，但提取随机效应的 BLUPs 并在单独的分析中使用它们并不是最佳策略。一个主要限制是，对于每个个体，提取截距和斜率的单个估计，然后在后续模型中处理这些估计，就好像它们被无误差地观察和测量一样。也就是说，实际上具有某种程度不确定性的估计被视为没有不确定性的精确已知。实际上，这些估计通常存在很大的不确定性。尽管推导 BLUPs 的精确置信区间很困难，但是通过将condVar = TRUE参数指定给ranef()函数，可以很容易地生成近似置信区间。结果绘制在图 11-12 中，它们表明该模型对于每个个体的随机截距和斜率估计具有高度的不确定性。这种不确定性凸显了提取单一最佳估计并将其视为完美的问题。

img/439480_1_En_11_Fig12_HTML.png

图 11-12

具有近似置信区间的估计随机效应的点阵图

ggplot(as.data.frame(ranef(m, condVar = TRUE)),
 aes(grp, condval,
     ymin = condval - 2 * condsd,
     ymax = condval + 2 * condsd)) +
 geom_pointrange(size = .2) +
 facet_wrap(~ term, scales = "free_x") +
 coord_flip() +
 theme(axis.text.y = element_blank(),
       axis.ticks.y = element_blank()) +
  ylab("Random effect + uncertainty") +
  xlab("Participant ID")

虽然提取 BLUPs 或每个个体的随机截距和斜率的其他单个估计并不是最佳的，但检查随机截距或斜率的预测值通常是合适且有趣的。包含随机效应预测值的最佳方法是将它们作为混合效应模型的一部分，以便在一个模型中同时估计随机效应及其预测值。这样就可以把不确定性考虑进去。通过水平间变量预测随机效应转化为所谓的水平间相互作用，即水平间变量和水平内变量的相互作用。乍一看，预测随机截距或斜率需要交互作用，这似乎有悖直觉。然而，预测随机斜率的实际含义是，研究日与睡眠开始潜伏期(斜率)的关联取决于平均醒来次数。以这种方式解释，希望在这种情况下“预测斜率”和交互如何捕捉相同的问题变得更加清晰。因为随机截距是对一个常数(按照惯例，数字 1)的结果的回归，预测随机截距的交互方面可以忽略，因为任何变量乘以 1 就是变量。

总之，在我们的混合效应模型中，检验平均觉醒次数是否预测随机截距和斜率的理想方法是添加平均觉醒次数乘以 1 作为预测值(这是随机截距的预测值)，并添加研究日 x 平均觉醒互动次数作为预测值(预测随机斜率)。表 11-3 显示了单一混合效果模型和先前模型提取 BLUPs 并运行线性回归的结果。在该表中，我们可以看到随机截距(BWASONs)预测和随机斜率(SurveyDayCount:BWASONs)预测的估计值和标准误差存在差异。通常情况下，当考虑随机截距和斜率中的不确定性(测量误差)时，影响的幅度更大，但估计中也存在更大的不确定性，由更大的标准误差表示。

表 11-3

统计模型

|   |

拦截

|

倾斜

|

随意

|
| --- | --- | --- | --- |
| (截取) | 4.093 | –0.022 | 4.014 |
|   | (0.218) | (0.001) | (0.272) |
| 屈臣氏 | 0.394 | Zero | 0.480 |
|   | (0.189) | (0.001) | (0.236) |
| 调查日计数 |   |   | –0.015 |
|   |   |   | (0.023) |
| 调查日计数:BWASONs |   |   | –0.008 |
|   |   |   | (0.020) |
| R 2 | Zero point zero two two | Zero |   |
| 调整 R 2 | Zero point zero one seven | –0.005 |   |
| 编号 obs。 | One hundred and ninety-one | One hundred and ninety-one | Two thousand and ninety-seven |
| 均方根误差 | One point eight | Zero point zero one |   |
| 美国化学师学会(American Institute of Chemists) |   |   | Nine thousand five hundred and seventy point nine one four |
| 比克 |   |   | Nine thousand six hundred and sixteen point one |
| 对数可能性 |   |   | –4777.457 |
| 民数记组:用户 ID |   |   | One hundred and ninety-one |
| Var: UserID(截距) |   |   | Three point six four |
| Var: UserID 调查天数 |   |   | Zero point zero zero two |
| Cov: UserID(截距)SurveyDayCount |   |   | –0.004 |
| Var:残差 |   |   | Four point four seven nine |

<【0.001】*<<***

me.prediction <- lmer(sqrtSOLs ~
   SurveyDayCount + BWASONs +
   SurveyDayCount:BWASONs +
   (1 + SurveyDayCount | UserID),
  data = d)

texreg(list(
  Intercept = extract(between.int),
  Slope = extract(between.slope),
  Random = extract(me.prediction)),
  digits = 3,
  label = "tglmml-blupsme",
  float.pos = "!hb")

11.2 R示例

随机截距的线性混合模型

我们之前研究了一个随机截取的积极影响模型。之前我们关注了简单线性模型和随机截距模型的对比。现在我们将重点介绍R中线性混合模型的设计和设置。

lmer()函数使用类似于lm()和R中其他建模函数的公式接口。指定结果变量，后跟一个波形符，然后是所有预测变量。线性混合效应模型与线性模型的区别在于添加了随机效应。固定效果与线性模型中的固定效果一样添加。随机效果加在括号内。在括号内，随机效应被写成任何其他模型公式，除了在竖线之后的末端，聚类变量被列出。

## mixed effects, with random intercept by ID
m.lmm <- lmer(PosAff ~ 1 + (1 | UserID), data = d)
summary(m.lmm)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: PosAff ~ 1 + (1 | UserID)
##    Data: d
##
## REML criterion at convergence: 14795
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -4.345 -0.647 -0.034  0.617  4.058
##
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  UserID   (Intercept) 0.629    0.793
##  Residual             0.529    0.727
## Number of obs: 6399, groups:  UserID, 191
##
## Fixed effects:
##             Estimate Std. Error       df t value Pr(>|t|)
## (Intercept)   2.6787     0.0581 189.8310    46.1   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1

仅与线性模型相比，固定效应的标准误差更大，并且增加了随机截距，如下文总结所示。

## fixed effects only, GLM
m.lm <- lm(PosAff ~ 1, data = d)
summary(m.lm)

##
## Call:
## lm(formula = PosAff ~ 1, data = d)
##
## Residuals:
##     Min      1Q  Median      3Q     Max
## -1.6760 -0.8751 -0.0065  0.7886  2.3240
##
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)
## (Intercept)   2.6760     0.0134     200   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Residual standard error: 1.1 on 6398 degrees of freedom
##   (528 observations deleted due to missingness)

## nice side by side comparison

screenreg(list(
  GLM = extract(m.lm),
  GLMM = extract(m.lmm)))

##
## ==================================================
##                          GLM          GLMM
## --------------------------------------------------
## (Intercept)                 2.68 ***      2.68 ***
##                            (0.01)        (0.06)
## --------------------------------------------------
## R²                         0.00
## Adj. R²                    0.00
## Num. obs.                6399          6399
## RMSE                        1.07
## AIC                                   14800.56
## BIC                                   14820.85
## Log Likelihood                        -7397.28
## Num. groups: UserID                     191
## Var: UserID (Intercept)                   0.63
## Var: Residual                             0.53
## ==================================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

类似于R中的任何其他回归建模函数，可以很容易地添加额外的固定效应预测值。下面的例子增加了平均压力作为正面影响的固定效应预测因子。来自summary()的结果显示，较高的平均压力与明显较低的积极影响相关。

## mixed effects, with random intercept by ID
m2.lmm <- lmer(PosAff ~ 1 + BSTRESS + (1 | UserID), data = d)
summary(m2.lmm)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: PosAff ~ 1 + BSTRESS + (1 | UserID)
##    Data: d
##
## REML criterion at convergence: 14762
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -4.347 -0.645 -0.034  0.617  4.049
##
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  UserID   (Intercept) 0.517    0.719
##  Residual             0.529    0.727
## Number of obs: 6399, groups:  UserID, 191
##
## Fixed effects:
##             Estimate Std. Error       df t value Pr(>|t|)
## (Intercept)   3.2201     0.0998 188.3579    32.3  < 2e-16 ***
## BSTRESS      -0.2300     0.0359 188.6190    -6.4  1.2e-09 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##         (Intr)
## BSTRESS -0.848

在我们对模型结果有信心之前，检查模型的假设是很重要的。使用plotDiagnosticsLMER()函数可以很容易地测试模型的几个假设。这些结果如图 11-13 所示。它们显示了残差的近似对称分布，几乎没有异方差的证据，以及正态分布的随机截距。在平均压力和积极情感的关系上，确实存在着某种非线性。

img/439480_1_En_11_Fig13_HTML.png

图 11-13

混合效应模型诊断图，显示残差分布(左上)、残差与拟合值以评估方差的均匀性(右上)、随机截距分布(左下)以及简单的单级广义加性模型(平滑平均应力和正应力之间的关联以评估非线性)(右下)。

assumptiontests <- plotDiagnosticsLMER(m2.lmm, plot = FALSE) do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot,
  list(ggplot(d, aes(BSTRESS, PosAff)) +
       stat_smooth()),
  ncol = 2))

## `geom_smooth()` using method = 'gam' and formula 'y␣~␣s(x,␣bs␣=␣"cs")'

考虑到图 11-13 中所示的非线性关联的证据，我们应该考虑更灵活的函数形式。前几章介绍了样条和广义加性模型(gam)。虽然我们没有讨论混合效果模型的 gam，但是我们可以相对容易地引入样条。然而，首先，我们需要确定什么样的样条曲线可以近似地表示数据。这是最容易实现的视觉比较样条与游戏。图 11-14 中显示了几种 B 样条与 GAM 的关系。结果表明，10 自由度模型的灵活性太大，虽然没有捕捉 GAM 中的一些波动，但比线性拟合更灵活，3 自由度 B 样条模型的趋势相当平滑。

img/439480_1_En_11_Fig14_HTML.png

图 11-14

使用 3 个自由度、10 个自由度的 B 样条曲线和一个广义加法模型绘制平均应力与积极影响的关系图。

ggplot(d, aes(BSTRESS, PosAff)) +
  stat_smooth(method = "lm",
              formula = y ~ bs(x, df = 3),
              colour = viridis(3)[1]) +
  stat_smooth(method = "lm",
              formula = y ~ bs(x, df = 10),
              colour = viridis(3)[2]) +
  stat_smooth(colour = viridis(3)[3])

## Warning: Removed 528 rows containing non-finite values (stat_smooth).
## Warning: Removed 528 rows containing non-finite values (stat_smooth).

## `geom_smooth()` using method = 'gam' and formula 'y␣~␣s(x,␣bs␣=␣"cs")'

## Warning: Removed 528 rows containing non-finite values (stat_smooth).

我们可以使用bs()函数将 B 样条曲线添加到模型中，然后使用赤池信息标准(AIC)将带有 B 样条曲线的模型与带有线性趋势的模型进行比较。请注意，AIC 依赖于真实可能性；因此，我们使用refitML()代替默认的、提供伪似然的受限最大似然来重新调整模型。AIC 提出了一个更好的拟合，尽管是适度的，B 样条与线性模型。

## mixed effects model
m3.lmm <- lmer(PosAff ~ 1 + bs(BSTRESS, df = 3) +
                 (1 | UserID), data = d)
summary(m3.lmm)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: PosAff ~ 1 + bs(BSTRESS, df = 3) + (1 | UserID)
##    Data: d
##
## REML criterion at convergence: 14752
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -4.352 -0.644 -0.034  0.618  4.052
##
## Random effects:
##  Groups   Name        Variance Std.Dev.
##  UserID   (Intercept) 0.509    0.713
##  Residual             0.529    0.727
## Number of obs: 6399, groups:  UserID, 191
##
## Fixed effects:
##                      Estimate Std. Error      df t value Pr(>|t|)
## (Intercept)             3.464      0.167 186.213   20.78   <2e-16 ***
## bs(BSTRESS, df = 3)1   -1.536      0.561 186.428   -2.74   0.0068 **
## bs(BSTRESS, df = 3)2   -0.898      0.569 186.628   -1.58   0.1162
## bs(BSTRESS, df = 3)3   -1.706      0.624 186.082   -2.73   0.0069 **
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##                 (Intr) b(BSTRESS,d=3)1 b(BSTRESS,d=3)2
## b(BSTRESS,d=3)1 -0.857
## b(BSTRESS,d=3)2  0.252 -0.630
## b(BSTRESS,d=3)3 -0.478  0.620          -0.738

## compare the linear and B-spline models
AIC(refitML(m3.lmm), refitML(m2.lmm))

##                 df   AIC
## refitML(m3.lmm)  6 14760
## refitML(m2.lmm)  4 14761

接下来，我们将增加一个预测值，工作日与周末。首先，我们通过使用weekdays()函数转换日期来创建新变量。然后我们可以将它添加到模型中。如果我们只是希望添加或删除预测值，我们可以使用update()函数，而不是总是重写模型。

## create the new variable in the dataset
d[, Weekend := factor(as.integer(
      weekdays(SurveyDay) %in% c("Saturday", "Sunday")))]

## update the model adding weekend
m4.lmm <- update(m3.lmm, . ~ . + Weekend)

## screenreg summary
screenreg(m4.lmm)

##
## =====================================
##                          Model 1
## -------------------------------------
## (Intercept)                  3.43 ***
##                             (0.17)
## bs(BSTRESS, df = 3)1        -1.54 **
##                             (0.56)
## bs(BSTRESS, df = 3)2        -0.90
##                             (0.57)
## bs(BSTRESS, df = 3)3        -1.71 **
##                             (0.62)
## Weekend1                     0.10 ***
##                             (0.02)
## -------------------------------------
## AIC                      14745.61
## BIC                      14792.96
## Log Likelihood           -7365.81
## Num. obs.                 6399
## Num. groups: UserID        191
## Var: UserID (Intercept)      0.51
## Var: Residual                0.53
## =====================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

为了呈现结果，特别是考虑到 B 样条的使用，最清楚的方法是生成预测并绘制结果。第一步是获得预测值。这是使用predict()功能完成的。将predict()与 LMMs 一起使用的另一个方面是，可以选择使用或不使用随机效果，使用re.form参数来指定。要获得忽略随机效应的总体平均预测，我们可以将预测的随机效应公式指定为零。

preddat <- as.data.table(expand.grid(
  BSTRESS = seq(
    from = min(d$BSTRESS, na.rm=TRUE),
    to = max(d$BSTRESS, na.rm=TRUE),
    length.out = 1000),
  Weekend = levels(d$Weekend)))

preddat$yhat <- predict(m4.lmm,
  newdata = preddat,
  re.form = ~ 0)

我们可以绘制预测来呈现模型结果，捕捉样条曲线捕捉到的非线性趋势。结果如图 11-15 所示。

img/439480_1_En_11_Fig15_HTML.png

图 11-15

平均压力和工作日与周末模型预测的积极影响图

ggplot(preddat, aes(BSTRESS, yhat, colour = Weekend)) +
  geom_line(size = 1) +
  ylab("Positive Affect") +
  xlab("Average Stress") +
  scale_color_viridis(discrete = TRUE) +
  theme(
    legend.position = c(.75, .8),
    legend.key.width = unit(1, "cm"))

虽然常规 GLMs 的预测可以产生标准误差(以及代理置信区间),但 LMMs 的预测更复杂。目前，根据 LMMs fit by lmer()为预测生成标准误差或置信区间的主要方法是使用自举。为了帮助加速引导，我们将设置一个本地集群来进行并行处理。我们需要加载相关的包并导出用于预测的数据集。

cl <- makeCluster(2)
clusterExport(cl, c("book_directory",
                    "checkpoint_directory",
                    "preddat", "d"))

clusterEvalQ(cl, {
  library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
    project = book_directory,
    checkpointLocation = checkpoint_directory,
    scanForPackages = FALSE,
    scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

  library(data.table)
  library(lme4)
  library(lmerTest)
  library(splines)
})

## [[1]]
##  [1] "splines"       "lmerTest"      "lme4"          "Matrix"
##  [5] "data.table"    "checkpoint"    "RevoUtils"     "stats"
##  [9] "graphics"      "grDevices"     "utils"         "datasets"
## [13] "RevoUtilsMath" "methods"       "base"
##
## [[2]]
##  [1] "splines"       "lmerTest"      "lme4"          "Matrix"
##  [5] "data.table"    "checkpoint"    "RevoUtils"     "stats"
##  [9] "graphics"      "grDevices"     "utils"         "datasets"
## [13] "RevoUtilsMath" "methods"       "base"

genPred <- function(m) {
  predict(m,
    newdata = preddat,
    re.form = ~0)
}

主自举是一个参数模型，它是使用lme4包中的bootMer()函数进行的。最后，我们计算结果的简单百分位数置信区间，并将它们添加回我们的数据集中。

system.time(
  bootres <- bootMer(m4.lmm,
    FUN = genPred,
    nsim = 1000,
    seed = 12345,
    use.u = FALSE,
    type = "parametric",
    parallel = "snow",
    cl = cl)
)

##    user  system elapsed
##    43.3     0.2    43.8

## calculate percentile bootstrap confidence intervals
## and add to the dataset for plotting
preddat$LL <- apply(bootres$t, 2, quantile, probs = .025)
preddat$UL <- apply(bootres$t, 2, quantile, probs = .975)

现在我们有了参数自举置信区间，我们可以重新制作我们的图，这次用阴影区域来表示预测中的不确定性。结果如图 11-16 所示。

img/439480_1_En_11_Fig16_HTML.png

图 11-16

平均压力和工作日与周末模型预测的积极影响图，具有自举置信区间

ggplot(preddat, aes(BSTRESS, yhat, colour = Weekend,
                    fill = Weekend)) +
  geom_ribbon(aes(ymin = LL, ymax = UL),
              alpha = .25, colour = NA) +
  geom_line(size = 1) +
  ylab("Positive Affect") +
  xlab("Average Stress") +
  scale_color_viridis(discrete = TRUE) +
  scale_fill_viridis(discrete = TRUE) +
  theme(
    legend.position = c(.75, .8),
    legend.key.width = unit(1, "cm")) +
  coord_cartesian(xlim = c(0, 8), ylim = c(1, 4),
                  expand = FALSE)

具有随机截距和斜率的线性混合模型

除了随机截距，lmm 还可以有随机斜率。随机斜率捕捉到了人与人之间预测因子和结果之间关联的个体差异。为了估计人与人之间在预测因子和结果关联方面的差异，至少有一些人(理想情况下是所有人)有一个以上的预测因子和结果值是必要的。因此，只有在参与者中变化的变量可以用作随机斜率。

在我们检查一个随机斜率模型之前，我们将会看到当我们添加一个人内预测因子作为固定效应时会发生什么。之前，我们研究了平均压力与积极情绪之间的关系。现在我们将检验人与人之间的压力:与个人平均压力水平的偏差。我们再次依靠update()函数将这个预测值添加到我们之前的 LMM 中。

## update the model adding within person stress
m5.lmm <- update(m4.lmm, . ~ . + WSTRESS)

## screenreg summary
screenreg(m5.lmm)

##
## =====================================
##                          Model 1
## -------------------------------------
## (Intercept)                  3.46 ***
##                             (0.17)
## bs(BSTRESS, df = 3)1        -1.54 **
##                             (0.56)
## bs(BSTRESS, df = 3)2        -0.90
##                             (0.57)
## bs(BSTRESS, df = 3)3        -1.71 **
##                             (0.62)
## Weekend1                     0.01
##                             (0.02)
## WSTRESS                     -0.16 ***
##                             (0.00)
## -------------------------------------
## AIC                      13389.59
## BIC                      13443.70
## Log Likelihood           -6686.80
## Num. obs.                 6399
## Num. groups: UserID        191
## Var: UserID (Intercept)      0.51
## Var: Residual                0.42
## =====================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

结果显示，人与人之间的压力也预示着较低水平的积极情感。同样，我们可以生成预测，并绘制它们，以查看压力内部和之间的关联，以及工作日与周末的积极影响。因为平均应力的内部偏差可能随平均应力的高低而变化，我们将分别计算低平均应力和高平均应力的内部应力范围。因此，我们在相对现实的数据范围内绘图，我们选择两个平均应力值，第 25 和第 75 百分位数。此外，对于应力范围内，我们不是绘制整个范围，而是从第 2 个百分点到第 98 个百分点，在平均应力的底部和顶部四分位数绘制。这抓住了一个事实，如果平均压力非常低，就不可能远低于平均水平，因为参与者报告的压力从 0 到 10。

bstress.low <- round(quantile(d[!duplicated(UserID)]$BSTRESS,
                        probs = .25), 1)
bstress.high <- round(quantile(d[!duplicated(UserID)]$BSTRESS,
                         probs = .75), 1)

preddat.low <- as.data.table(expand.grid(
  BSTRESS = bstress.low,
  WSTRESS = seq(
    from = quantile(d[BSTRESS <= bstress.low]$WSTRESS,
               probs = .02, na.rm = TRUE),
    to = quantile(d[BSTRESS <= bstress.low]$WSTRESS,
               probs = .98, na.rm = TRUE),
    length.out = 1000),
  Weekend = factor("1", levels = levels(d$Weekend))))

preddat.high <- as.data.table(expand.grid(
  BSTRESS = bstress.high,
  WSTRESS = seq(
    from = quantile(d[BSTRESS >= bstress.high]$WSTRESS,
               probs = .02, na.rm = TRUE),
    to = quantile(d[BSTRESS >= bstress.high]$WSTRESS,
               probs = .98, na.rm = TRUE),
    length.out = 1000),
  Weekend = factor("1", levels = levels(d$Weekend))))

preddat <- rbind(
  preddat.low,
  preddat.high)

preddat$yhat <- predict(m5.lmm,
  newdata = preddat,
  re.form = ~ 0)

## convert BSTRESS to factor for plotting
preddat$BSTRESS <- factor(preddat$BSTRESS)

现在我们可以绘制结果，如图 11-17 所示。该图显示，低水平平均应力的内应力扩散小于高水平平均应力的内应力扩散。

img/439480_1_En_11_Fig17_HTML.png

图 11-17

从平均压力和工作日与周末的模型预测的积极影响图。

ggplot(preddat, aes(WSTRESS, yhat, colour = BSTRESS)) +
  geom_line(size = 1) +
  ylab("Positive Affect") +
  xlab("Within Stress") +
  scale_color_viridis(discrete = TRUE) +
  theme(
    legend.position = c(.05, .2),
    legend.key.width = unit(1, "cm"))

如果我们愿意，我们可以绘制包含随机效应的预测线，以显示由于个体差异而可能在人群中发生的预测范围。这需要使用随机截距来生成预测。

bstress.low <- round(quantile(d[!duplicated(UserID)]$BSTRESS,
                        probs = .25), 1)
bstress.high <- round(quantile(d[!duplicated(UserID)]$BSTRESS,
                         probs = .75), 1)

preddat.low <- as.data.table(expand.grid(
  UserID = unique(d$UserID),
  BSTRESS = bstress.low,
  WSTRESS = seq(
    from = quantile(d[BSTRESS <= bstress.low]$WSTRESS,
               probs = .02, na.rm = TRUE),
    to = quantile(d[BSTRESS <= bstress.low]$WSTRESS,
               probs = .98, na.rm = TRUE),
    length.out = 1000),
  Weekend = factor("1", levels = levels(d$Weekend))))

preddat.high <- as.data.table(expand.grid(
  UserID = unique(d$UserID),
  BSTRESS = bstress.high,
  WSTRESS = seq(
    from = quantile(d[BSTRESS >= bstress.high]$WSTRESS,
               probs = .02, na.rm = TRUE),
    to = quantile(d[BSTRESS >= bstress.high]$WSTRESS,
               probs = .98, na.rm = TRUE),
    length.out = 1000),
  Weekend = factor("1", levels = levels(d$Weekend))))

preddat <- rbind(
  preddat.low,
  preddat.high)

preddat$yhat <- predict(m5.lmm,
  newdata = preddat,
  re.form = NULL)

## convert BSTRESS to factor for plotting
preddat$BSTRESS <- factor(preddat$BSTRESS)

现在我们可以绘制结果，如图 11-18 所示。该图显示了个体之间积极情感水平的巨大差异。尽管这些特定的线是基于我们样本的随机效应，但它给出了一种可能发生在人群中的可变性的感觉。

img/439480_1_En_11_Fig18_HTML.png

图 11-18

平均压力和工作日与周末模型预测的积极影响图

ggplot(preddat, aes(WSTRESS, yhat, group = UserID)) +
  geom_line(alpha = .2) +
  ylab("Positive Affect") +
  xlab("Within Stress") +
  facet_wrap(~ BSTRESS, ncol = 2) +
  coord_cartesian(
    xlim = c(-4, 5),
    ylim = c(1, 5),
    expand = FALSE)

接下来，我们研究内应力的随机斜率。我们再次更新之前的模型。然而，这次更新更加复杂，因为随机效果是如何在lmer()中指定的。我们以前的模型都包括随机拦截。通过编写:(WSTRESS | UserID)来尝试添加一个随机斜率似乎是很自然的。然而，与固定效应公式一样，R自动假定应该包括截距。于是(WSTRESS | UserID)扩展为(1 + WSTRESS | UserID)。这是不合适的，因为已经包含了随机截距。另一个显然合乎逻辑的选择是显式排除截距，这与固定效果的工作方式相同:(0 + WSTRESS | UserID)。然而，这种方法会导致随机截距和随机斜率，但这两者会被迫不相关。lmer()仅包括随机效应在同一区块时的相关性。因此，我们真正需要的是(WSTRESS | UserID)，但我们需要移除初始随机截距。下面的代码首先从旧模型中删除随机截距，然后添加一个新的随机效果块，其中包括随机截距和随机斜率。如果我们从头开始编写一个模型，我们可以简单地编写一个随机效果行，但是因为我们正在更新一个现有的模型，我们需要删除旧的随机截距。

m6.lmm <- update(m5.lmm, . ~ . - (1 | UserID) +
  (1 + WSTRESS | UserID))

screenreg(m6.lmm)

##
## =============================================
##                                  Model 1
## ---------------------------------------------
## (Intercept)                          3.45 ***
##                                     (0.16)
## bs(BSTRESS, df = 3)1                -1.59 **
##                                     (0.54)
## bs(BSTRESS, df = 3)2                -0.75
##                                     (0.54)
## bs(BSTRESS, df = 3)3                -1.72 **
##                                     (0.59)
## Weekend1                             0.02
##                                     (0.02)
## WSTRESS                             -0.16 ***
##                                     (0.01)
## ---------------------------------------------
## AIC                              13196.60
## BIC                              13264.23
## Log Likelihood                   -6588.30
## Num. obs.                         6399
## Num. groups: UserID                191
## Var: UserID (Intercept)              0.51
## Var: UserID WSTRESS                  0.01
## Cov: UserID (Intercept) WSTRESS     -0.02
## Var: Residual                        0.40
## =============================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

同样，我们可以做出预测。这一次，我们重点关注随机截距和斜率，以突出个体之间的差异。由于该模型使用了与我们之前的示例相同的变量，我们只需要生成新的预测，然后绘制它们。我们不需要重新创建用于预测的数据。

## convert BSTRESS  from factor  to numeric for prediction
preddat$BSTRESS  <- as.numeric(as.character(
  preddat$BSTRESS))

preddat$yhat2 <- predict(m6.lmm,
  newdata = preddat,
  re.form =  NULL)

##  convert BSTRESS  to factor for plotting
preddat$BSTRESS  <-  factor(preddat$BSTRESS)

现在我们可以绘制结果，如图 11-19 所示。该图显示了个体之间压力和积极情感关联水平的较大变化和斜率的一些变化。

img/439480_1_En_11_Fig19_HTML.png

图 11-19

平均压力和工作日与周末模型预测的积极影响图

ggplot(preddat, aes(WSTRESS, yhat2, group = UserID)) +
  geom_line(alpha = .2) +
  ylab("Positive Affect") +
  xlab("Within Stress") +
  facet_wrap(~ BSTRESS, ncol = 2) +
  coord_cartesian(
    xlim = c(-4, 5),
    ylim = c(1, 5),
    expand = FALSE)

像往常一样，检查诊断是一个好主意。这些如图 11-20 所示。

assumptiontests <- plotDiagnosticsLMER(m6.lmm, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot,
  list(ggplot(d, aes(WSTRESS, PosAff)) +
       stat_smooth()),
  ncol = 2))

## `geom_smooth()` using method = 'gam' and formula 'y␣~␣s(x,␣bs␣=␣"cs")'

图 11-20 中的诊断表明存在一个多变量异常值，但在其他方面，诊断似乎相当合适，尽管人与人之间的压力似乎也存在某种程度的非线性趋势。在继续之前，我们将排除多元异常值。首先，我们查看假设检验中的极值，以确定多元极值的 ID。

img/439480_1_En_11_Fig20_HTML.png

图 11-20

混合效应模型诊断图，显示残差分布(左上)、残差与拟合值以评估方差的均匀性(右上)、随机截距分布(左下)，以及简单的单级广义加性模型(应力内和积极影响之间的关联平滑，以评估非线性(右下)。

assumptiontests$ExtremeValues[
  EffectType == "Multivariate Random Effect UserID"]

##     PosAff UserID                        EffectType
##  1:    4.7    123 Multivariate Random Effect UserID
##  2:    3.9    123 Multivariate Random Effect UserID
##  3:    3.8    123 Multivariate Random Effect UserID
## ---
## 20:    3.7    123 Multivariate Random Effect UserID
## 21:    4.9    123 Multivariate Random Effect UserID
## 22:    4.6    123 Multivariate Random Effect UserID

接下来，我们可以更新我们的模型，这次不改变公式，而是改变数据集。在这种情况下，结果看起来是相似的，尽管 B 样条曲线有些变化。由于我们稍后将比较基于拟合指数的模型，以确定应力内的哪个趋势是最佳的，我们通过设置REML = FALSE从受限的最大似然变为最大似然。

m7.lmm <- update(m6.lmm,
  data = d[UserID != 123],
  REML = FALSE)

screenreg(list(m6.lmm, m7.lmm))

##
## ===========================================================
##                                  Model 1       Model 2
## -----------------------------------------------------------
## (Intercept)                          3.45 ***      3.43 ***
##                                     (0.16)        (0.16)
## bs(BSTRESS, df = 3)1                -1.59 **      -1.50 **
##                                     (0.54)        (0.52)
## bs(BSTRESS, df = 3)2                -0.75         -0.91
##                                     (0.54)        (0.52)
## bs(BSTRESS, df = 3)3                -1.72 **      -1.63 **
##                                     (0.59)        (0.57)
## Weekend1                             0.02          0.02
##                                     (0.02)        (0.02)
## WSTRESS                             -0.16 ***     -0.16 ***
##                                     (0.01)        (0.01)
## -----------------------------------------------------------
## AIC                              13196.60      13083.77
## BIC                              13264.23      13151.38
## Log Likelihood                   -6588.30      -6531.89
## Num. obs.                         6399          6377
## Num. groups: UserID                191           190
## Var: UserID (Intercept)              0.51          0.50
## Var: UserID WSTRESS                  0.01          0.01
## Cov: UserID (Intercept) WSTRESS     -0.02         -0.03
## Var: Residual                        0.40          0.40
## ===========================================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

接下来，我们重新检查诊断图，以评估去除了多变量异常值的模型。这些如图 11-21 所示。

img/439480_1_En_11_Fig21_HTML.png

图 11-21

混合效应模型诊断图，显示残差分布(左上)、残差与拟合值以评估方差的均匀性(右上)、随机截距分布(左下)，以及简单的单级广义加性模型(应力内和积极影响之间的关联平滑，以评估非线性(右下)。

assumptiontests <- plotDiagnosticsLMER(m7.lmm, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot,
  list(ggplot(d[UserID != 123], aes(WSTRESS, PosAff)) +
       stat_smooth()),
  ncol = 2))

## `geom_smooth()` using method = 'gam' and formula 'y␣~␣s(x,␣bs␣=␣"cs")'

更新的诊断对模型来说相对较好，但是内应力的潜在非线性问题仍然存在。探索这一点的一种方法是拟合几种可能的模型，并使用赤池信息标准(AIC)或贝叶斯信息标准(BIC)来选择最佳模型。我们将对比四种模型:(a)线性，(B)二次，(c)弯曲度为 0 的线性分段，以及(d) B 样条。请注意，对于所有趋势，我们包括固定和随机影响。此外，所有模型都是基于去除了多元异常值的随机线性斜率模型。在什么程度上包含或排除一个离群值是有争议的。线性趋势中的多变量异常值可能与其他趋势不一致，这可能是从最终选择的模型中排除的原因。然而，异常值也可以改变哪种类型的模型被选为最佳模型，这就需要在比较模型之前排除异常值。在这种情况下，这就是我们所做的。

m7.lmmb <- update(m7.lmm, . ~ . - (1 + WSTRESS | UserID) +
  WSTRESS + I(WSTRESS²) +
  (1 + WSTRESS + I(WSTRESS²) | UserID))

m7.lmmc <- update(m7.lmm, . ~ . - (1 + WSTRESS | UserID)
  - WSTRESS +
  pmin(WSTRESS, 0) + pmax(WSTRESS, 0) +
  (1 + pmin(WSTRESS, 0) + pmax(WSTRESS, 0) | UserID))

m7.lmmd <- update(update(m7.lmm, . ~ . - WSTRESS), . ~ .
  - (1 + WSTRESS | UserID)  +
  bs(WSTRESS, df = 3) + (1 + bs(WSTRESS, df = 3) | UserID))

一旦所有的模型都拟合好了，我们就可以使用AIC()来比较 AIC。结果表明线性显然是次优的。二次、分段线性和 B 样条的 AIC 彼此更接近。因为呈现和解释两段线性模型比二次或 B 样条要容易得多，所以我们将继续使用分段线性模型。

AIC(
  m7.lmm,
  m7.lmmb,
  m7.lmmc,
  m7.lmmd)

##         df   AIC
## m7.lmm  10 13084
## m7.lmmb 14 13007
## m7.lmmc 14 13014
## m7.lmmd 19 13004

我们将最后一次重新检查诊断图，以确保我们的分段线性模型一切正常。这些如图 11-22 所示。诊断表明，几乎没有证据表明任何假设被违反。

img/439480_1_En_11_Fig22_HTML.png

图 11-22

混合效应模型诊断图，显示残差分布(左上)、残差与拟合值以评估方差的均匀性(右上)、随机效应分布(中间行和左下)以及随机效应的多元正态性检验(右下)。

assumptiontests <- plotDiagnosticsLMER(m7.lmmc, plot = FALSE)
do.call(plot_grid, c(
  assumptiontests[c("ResPlot", "ResFittedPlot")],
  assumptiontests$RanefPlot,
  ncol = 2))

接下来，我们将检查具有效应大小的模型的概要，包括每个预测值的边际和条件R2 和科恩的f2 值。这可以通过使用JWileymisc包中的detailedTests()函数来完成。不幸的是，当包含 B 样条时，从模型中提取的模型框架并不完全正确，这对于应力的平均影响仍然存在。

为了在撰写本文时解决这个问题(在您阅读本文时，JWileymisc将被更新，因此不再需要它)，我们做了一些修改，重新定义了内置的model.frame()函数。在我们将结果保存在对象test.m7.lmmc中之后，我们删除了所有多余的函数和副本，这样我们的攻击就不会影响其他函数或R的正常使用。

## hack
model.frame <- function(obj) {
  d[UserID != 123][
    !is.na(PosAff) & !is.na(BSTRESS) &
    !is.na(WSTRESS) & !is.na(Weekend)]
}
detailedTests <- detailedTests
environment(detailedTests) <- environment()
.detailedTestsLMER <- .detailedTestsLMER
environment(.detailedTestsLMER) <- environment()

## calculate the detailed tests
test.m7.lmmc <- detailedTests(m7.lmmc,
  method = "Wald")

## remove our hack
rm(model.frame, detailedTests,
   .detailedTestsLMER)

现在我们可以使用formatLMER()函数得到所有的测试，并得到一组格式良好的结果。请注意，这可能需要几秒钟，即使使用最简单的 Wald 方法来确定置信区间。最终结果如表 11-4 所示。在效果大小下，每个变量有两个，第一个是边际科恩的f2，第二个在斜线之后，是条件科恩的f2，这取决于计算是基于边际还是条件R2 值。

表 11-4

最终随机截距和斜率模型用 B 样条表示平均压力，线性分段模型表示人内压力

|   |

学期

|

模型 1

|
| --- | --- | --- |
| one | 固定效果 |   |
| Two | (截取) | 3.35* * 【3.03，3.66】 |
| three | 周末 1 | 0.02 [–0.01, 0.06] |
| four | bs(b 应力，df = 3)1 | –1.47* [–2.48, –0.46] |
| five | bs(b 应力，df = 3)2 | –0.75 [–1.74, 0.23] |
| six | bs(b 应力，df = 3)3 | –1.53** [–2.65, –0.40] |
| seven | pmax(w 应力，0) | –0.14*** [–0.16, –0.12] |
| eight | pmin(w 应力，0) | –0.19*** [–0.22, –0.16] |
| nine | 随机效应 |   |
| Ten | cor_pmax(WSTRESS，0)。(截取)|用户标识 | –0.83 |
| Eleven | cor_pmax(WSTRESS，0)。pmin(WSTRESS，0)|UserID | Zero point zero two |
| Twelve | cor_pmin(WSTRESS，0)。(截取)|用户标识 | Zero point one seven |
| Thirteen | sd_(截距)|用户标识 | Zero point seven six |
| Fourteen | sd_pmax(WSTRESS，0)|UserID | Zero point zero seven |
| Fifteen | SD _ pmin(wsstress，0)|UserID | Zero point one six |
| Sixteen | 希腊字母表中第十八个字母 | Zero point six two |
| Seventeen | 整体模型 |   |
| Eighteen | DF 型 | Fourteen |
| Nineteen | n(用户 ID) | One hundred and ninety |
| Twenty | n(观察值) | Six thousand three hundred and seventy-seven |
| Twenty-one | 洛格里克 | –6492.77 |
| Twenty-two | 美国化学师学会(American Institute of Chemists) | Thirteen thousand and thirteen point five three |
| Twenty-three | 比克 | Thirteen thousand one hundred and eight point one eight |
| Twenty-four | 边缘 R2 | Zero point one eight |
| Twenty-five | 有条件的 R2 | Zero point six five |
| Twenty-six | 效果尺寸 |   |
| Twenty-seven | bs(b 应力，df = 3)(固定) | 0.11/–0.03，p < .001 |
| Twenty-eight | 周末(固定) | 0.00/ 0.00，p = .191 |
| Twenty-nine | pmin(WSTRESS，0)(固定+随机) | –0.01/0.06，p < .001 |
| Thirty | pmin(WSTRESS，0)(随机) | –0.01/0.03，p < .001 |
| Thirty-one | pmax(WSTRESS，0)(固定+随机) | 0.00/ 0.03，p < .001 |
| Thirty-two | pmax(WSTRESS，0)(随机) | –0.03/–0.02，p < .001 |

effecttable <- formatLMER(list(test.m7.lmmc))

xtable(effecttable,
  caption = paste("Final random intercept and slope model",
    "with a B-spline for average stress and linear piecewise",
    "model for within person stress."),
  label = "tglmml-effecttable")

还要注意，可以用不同的方式格式化结果。使用sprintf()函数写出系数、p 值、置信区间和效应大小，我们可以在它们周围指定不同的标签或格式。以下示例打印了固定效应系数的实际 p 值而不是星号，使用圆括号而不是方括号表示置信区间，并为所有效应添加了一些标签。结果如表 11-5 所示。

表 11-5

最终随机截距和斜率模型的不同格式

|   |

学期

|

模型 1

|
| --- | --- | --- |
| one | 固定效果 |   |
| Two | (截取) | b = 3.35，p < .001，CI =(3.03；3.66) |
| three | 周末 1 | b = 0.02，p = .191，CI =(–0.01；0.06) |
| four | bs(b 应力，df = 3)1 | b =–1.47，p = .005，CI =(–2.48；–0.46) |
| five | bs(b 应力，df = 3)2 | b =–0.75，p = .136，CI =(–1.74；0.23) |
| six | bs(b 应力，df = 3)3 | b =–1.53，p = .009，CI =(–2.65；–0.40) |
| seven | pmax(w 应力，0) | b =–0.14，p < .001，CI =(–0.16；–0.12) |
| eight | pmin(w 应力，0) | b =–0.19，p < .001，CI =(–0.22；–0.16) |
| nine | 随机效应 |   |
| Ten | cor_pmax(WSTRESS，0)。(截取)|用户标识 | –0.83 |
| Eleven | cor_pmax(WSTRESS，0)。pmin(WSTRESS，0)|UserID | Zero point zero two |
| Twelve | cor_pmin(WSTRESS，0)。(截取)|用户标识 | Zero point one seven |
| Thirteen | sd_(截距)|用户标识 | Zero point seven six |
| Fourteen | sd_pmax(WSTRESS，0)|UserID | Zero point zero seven |
| Fifteen | SD _ pmin(wsstress，0)|UserID | Zero point one six |
| Sixteen | 希腊字母表中第十八个字母 | Zero point six two |
| Seventeen | 整体模型 |   |
| Eighteen | DF 型 | Fourteen |
| Nineteen | n(用户 ID) | One hundred and ninety |
| Twenty | n(观察值) | Six thousand three hundred and seventy-seven |
| Twenty-one | 洛格里克 | –6492.77 |
| Twenty-two | 美国化学师学会(American Institute of Chemists) | Thirteen thousand and thirteen point five three |
| Twenty-three | 比克 | Thirteen thousand one hundred and eight point one eight |
| Twenty-four | 边缘 R2 | Zero point one eight |
| Twenty-five | 有条件的 R2 | Zero point six five |
| Twenty-six | 效果尺寸 |   |
| Twenty-seven | bs(b 应力，df = 3)(固定) | 毛利 f2 = 0.11：伯爵 F2 =–0.03，p < .001 |
| Twenty-eight | 周末(固定) | 毛利 f2 = 0.00：控制器 f2 = 0.00，p = 191 |
| Twenty-nine | pmin(WSTRESS，0)(固定+随机) | 毛利 F2 =–0.01；控制器 f2 = 0.06，p < .001 |
| Thirty | pmin(WSTRESS，0)(随机) | 毛利 F2 =–0.01；控制器 f2 = 0.03，p < .001 |
| Thirty-one | pmax(WSTRESS，0)(固定+随机) | 毛利 f2 = 0.00：控制器 f2 = 0.03，p < .001 |
| Thirty-two | pmax(WSTRESS，0)(随机) | 毛利 F2 =–0.03；伯爵 F2 =–0.02，p < .001 |

xtable(
formatLMER(
  list(test.m7.lmmc),
  format = list(
    FixedEffects = c("b = %s, %s, CI = (%s; %s)"),
    RandomEffects = c("%s", "%s (%s; %s)"),
    EffectSizes = c("Marg f2 = %s; Cond f2 = %s, %s")),
  pcontrol = list(
    digits = 3,
    stars = FALSE,
    includeP = TRUE,
    includeSign = TRUE,
    dropLeadingZero = TRUE)),
  caption = paste("Different formatting for the final",
    "random intercept and slope model."),
  label = "tglmml-effecttablealt")

11.3 摘要

本章介绍了线性混合模型，作为广义线性混合模型的一个特例。GLMMs 的一个独特特征是，除了大多数统计模型中通常存在的固定效应之外，还引入了随机效应。随机效应允许变量的关联在不同的个体之间不同，或者无论更高的分组变量是什么(例如，人、学校、医院等)。).随机效应为非独立评估问题提供了一个优雅的解决方案，无需对每个人的数据进行建模。本章还介绍了如何确定效应大小和从 GLMMs 生成预测的挑战，特别展示了如何使用自举来准确捕捉预测中的不确定性。表 11-6 中显示了本章中使用的功能总结以及每个功能的简要描述。

表 11-6

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| aes() | 控制哪些变量影响哪些美感(例如，x/y 轴和颜色)。 |
| AIC() | 赤池信息准则。 |
| apply() | 获取给定的函数，并将其应用于指定的变量。 |
| bootMer() | 从lmer()模型中抽取样本，以生成系数或预测的置信区间。 |
| cat() | 连接并打印输入的字符串。 |
| clusterEvalQ() | 来自parallel的函数，它将给定的环境复制到每个集群实例。 |
| clusterExport() | 从全局环境中导出值，供每个集群环境使用。 |
| confint() | 置信区间生成函数。 |
| coord_cartesian() | 以笛卡尔的方式在图上设置界限。 |
| data() | 将数据放入内存(本例中来自JWileymisc包)。 |
| detailedTests() | 计算lmer()类型模型的置信区间、整体模型效应大小和单个系数的效应大小。 |
| element_blank() | 确保不绘制ggplot的元素。 |
| facet_wrap() | 为命名的每个方面(或因素)创建总体图形的副本(例如，个体与随机)。 |
| factor() | 将数据元素的特定集合指定为因子。 |
| fitted() | 类似于predict()，除了用来建立模型的原始数据是输入。在这两种情况下，都会返回模型输出 yhat 值。 |
| fixef() | 提取固定效果，以模型作为参数。 |
| formatLMER() | 格式化模型输出并确保一致性、对齐和标准格式。 |
| geom_line() | 画一条线。 |
| geom_ribbon() | 在 y 值的任一侧绘制阴影区域(例如，用于置信区间)。 |
| geom_segment() | 在给定点之间绘制线段，这对离散数据很有用。 |
| geom_vline() | 画一条垂直线。 |
| ggplot() | 图形绘图对象的语法(相对于 base R 图形)。 |
| iccMixed() | 在幕后使用混合效应模型计算变量的组内相关系数。需要变量的名称、聚类分析或 ID 变量的名称以及数据集作为参数。 |
| image() | 基本graphics功能显示方块。 |
| is.na() | 返回表示 NA 元素的布尔值。 |
| lm() | 符合线性模型。 |
| lmer() | 估计线性混合效应模型。 |
| makeCluster() | 创建并行计算集群。 |
| melt() | 获取宽数据并将其分解为长数据。 |
| offset() | 将模型中的系数固定为特定值(而不是允许模型通过算法计算系数)。 |
| plotDiagnosticsLMER() | 为lmer()级模型制作各种诊断图。 |
| predict() | 类似于fitted()，除了需要一个数据参数。在这两种情况下，都会返回模型输出 yhat 值。 |
| print() | 将指定的字符串打印到控制台。 |
| R2LMER() | 从线性混合模型中计算边际和条件R??【2】??。 |
| rbind() | 按行将数据绑定在一起。 |
| ranef() | 从拟合的lmer()模型对象中提取随机效果。 |
| refitML() | 模型改装功能取代了默认的受限最大似然法。 |
| round() | 将值舍入到指定的小数位数。 |
| scale_color_viridis() | 使用viridis颜色包在标尺上提供颜色。 |
| sprintf() | 打印给定格式的字符。 |
| stat_smooth() | 平滑图表以避免绘制过度。 |
| update() | 更新并重新拟合模型。 |
| VarCorr() | 从lmer()类模型中提取随机效应方差和协方差或标准差和相关性。将拟合的模型作为其参数。 |**

十二、GLMMs：高级

关于广义线性混合模型(GLMMs)的这一章建立在使用 GLMMs 简介一章和 GLMMs 线性一章中的多级数据的基础上，这两章严格关注连续的正态分布结果。本章重点介绍其他类型结果的 GLMMs，特别是二元结果和计数结果。

我们确实使用了optimx包【70】和dfoptim包【97】。虽然不能直接使用(它们是依赖关系)，但确实需要安装。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(viridis)
library(JWileymisc)
library(data.table)
library(lme4)
library(lmerTest)
library(chron)
library(zoo)
library(pander)
library(texreg)
library(xtable)
library(splines)
library(parallel)
library(boot)
library(optimx)
library(dfoptim)

options(width = 70, digits = 2)

12.1 概念背景

本章没有介绍任何实质性的新概念内容。更确切地说，它是前几章内容的综合。如果你还没有读过，相关章节是前两章:GLMMs 简介和 GLMMs 线性。这两章一起提供了混合效果或多级模型的一些独特方面的覆盖范围。另一个需要的方面是熟悉不同的发行系列和链接功能。这些概念在前面的章节中已经介绍过了，特别是 GLM 协议 1 和 GLM 协议 2。在这两章中，我们探讨了如何将线性回归模型扩展到逻辑回归和泊松回归模型，以分析二元和计数结果数据。在这一章中，我们将检查相同的扩展，但是我们不是扩展线性回归，而是扩展包含固定和随机效应的线性混合模型。然而，在实践中，概念上几乎没有区别。如果你理解混合效应模型，你理解逻辑回归和泊松回归，你会发现同样的想法和概念贯穿本章。

12.2 物流 GLMM

随机截距

我们将考察的第一组模型是随机截距逻辑回归模型。首先，我们加载数据，包括原始数据和在 GLMMs 简介章节中处理过的数据。

data(aces_daily)
draw <- as.data.table(aces_daily)
d <- readRDS("aces_daily_sim_processed.RDS")

从技术上讲，我们一直使用的数据集中没有二元结果。然而，我们可以通过对连续结果进行分类来创建二元结果。每天，参与者报告他们入睡需要多少分钟。通常超过 30 分钟才能入睡被认为是临床上有意义的时间长度。

d[, SOLs30 := as.integer(SOLs >= 30)]

GLMMs 的设置与我们在 GLMMs 线性章节中运行的线性混合模型非常相似。主要区别是使用了glmer()函数来代替lmer()函数，并且需要指定分布和可选的链接函数。对于二元结果，我们使用带有 logit 链接函数的二项分布，如 GLM 新协议第二章所述。我们还增加了两个预测指标:睡眠开始后醒来的平均次数和解脱应对的平均使用。除了正常结果之外，GLMMs 的另一个挑战是没有封闭解，而是必须通过数值积分来近似求解。R默认为所谓的拉普拉斯近似，一个积分点，但使用额外的积分点可以提高精度。我们通过设置nAGQ = 9使用 9 个点。

m1.glmm <- glmer(SOLs30 ~ BCOPEDis + BWASONs + (1 | UserID),
                 family = binomial(link = logit),
                 data = d, nAGQ = 9)
summary(m1.glmm)

## Generalized linear mixed model fit by maximum likelihood (Adaptive
##   Gauss-Hermite Quadrature, nAGQ = 9) [glmerMod]
##  Family: binomial  ( logit )
## Formula: SOLs30 ~ BCOPEDis + BWASONs + (1 | UserID)
##    Data: d
##
##      AIC      BIC   logLik deviance df.resid
##     1969     1991     -980     1961     2093
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -2.558 -0.453 -0.226  0.346  3.343
##
## Random effects:
##  Groups Name        Variance Std.Dev.
##  UserID (Intercept) 3.55     1.88
## Number of obs: 2097, groups:  UserID, 191
##
## Fixed effects:
##             Estimate Std. Error z value Pr(>|z|)
## (Intercept)   -3.606      0.684   -5.27  1.4e-07 ***
## BCOPEDis       0.777      0.295    2.63   0.0085 **
## BWASONs        0.520      0.228    2.29   0.0223 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##          (Intr) BCOPED
## BCOPEDis -0.918
## BWASONs  -0.410  0.101

观察结果，我们可以说，睡眠开始后平均不使用解脱应对和平均不醒来的人花费 30 分钟或更多时间入睡的概率为-3.6。我们可以使用反向链接函数$$ \frac{1}{1+{e}^{-\mu }} $$，将此转化为概率。在R中，我们可以使用plogis()函数来完成。

plogis(fixef(m1.glmm)[["(Intercept)"]])

## [1] 0.026

检查单个系数，我们看到，人们每使用更高的平均脱离应对单位，他们预计会有 0.8 更高的长睡眠开始潜伏期(30 分钟或更长)的对数几率。同样，人们平均每多醒来一次，长时间睡眠潜伏期的对数几率就会增加 0.5 倍。更简单地说，研究结果表明，更多地使用解脱应对方式和更多地在睡眠开始后醒来，预示着花 30 分钟或更长时间入睡的可能性更高。

另一种解释固定效应的方法是将它们转换成优势比。固定效应的优势比可以通过对其取指数来计算，类似于常规的逻辑回归。下面的代码为固定效果和固定效果的置信区间执行此操作，它们是使用fixef()函数和confint()函数的parm = "beta_"参数选择的，因此只返回固定效果的置信区间，而不是随机效果的置信区间。使用cbind()将这些组合起来，然后对整个结果进行指数运算，给出所有比值比范围内的估计值和置信区间。

exp(cbind(
  B = fixef(m1.glmm),
  confint(m1.glmm, parm = "beta_", method = "Wald")))

##                 B  2.5 % 97.5 %
## (Intercept) 0.027 0.0071    0.1
## BCOPEDis    2.176 1.2199    3.9
## BWASONs     1.682 1.0768    2.6

检查比值比，我们可以说，人们使用的每一个额外的单位更高的平均脱离应对，他们预计有 2.2 倍的长睡眠开始潜伏期的几率。同样，人们平均每多醒来一次，就会有 1.7 倍的长时间睡眠潜伏期。

为了进一步帮助解释，我们可以生成预测概率。然而，由于随机效应，从 GLMM 中生成预测概率比从常规逻辑回归中生成要复杂得多。尽管随机截距在 logit 标度上总是平均为零，但在概率标度上不会平均为零。

首先，我们使用平均随机效应生成预测(本质上是将它们设置为零)。

preddat <- as.data.table(expand.grid(
  BCOPEDis = seq(
    from = min(d$BCOPEDis, na.rm=TRUE),
    to = max(d$BCOPEDis, na.rm = TRUE),
    length.out = 1000),
  BWASONs = quantile(d$BWASONs, probs = c(.2, .8),
                     na.rm = TRUE)))

## predictions based on average random effects
preddat$yhat <- predict(m1.glmm,
  newdata = preddat,
  type = "response",
  re.form = ~ 0)

接下来，我们为样本中的每个人生成预测。

preddat2 <- as.data.table(expand.grid(
  UserID = unique(d$UserID),
  BCOPEDis = seq(
    from = min(d$BCOPEDis, na.rm=TRUE),
    to = max(d$BCOPEDis, na.rm = TRUE),
    length.out = 1000),
  BWASONs = quantile(d$BWASONs, probs = c(.2, .8),
                     na.rm = TRUE)))

## predictions based on average random effects
preddat2$yhat <- predict(m1.glmm,
  newdata = preddat2,
  type = "response",
  re.form = NULL)

现在我们将人们的预测概率平均化。也就是说，这是在生成预测概率之后进行平均，而不是在生成预测概率之前进行平均。

## calculate predicted probabilities
## averaging across participants
preddat3 <- preddat2[, .(yhat = mean(yhat)),
         by = .(BCOPEDis, BWASONs)]

现在我们可以绘制各种结果，如图 12-1 所示。这些图突出显示了在概率尺度上对随机效应进行平均与在 logit 尺度上对随机效应进行平均并生成一组预测概率时，预测概率的差异有多大。一般来说，为每个参与者生成多个预测概率并对其进行平均比对用于生成预测的值进行平均更合适，尽管这需要花费更多的精力来生成。

img/439480_1_En_12_Fig1_HTML.png

图 12-1

将随机效应设置为零(在 logit 标度上平均)并对所有随机效应进行平均的预测概率图

ggplot(rbind(
  cbind(preddat, Type = "Zero"),
  cbind(preddat3, Type = "Average")),
  aes(BCOPEDis, yhat, colour = Type)) +
  geom_line(size = 1) +
  scale_color_viridis(discrete = TRUE) +
  facet_wrap(~ round(BWASONs, 1)) +
  theme(
    legend.key.width = unit(1, "cm"),
    legend.position = c(.1, .9)) +
  xlab("Average disengagement coping") +
  ylab("Probability of sleep onset latency 30+ min") +
  coord_cartesian(
    xlim = c(1, 4),
    ylim = c(0, .6),
    expand = FALSE)

我们还可以通过绘制单个预测概率来了解随机截距对概率标度的影响。这些结果如图 12-2 所示。

img/439480_1_En_12_Fig2_HTML.png

图 12-2

脱离应对水平和平均觉醒次数的个人预测概率图

ggplot(preddat2,
  aes(BCOPEDis, yhat, group = UserID)) +
  geom_line(alpha = .2) +
  facet_wrap(~ round(BWASONs, 1))+
  xlab("Average disengagement coping") +
  ylab("Probability of sleep onset latency 30+ min") +
  coord_cartesian(
    xlim = c(1, 4),
    ylim = c(0, 1),
    expand = FALSE)

随机截距和斜率

正如线性混合模型一样，GLMMs 可以同时具有随机截距和随机斜率。随机斜率可以捕捉个人内部预测因素与事件发生概率之间的个体差异，这里需要 30 分钟或更长时间才能入睡。在这里，我们研究了一个预测入睡时间的平均和个人积极情绪的模型，包括个人积极情绪的随机截距和随机斜率。

m2.glmm <- glmer(SOLs30 ~ BPosAff + WPosAff +
  (1 + WPosAff | UserID),
  family = binomial(link = logit),
  data = d, nAGQ = 1)

summary(m2.glmm)

## Generalized linear mixed model fit by maximum likelihood (Laplace
##   Approximation) [glmerMod]
##  Family: binomial  ( logit )
## Formula: SOLs30 ~ BPosAff + WPosAff + (1 + WPosAff | UserID)
##    Data: d
##
##      AIC      BIC   logLik deviance df.resid
##     1813     1846     -900     1801     1894
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -2.334 -0.451 -0.242  0.341  3.415
##
## Random effects:
##  Groups Name        Variance Std.Dev. Corr
##  UserID (Intercept) 3.7615   1.94
##         WPosAff     0.0897   0.30     1.00
## Number of obs: 1900, groups:  UserID, 191
##
## Fixed effects:

##             Estimate Std. Error z value Pr(>|z|)
## (Intercept)   -1.877      0.561   -3.34  0.00082 ***
## BPosAff        0.117      0.198    0.59  0.55573
## WPosAff       -0.337      0.123   -2.73  0.00627 **
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##         (Intr) BPsAff
## BPosAff -0.952
## WPosAff  0.092 -0.001

这些结果表明，当积极情绪比个人的平均积极情绪高一个单位时，他们当晚花很长时间才能入睡的对数几率预计会低-0.34。请注意，这并不是简单地说快乐的人更快入睡，因为个人变量是对个人均值的偏离。这些结果表明，当人们相对于平时的感觉更快乐时，他们不太可能花很长时间才能入睡。

和以前一样，我们可以很容易地计算出优势比。这些研究表明，对于每单位高于平均水平的晚间积极情绪，参与者花 30 分钟或更多时间入睡的几率约为 0.71 倍。

exp(cbind(
  B = fixef(m2.glmm),
  confint(m2.glmm, parm = "beta_", method = "Wald")))

##                B 2.5 % 97.5 %
## (Intercept) 0.15 0.051   0.46
## BPosAff     1.12 0.762   1.66
## WPosAff     0.71 0.560   0.91

将个人积极情感的影响转换为概率需要考虑其他预测因素以及随机截距和斜率，并对两者进行平均。由于积极情感的平均水平不同，人与人之间的积极情感可能有不同的范围，所以我们分别计算这些范围。

bpa.low <- quantile(d$BPosAff, probs = .2, na.rm=TRUE)
bpa.high <- quantile(d$BPosAff, probs = .8, na.rm=TRUE)

preddat4.low <- as.data.table(expand.grid(
  UserID = unique(d$UserID),
  WPosAff = seq(
    from = min(d[BPosAff <= bpa.low]$WPosAff,
               na.rm = TRUE),
    to = max(d[BPosAff <= bpa.low]$WPosAff,
             na.rm = TRUE),
    length.out = 1000),
  BPosAff = bpa.low))

preddat4.high <- as.data.table(expand.grid(
  UserID = unique(d$UserID),
  WPosAff = seq(
    from = min(d[BPosAff >= bpa.high]$WPosAff,
               na.rm = TRUE),
    to = max(d[BPosAff >= bpa.high]$WPosAff,
             na.rm = TRUE),
    length.out = 1000),
  BPosAff = bpa.high))

preddat4 <- rbind(
  preddat4.low,
  preddat4.high)

## predictions including random effects
preddat4$yhat <- predict(m2.glmm,
  newdata = preddat4,
  type = "response",
  re.form = NULL)

## calculate predicted probabilities
## averaging across participants
preddat4b <- preddat4[, .(yhat = mean(yhat)),
         by = .(WPosAff, BPosAff)]

现在，我们可以绘制各种结果，如图 12-3 所示，这表明，与具有“高”平均积极情感(第 80 百分位)的人相比，具有“低”平均积极情感(第 20 百分位)的人的内部变化范围确实非常不同。

img/439480_1_En_12_Fig3_HTML.png

图 12-3

考虑到随机截距和个人内积极影响的斜率，预测概率在个体间平均的图表

ggplot(preddat4b,
  aes(WPosAff, yhat, colour = factor(round(BPosAff, 1)))) +
  geom_line(size = 1) +
  scale_color_viridis("Average\nPositive Affect",
                      discrete = TRUE) +
  theme(

    legend.key.width = unit(1.5, "cm"),
    legend.position = c(.7, .9)) +
  coord_cartesian(
    xlim = c(-4, 4),
    ylim = c(0, .45),
    expand = FALSE) +
  xlab(paste0("Within person positive affect\n",
              "(deviations from own mean)")) +
  ylab("Probability of sleep onset latency 30+ min")

12.3 泊松和负二项式广义矩估计

随机截距

对于计数结果，通常假设泊松或负二项式分布，因为正态分布通常不能很好地表示计数数据。我们在《GLM 新协议》第二章中引入了泊松模型，用于仅固定效应(单水平)模型。本节通过允许随机截取扩展了这一点。泊松分布的一个特征是方差预期等于均值。如果可变性大于平均值，则存在过度分散。虽然这通常是泊松模型的一个问题，但在混合效应泊松模型中可能不太受关注，因为对于每个人的随机截距，模型更有可能适应每个人，并且方差等于均值的假设可能更成立。

在R中运行具有随机截距的泊松 GLMM 可以使用glmer()函数来完成，并使用参数family = poisson(link = log)来指定分布和链接函数。除此之外，该模型在结构上与其他 GLMMs 相同。在这项分析中，我们将使用夜间醒来的次数作为结果变量，年龄(岁)和参与者是否出生在澳大利亚(编码 1)或不出生在澳大利亚(编码 0)作为两个预测变量。

m3.glmm <- glmer(WASONs ~ Age + BornAUS +
  (1 | UserID),
  family = poisson(link = log),
  data = d, nAGQ = 9)

summary(m3.glmm)

## Generalized linear mixed model fit by maximum likelihood (Adaptive
##   Gauss-Hermite Quadrature, nAGQ = 9) [glmerMod]
##  Family: poisson  ( log )
## Formula: WASONs ~ Age + BornAUS + (1 | UserID)
##    Data: d
##
##      AIC      BIC   logLik deviance df.resid
##     2070     2092    -1031     2062     1910
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -1.763 -0.673 -0.360  0.477  3.983
##
## Random effects:
##  Groups Name        Variance Std.Dev.
##  UserID (Intercept) 0.52     0.721
## Number of obs: 1914, groups:  UserID, 190
##
## Fixed effects:
##             Estimate Std. Error z value Pr(>|z|)
## (Intercept)  -1.7574     0.5810   -3.02  0.00249 **
## Age           0.0588     0.0266    2.21  0.02681 *
## BornAUS       0.4250     0.1243    3.42  0.00063 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##         (Intr) Age
## Age     -0.991
## BornAUS -0.061 -0.019

因为泊松 GLMMs 使用对数链接，所以结果是对数标度的。检查个别系数，我们可以解释如下。截距表明，一个不是在澳大利亚出生的零岁儿童每晚醒来的次数预计为-1.8 次。随着年龄的增长，他们每晚醒来的次数会增加 0.1 次。最后，与出生在澳大利亚以外的人相比，出生在澳大利亚的人预期会有 0.4 个更高的对数觉醒。

与逻辑 GLMMs 一样，我们可以使用反向链接函数，在本例中简称为exp()，以使结果更容易理解。转换截距，我们可以说，一个不是在澳大利亚出生的零岁儿童预计每晚醒来 0.2 次。

我们还可以对系数取幂，得到基线计数的乘数。这导致了这样一种解释:随着年龄的增长，人们每晚醒来的次数会增加 1.1 倍。与出生在澳大利亚以外的人相比，出生在澳大利亚的人预计会有 1.5 倍的觉醒。当泊松系数被指数化时，它们被称为事故率比率(IRRs)。IRRs 提供了一个相对标准，即一个组的发病率比另一个组高多少倍，或者当连续预测因子改变时，发病率高多少倍。

为了得到 IRR 和置信区间，我们采用了与得到逻辑 glm 的 ORs 相同的方法。首先，我们提取系数和置信区间，然后对最终结果求幂，将它们放在 IRR 标度上，而不是对数标度上。

exp(cbind(
  B = fixef(m3.glmm),
  confint(m3.glmm, parm = "beta_", method = "Wald")))

##                B 2.5 % 97.5 %
## (Intercept) 0.17 0.055   0.54
## Age         1.06 1.007   1.12
## BornAUS     1.53 1.199   1.95

为了查看绝对效果，我们为样本中的每个人生成预测，并对结果进行平均。

preddat5 <- as.data.table(expand.grid(
  UserID = unique(d[!is.na(BornAUS) & !is.na(Age)]$UserID),
  Age = seq(
    from = min(d$Age, na.rm=TRUE),
    to = max(d$Age, na.rm = TRUE),
    length.out = 1000),
  BornAUS = 0:1))

## predictions based on average random effects
preddat5$yhat <- predict(m3.glmm,
  newdata = preddat5,
  type = "response",
  re.form = NULL)

## calculate predicted counts
## averaging across participants
preddat5 <- preddat5[, .(yhat = mean(yhat)),
         by = .(Age, BornAUS)]

我们还可以通过绘制单个预测概率来了解随机截距对概率标度的影响。这些结果如图 12-4 所示。

ggplot(preddat5,
  aes(Age, yhat, colour = factor(BornAUS))) +
  geom_line(size = 2) +
  scale_colour_viridis("Born in Australia", discrete = TRUE) +
  xlab("Age (years)") +
  ylab("Predicted # wakenings after sleep onset") +
  theme(
    legend.key.width = unit(1.5, "cm"),
    legend.position = c(.1, .9)) +
  coord_cartesian(
    xlim = c(18, 26.5),
    ylim = c(0, 2),
    expand = FALSE)

如果担心过度分散，计数结果的替代方法是使用负二项式模型。对这一点的支持正在添加到lme4包中，这样的模型可以使用glmer.nb()功能来适应。请注意，这些模型比拟合泊松模型慢得多。接下来，我们将泊松随机截距模型改装为负二项模型。

img/439480_1_En_12_Fig4_HTML.png

图 12-4

按年龄和是否在澳大利亚出生划分的睡眠开始后醒来的平均预测次数图

m3.glmm.nb <- glmer.nb(formula(m3.glmm),
  data = d)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00224463 (tol = 0.001, component 1)

## Warning in theta.ml(Y, mu, weights = object@resp$weights, limit = limit, : iteration limit reached

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00115603 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00162663 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00194197 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00147706 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.0016048 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.0014179 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00177251 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.0012395 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00139838 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00142382 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00144676 (tol = 0.001, component 1)

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00138734 (tol = 0.001, component 1)

负二项式 GLMM 生成关于收敛失败的警告。为了研究这些收敛警告，我们可以尝试使用不同的优化器来拟合模型，看看不同的优化器是否收敛到相同的结果。lme4包没有直接包含这个函数，但是它附带了一个R脚本，可以加载这个脚本来提供一个函数。注意，这也需要加载一些额外的R包来提供额外的优化器。一旦我们从lme4包中获得了代码，我们就可以使用allFit()函数来使用不同的优化器来适应我们的模型。

## load R code shipped with lme4 to provide the allFit()
source(system.file("utils", "allFit.R", package="lme4"))
m3.all <- allFit(m3.glmm.nb)

## bobyqa :

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00130544 (tol = 0.001, component 1)

## [OK]
## Nelder_Mead :

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00199142 (tol = 0.001, component 1)

## [OK]
## nlminbw : [OK]
## nmkbw :

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00894524 (tol = 0.001, component 1)

## [OK]
## optimx.L-BFGS-B :

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.361426 (tol = 0.001, component 1)

## [OK]
## nloptwrap.NLOPT_LN_NELDERMEAD :

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00541331 (tol = 0.001, component 1)

## [OK]
## nloptwrap.NLOPT_LN_BOBYQA :

## Warning in checkConv(attr(opt, "derivs"), opt$par, ctrl = control$checkConv, : Model failed to converge with max|grad| = 0.00541331 (tol = 0.001, component 1)

## [OK]

我们再次得到收敛失败的警告，尽管在许多情况下，我们可以看到绝对梯度接近默认容差 0.001。接下来，我们可以对所有拟合进行总结，并查看固定效应、对数似然和θ的结果，θ在该模型中是随机截距方差。

m3.all.sum <- summary(m3.all)

m3.all.sum$fixef

##                               (Intercept)   Age BornAUS
## bobyqa                               -1.8 0.059    0.42
## Nelder_Mead                          -1.8 0.059    0.42
## nlminbw                              -1.8 0.059    0.42
## nmkbw                                -1.8 0.059    0.42
## optimx.L-BFGS-B                      -1.7 0.055    0.42
## nloptwrap.NLOPT_LN_NELDERMEAD        -1.8 0.059    0.42
## nloptwrap.NLOPT_LN_BOBYQA            -1.8 0.059    0.42

m3.all.sum$llik

##                        bobyqa                   Nelder_Mead
##                         -2270                         -2270
##                       nlminbw                         nmkbw
##                         -2270                         -2270
##               optimx.L-BFGS-B nloptwrap.NLOPT_LN_NELDERMEAD
##                         -2270                         -2270
##     nloptwrap.NLOPT_LN_BOBYQA
##                         -2270

m3.all.sum$theta

##                               UserID.(Intercept)
## bobyqa                                      0.72
## Nelder_Mead                                 0.72
## nlminbw                                     0.72
## nmkbw                                       0.72
## optimx.L-BFGS-B                             0.72
## nloptwrap.NLOPT_LN_NELDERMEAD               0.72
## nloptwrap.NLOPT_LN_BOBYQA                   0.72

结果表明，所有不同的优化器收敛到相同的估计。因此，尽管有收敛警告，我们可能会感到相对自信，我们实际上已经找到了最优解，模型已经收敛。

接下来我们使用screenreg()函数并排打印两个模型的结果，看看泊松和负二项式有什么不同。在这种情况下，我们可以看到它们非常相似，除了年龄和截距的标准误差在负二项式模型中比在泊松模型中稍小。

screenreg(
  list(Poisson = m3.glmm,
       NegBin = m3.glmm.nb))

##
## ===================================================
##                          Poisson       NegBin
## ---------------------------------------------------
## (Intercept)                 -1.76 **      -1.76 ***
##                             (0.58)        (0.48)
## Age                          0.06 *        0.06 **
##                             (0.03)        (0.02)
## BornAUS                      0.42 ***      0.42 ***
##                             (0.12)        (0.12)
## ---------------------------------------------------
## AIC                       2070.12       4549.55
## BIC                       2092.34       4577.34
## Log Likelihood           -1031.06      -2269.78
## Num. obs.                 1914          1914
## Num. groups: UserID        190           190
## Var: UserID (Intercept)      0.52          0.51
## ===================================================
## *** p < 0.001, ** p < 0.01, * p < 0.05

如前所述，我们可以通过首先提取固定效应和置信区间，然后对其求幂，来制作事故率比率(IRRs)及其置信区间的表格。下面的代码通过对泊松和负二项式广义矩估计的并排比较来实现这一点。

exp(cbind(
  fixef(m3.glmm),
  confint(m3.glmm, parm = "beta_", method = "Wald"),
  fixef(m3.glmm.nb),
  confint(m3.glmm.nb, parm = "beta_", method = "Wald")))

##                  2.5 % 97.5 %      2.5 % 97.5 %
## (Intercept) 0.17 0.055   0.54 0.17 0.068   0.44
## Age         1.06 1.007   1.12 1.06 1.016   1.11
## BornAUS     1.53 1.199   1.95 1.53 1.202   1.95

比较预期分布和观察到的分布，看它们有多接近，也是有帮助的。以下代码从负二项式 GLMM(称为 theta)中提取过度离散的估计值，然后计算每个觉醒次数的观察密度和预期密度，并将它们存储在数据集中用于绘制。

theta <- getME(m3.glmm.nb, "glmer.nb.theta")

density <- data.table(
  X = as.integer(names(table(d$WASONs))),
  Observed = as.vector(prop.table(table(d$WASONs))))

density$NegBin <- colMeans(do.call(rbind, lapply(fitted(m3.glmm.nb), function(mu) {
  dnbinom(density$X, size = theta, mu = mu)
  })))

density$Poisson <- colMeans(do.call(rbind, lapply(fitted(m3.glmm), function(mu) {
  dpois(density$X, lambda = mu)
  })))

现在，我们可以绘制密度图，以显示我们的模型与观察到的数据分布有多接近。结果如图 12-5 所示。该图显示，总的来说，观察到的分布和预期的分布相当一致。这支持了我们的分配期望不是完全不合理的。我们还看到，在这种情况下，泊松模型和负二项式模型之间没有区别。

ggplot(melt(density, id.vars = "X"),
  aes(X, value, fill = variable)) +
  geom_col(position = "dodge") +
  scale_fill_viridis("Type", discrete = TRUE) +
  theme(legend.position = c(.8, .8)) +
  xlab("Number of awakenings") +
  ylab("Density") +
  coord_cartesian(
    xlim = c(-.5, 4.5),
    ylim = c(0, .5),
    expand = FALSE)

为了更好地理解为什么泊松和负二项式广义矩估计在分布方面给出相同的最终结果，我们可以看看θ的模型估计。这是一个非常高的估计，在这些情况下，负二项式趋向于泊松。

getME(m3.glmm.nb, "glmer.nb.theta")

## [1] 40993

考虑到θ的估计值、泊松和负二项式模型的结果和预期分布的相似性，在这种情况下，我们最有可能选择使用更简单的泊松模型。

img/439480_1_En_12_Fig5_HTML.png

图 12-5

基于泊松和负二项 GLMM 的夜间醒来次数的观测和预期平均密度。

随机截距和斜率

与逻辑广义矩量法一样，我们不仅可以包括随机截距，还可以包括随机斜率。在这里，我们将继续尝试预测睡眠开始后的觉醒。给定随机截距模型的结果，我们将在这里只探讨泊松 GLMM，而不是也包括负二项 GLMM。

除了年龄和参与者是否出生在澳大利亚之外，一个很好的觉醒预测因子可能是先前觉醒的次数。作为 GLMMs 介绍章节的一部分，我们创建了滞后变量。变量WWASONsLag1捕捉前一天晚上个人内部与个人均值的偏差。也就是说，它告诉我们一个参与者昨晚醒来的次数比平时多(或少)了多少次。虽然醒来的次数是一个离散的计数，但 12 天内平均醒来次数的偏差呈现一个更连续的分布，因为人们可能高于或低于他们自己的平均值。图 12-6 中显示了睡眠开始后唤醒的滞后人内偏差分布图。该图显示了一种非正态分布，但更连续且相对对称。

img/439480_1_En_12_Fig6_HTML.png

图 12-6

睡眠开始后，人与典型觉醒次数的偏差分布滞后于前一天。

testdistr(d[, WWASONsLag1],
          varlab = "Within WASONs lag 1")

在下面的模型中，我们将WWASONsLag1包括为固定效应和随机效应。因为我们在截距中加入了随机效应，所以模型将允许随机效应相互关联。

m4.glmm <- glmer(WASONs ~ Age + BornAUS +
   WWASONsLag1 +
  (1 + WWASONsLag1  | UserID),
  family = poisson(link = log),
  data = d, nAGQ = 1)

summary(m4.glmm)

## Generalized linear mixed model fit by maximum likelihood (Laplace
##   Approximation) [glmerMod]
##  Family: poisson  ( log )
## Formula:
## WASONs ~ Age + BornAUS + WWASONsLag1 + (1 + WWASONsLag1 | UserID)
##    Data: d
##
##      AIC      BIC   logLik deviance df.resid
##     4246     4284    -2116     4232     1770
##
## Scaled residuals:
##    Min     1Q Median     3Q    Max
## -1.768 -0.655 -0.333  0.485  3.892
##
## Random effects:
##  Groups Name        Variance Std.Dev. Corr
##  UserID (Intercept) 0.5043   0.7101
##         WWASONsLag1 0.0044   0.0663   1.00
## Number of obs: 1777, groups:  UserID, 189
##
## Fixed effects:
##             Estimate Std. Error z value Pr(>|z|)
## (Intercept)  -1.6039     0.5728   -2.80  0.00511 **
## Age           0.0527     0.0262    2.01  0.04472 *
## BornAUS       0.4045     0.1218    3.32  0.00089 ***
## WWASONsLag1  -0.0986     0.0457   -2.16  0.03093 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Correlation of Fixed Effects:
##             (Intr) Age    BrnAUS
## Age         -0.991
## BornAUS     -0.059 -0.020
## WWASONsLag1 -0.039  0.043  0.112

模型摘要显示了睡眠开始后的滞后觉醒和第二天晚上的觉醒次数之间的平均负相关(固定效应)。具体来说，每增加一次高于个人平均水平的觉醒，他们第二天晚上的觉醒对数就会减少-0.1。我们可以对这个值取幂来得到 IRR。IRR 表明，每增加一次高于个人平均水平的觉醒，他们在第二天晚上的觉醒次数就会增加 0.91 倍。

exp(cbind(
  B = fixef(m4.glmm),
  confint(m4.glmm, parm = "beta_", method = "Wald")))

##                B 2.5 % 97.5 %
## (Intercept) 0.20 0.065   0.62
## Age         1.05 1.001   1.11
## BornAUS     1.50 1.180   1.90
## WWASONsLag1 0.91 0.828   0.99

尽管不是很大，但是斜率还是有一些变化，正如随机方差和标准偏差所示。我们可以提取每个参与者的斜率，使用coef()函数将固定效应和随机效应结合起来。然后，我们可以对这些斜率取指数，并绘制它们来显示 IRR 的分布。分布显示，几乎所有的参与者都被预测为 IRR 低于 1，这表明对于几乎所有的人来说，当他们在某个晚上醒来的次数多于平时时，他们在第二天晚上醒来的次数往往会更少(图 12-7 )。

testdistr(exp(coef(m4.glmm)$UserID$WWASONsLag1))

最后，我们可以预测醒来的次数。通常，在预测中包含一定程度的不确定性是可取的。然而，围绕 GLMMs 的预测产生置信区间是复杂的。通过使用自举可以获得近似的置信区间。然而，值得注意的是，即使是自举置信区间目前也仅限于参数自举，因此仍然对分布进行假设。首先，我们建立一个新的预测数据集，并在链接范围内生成整体预测。

preddat.boot <- as.data.table(expand.grid(
  UserID = unique(model.frame(m4.glmm)$UserID),
  WWASONsLag1 = seq(
    from = min(d$WWASONsLag1, na.rm = TRUE),
    to = max(d$WWASONsLag1, na.rm = TRUE),
    length.out = 100),
  Age = quantile(d[!duplicated(UserID)]$Age,
                 probs = c(.2, .8), na.rm = TRUE),
  BornAUS = 0:1))

preddat.boot$yhat <- predict(m4.glmm,
  newdata = preddat.boot)

为了帮助加速引导，我们将设置一个本地集群来进行并行处理。我们需要加载相关的包并导出用于预测的数据集。

img/439480_1_En_12_Fig7_HTML.png

图 12-7

对于几乎所有人来说，当他们在某个晚上醒来的次数比平常多的时候，他们在第二天晚上醒来的次数就会减少。

genPred <- function(m) {
  predict(m,
    newdata = preddat.boot)
}

cl <- makeCluster(4)
clusterExport(cl, c("book_directory",
                    "checkpoint_directory",
                    "preddat.boot", "d", "genPred"))

clusterEvalQ(cl, {
  library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
    project = book_directory,
    checkpointLocation = checkpoint_directory,
    scanForPackages = FALSE,
    scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

  library(data.table)
  library(lme4)
  library(lmerTest)
})

## [[1]]
##  [1] "lmerTest"      "lme4"          "Matrix"        "data.table"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"
##
## [[2]]
##  [1] "lmerTest"      "lme4"          "Matrix"        "data.table"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"
##
## [[3]]
##  [1] "lmerTest"      "lme4"          "Matrix"        "data.table"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"
##
## [[4]]
##  [1] "lmerTest"      "lme4"          "Matrix"        "data.table"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"

主自举是一个参数模型，它是使用lme4包中的bootMer()函数进行的。请注意，我们在这里很少启动，因为即使是使用四核的并行集群，它也相对较慢。更常见的是运行 1，000、5，000 或 10，000 个引导数据库样本，但这可能需要数分钟或数小时。

system.time(bootres <- bootMer(m4.glmm,
    FUN = genPred,
    nsim = 100,
    seed = 12345,
    use.u = FALSE,
    type = "parametric",
    parallel = "snow",
    ncpus = 4,
    cl = cl))

##    user  system elapsed
##     3.3     1.7   169.4

最后，我们计算结果的简单百分位数置信区间，并将它们添加回我们的数据集中。这比线性混合模型的情况要复杂一些，因为我们跨 ID 折叠。这是因为无论是在链接范围(log，平均为零)还是在响应范围(counts，随机效应不平均为零)上平均随机效应，都会产生不同的结果。在我们的预测数据集中，有 75，600 行，对应于 189 个唯一 id，每个 id 针对不同的预测值重复 400 次。为了找到具有相同预测值但跨越 id 的所有行，我们可以为第一个、第二个等创建一个索引。预测值的组合。只要数据集是按预测值排序的，我们可以通过简单地按唯一 id 的长度重复一个索引值来做到这一点。

preddat.boot[, Index := rep(1L:400L,
  each = length(unique(UserID)))]

首先，我们将创建一个新的小型预测数据集，该数据集仅包含平均预测值和所需的预测值集。请注意，我们对预测的日志计数进行指数运算，然后对 id 进行平均，而不是先平均后指数运算。

preddat.boot.avg <- preddat.boot[, .(yhat = mean(exp(yhat))),
  by = .(WWASONsLag1, Age, BornAUS)]

现在我们可以通过新的指数循环，从 bootstrap 样本中获得平均计数的置信区间。如果我们直接采用基于百分位数的置信区间，这将包含由于人与人之间的差异和平均估计中的不确定性。相反，我们对所有 id 取指数，取平均值，然后取 bootstrap 样本的百分位数。在指数化之后，但在计算百分位数置信区间之前，对所有人(id)进行平均，意味着我们对所有人的可变性进行平均，并且只考虑所有人的平均估计值的可变性。我们还可以包括由 IDs 引起的可变性，但这将回答一个不同的问题。

要真正做到这一点，请注意引导结果在列上有不同的预测(即，列是区分不同 id 和我们的预测变量的各种值的部分)，并且每个新的引导结果是不同的行。因此，我们在列上使用我们的索引，并在取幂之后取行的平均值，以便对一组特定的预测值的 id 的可变性进行平均。然后，我们计算置信区间的百分位数，并将它们添加回我们的预测数据集中，该数据集中的 id 是平均的。

dim(bootres$t)

## [1]   100 75600

for (i in 1:400) {
  ## find which indices to use
  ok <- which(preddat.boot$Index == i)

  ## now average across people
  tmp_avg <- rowMeans(exp(bootres$t[, ok]))

  ## lower confidence interval
  preddat.boot.avg[i,
    LL := quantile(tmp_avg, probs = .025, na.rm = TRUE)]
  preddat.boot.avg[i,
    UL := quantile(tmp_avg, probs = .975, na.rm = TRUE)]
}

现在我们有了参数自举置信区间，我们可以绘制一个图表，显示以前夜间醒来的预测次数、年龄以及参与者是否出生在澳大利亚。结果如图 12-8 所示。图表显示，当人们醒来的次数高于他们自己的平均次数时，第二天晚上醒来的次数减少了。我们也可以看到年龄的主要影响,“年长”的年轻人比“年轻”的年轻人有更多的觉醒预测。同样通过颜色，我们看到那些在澳大利亚出生的人比那些不在澳大利亚出生的人倾向于报告更多的觉醒。置信区间不是严格对称的，这对于反应标度上的置信区间是正常的(即，在指数化之后)。置信区间有一些参差不齐。如果我们生成 5000 个引导样本而不是 100 个，它们可能会更平滑。

img/439480_1_En_12_Fig8_HTML.png

图 12-8

根据前一次夜间醒来(相对于自己的平均值)预测醒来次数的图，按年龄(岁)在第 20 和第 80 百分位(分别为 19.4 岁和 25 岁)分开，并在澳大利亚出生(0 =否，1 =是)。平均预测计数周围的自举置信区间通过阴影显示。

ggplot(preddat.boot.avg, aes(WWASONsLag1, yhat,
  colour = factor(BornAUS), fill = factor(BornAUS))) +
  geom_ribbon(aes(ymin = LL, ymax = UL),
              alpha = .25, colour = NA) +
  geom_line(size = 1) +
  ylab("Predicted Awakenings") +
  xlab("Within person awakenings lag 1") +
  scale_color_viridis("Born in Australia", discrete = TRUE) +
  scale_fill_viridis("Born in Australia", discrete = TRUE) +
  theme(
    legend.position = "bottom",
    legend.key.width = unit(1, "cm")) +
  facet_wrap(~ Age) +
  coord_cartesian(
   xlim = c(-3, 3),
   ylim = c(0, 2.5),
   expand = FALSE)

12.4 摘要

本章建立在前面章节的线性混合效应模型的基础上，为二元和计数结果建立混合效应模型。具体来说，本章涵盖了逻辑混合效应模型和泊松和负二项混合效应模型。本章还介绍了从 GLMMs 生成预测的独特挑战，特别是如何考虑原始尺度预测中的随机效应。最后，我们展示了如何计算原始规模上预测的置信区间，以说明使用自举的随机效应。表 12-1 总结了一些关键功能。

表 12-1

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| glmer() | 估计广义线性混合效应模型。 |
| glmer.nb() | 估计负二项广义线性混合效应模型。 |
| bootMer() | 自助线性或广义线性混合效应模型。 |
| binomial() | logistic 广义线性混合模型的分布族函数。通常与规范的 logit 链接一起使用。 |
| poisson() | 计数结果泊松广义线性混合模型的分布族函数。通常与规范日志链接一起使用。 |
| summary() | 提供数据输入的摘要。 |
| fixef() | 提取固定效果，以模型作为参数。 |
| coef() | 从广义线性混合模型中提取模型系数。请注意，与使用glmer()或lmer()拟合混合效果模型的单级模型不同，该函数返回每个参与者或集群级别的系数，其中包含固定和随机效果。 |
| confint() | 置信区间生成函数。 |
| predict() | 类似于fitted()，除了需要一个数据参数。在这两种情况下，都会返回模型输出 yhat 值。 |
| quantile() | 计算给定数据的分位数。 |

十三、模拟 IIV

到目前为止，我们只关注分布位置(或平均值)的统计模型。这一章的重点是一些新的东西，分布的规模或可变性。具体来说，本章介绍了个体内变异性(IIV)的概念，即在重复评估中个体单位内的变异性。虽然是一个相对小众的研究领域，IIV 提供了关于单个单位的附加信息，并允许新类型的研究或实际问题进行评估，如人(学校，工厂等)。)有更大的可变性会有不同的结果？本章使用了由作者之一开发的专门用于vari能力an分析的软件包varian。

library(checkpoint)
checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

library(knitr)
library(ggplot2)
library(cowplot)
library(viridis)
library(data.table)
library(JWileymisc)
library(varian)
library(mice)
library(parallel)

options(width = 70, digits = 2)

13.1 概念背景

贝叶斯推理

一个重要的注意事项是贝叶斯方法的使用。贝叶斯思维的覆盖范围超出了本书的范围。然而，Gelman 及其同事(2013 年)[36]有一本关于贝叶斯数据分析的非常详细的书。虽然不要求对贝叶斯方法有深入的了解，但是对如何进行抽样的基本理论和实践的熟悉是充分利用本章所必需的。我们在这里提供一个非常简单的概述贝叶斯推断的几个方面，但是强烈建议没有遇到过这些方法的读者去阅读其他的著作。

贝叶斯推理使用贝叶斯规则来计算参数的后验分布， p(参数-数据，先验)，它是参数的概率，以数据和先验分布为条件。马尔可夫链蒙特卡罗(MCMC)用于从参数的后验概率分布中抽取样本。通过汇总来自后验分布的 MCMC 样本，例如通过计算样本的平均值或中值，获得点估计；不确定性可以通过计算标准偏差或给出百分位数来表征(例如，95%置信区间的 2.5 和 97.5 百分位数；CI)。如果需要 p 值，可以将双尾经验 p 值计算为高于或低于 0 的样本比例中较小者的两倍，即:2 **min(prop(θ*≤0)， prop ( θ > 0)。可以通过计算模型中每个参数的百分比比例缩减系数(PSRFs) [17]来检查收敛性。PSRFs 也称为 Rhats，它估计通过延长 MCMC 链的运行时间可以降低的比例。值 1 表示收敛，尽管通常认为足够接近 1 的值表示收敛(例如 1.1)。

贝叶斯推断依赖于总结后验分布。因此，为了得到稳定的总结，有足够的后验样本量是很重要的。然而，如果样本中存在高自相关，许多后验样本可能不足以表征整个后验参数分布。通常，可以从基于变异函数和多链方差对自相关估计进行调整的每个参数的有效样本量中提取相关信息。还可以评估每个参数的有效后验样本量。如果估计的后验有效样本量不足，这可能表明需要额外的迭代，或者可能需要一些其他方法，如重新调整数据、简化模型或使用更强的先验。

什么是 IIV？

在大多数应用中，人们关注的是均值(也称为“位置”)差异。例如，常见的问题是两组是否有不同的均值，均值是否可以通过其他因素(即大多数回归模型)预测，以及均值如何随时间变化。然而，研究人员也承认个体间和个体内的可变性(也称为“尺度”)是重要的[30]。例如，Russell，Moskowitz，Zuroff，Sookman 和 Paris (2007) [84]的实证研究表明，边缘型人格障碍患者(其特征是不稳定的关系和情感不稳定[1])在情感方面表现出比对照组显著更高的个体内变异性。在衰老和发育过程的背景下，Ram 和 Gerstorf (2009) [77]概述了研究个体间变异性的重要概念、方法和研究设计考虑因素。概念和经验的兴趣 IIV 也存在于睡眠领域(如比斯等人，2010[18]；Suh et al .，2012 [91])，因为发现没有两个晚上的睡眠是相同的，许多人每晚睡觉的时间、睡眠时间和睡眠质量都有很大差异。因此，尽管与理解手段的兴趣相比，对规模和 IIV 的兴趣较小，但人们对 IIV 很感兴趣。

这一章的目的是介绍一个严格的和可行的方法来估计个体内部的变异性。当个体间的差异具有理论和经验相关性时，我们也将强调变异性估计指数的效用。在介绍更复杂的统计位置和比例模型之前，我们将首先介绍一些简单的量化 IIV 的方法。

可变性的量化和建模方法

在介绍我们的主要贝叶斯位置尺度模型之前，我们回顾了一些量化和建模可变性的现有方法。

也许可变性最常见的度量是方差或标准差。使用标准偏差(或方差的平方)计算个体间的变异性，作为每个受试者观察值的标准偏差，也称为个体标准偏差(ISD)。计算 ISD 后，它可用作另一个统计模型中的结果或预测值。因为 ISD 量化了与单个单位平均值的偏差，系统时间效应(例如，随时间线性增加)将增加 ISD。这可能合适，也可能不合适，取决于您是对捕捉一个人的所有可变性感兴趣，还是仅对非系统可变性感兴趣。

例如，在睡眠中，日光的季节性变化会影响个人的睡眠/觉醒行为，并且这种变化可能没有直接的研究或临床相关性。在这些情况下，ISD 可能高估了感兴趣的个体内变异的类型。在对时间或其他相关因素进行调整(即去趋势化)后，可以通过计算残差的 ISD 来解决这种偏差。

量化可变性的另一个传统方法是连续差异的均方根(RMSSD ) [103]。因为 RMSSD 是基于连续的差异，它自然地消除了系统趋势的影响。例如，下面的代码显示了相同的数据，首先从最小到最大排序，然后随机化。虽然数据重新排序后标准差不会改变，但有序数据的 RMSSD 比无序数据的要小得多。这突出了系统趋势(有序数据)的 RMSSD 可能小于标准差，但无序数据的大小可能相同，甚至更大。

## ordered
sd(c(1, 3, 5, 7, 9))

## [1] 3.2

rmssd(c(1, 3, 5, 7, 9))

## [1] 2

## randomized
sd(c(3, 1, 9, 5, 7))

## [1] 3.2

rmssd(c(3, 1, 9, 5, 7))

## [1] 4.7

可变性的其他度量是方差(即， ISD 2 )、连续差异的均方值(即， RMSSD 2 )、中位数绝对差、极差、四分位差和变异系数。

为了更好地理解这些不同的度量之间的关系，我们将从广义线性混合模型(GLMMs)的章节中加载我们使用的 ACES 数据。我们还加载我们制作并保存在“GLMMs:简介”一章中的经过处理的数据。接下来，我们定义一个函数，variability_measures(),,以便更容易地计算数据上的所有这些度量。

data(aces_daily)
draw <- as.data.table(aces_daily)
d <- readRDS("aces_daily_sim_processed.RDS")

variability_measures <- function(x) {
  x <- na.omit(x)
  list(
    SD = sd(x),
    VAR = sd(x)²,
    RMSSD = rmssd(x),
    MSSD = rmssd(x)²,
    MAD = median(abs(x - median(x))),
    RANGE = range(x),
    IQR = abs(diff(quantile(x, probs = c(.25, .75)))),
    CV = sd(x) / mean(x))
}

现在，我们可以通过参与者 ID 来计算可变性测量，以创建一个新的数据集，然后估计并绘制 ACES 数据中四个不同变量的相关矩阵。

plot_grid(
  plot(SEMSummary(~ .,
    data = d[, variability_measures(PosAff), by = UserID][,-1]),
    order = "asis") +
    ggtitle("PosAff"),
  plot(SEMSummary(~ .,
    data = d[, variability_measures(NegAff), by = UserID][,-1]),
    order = "asis") +
    ggtitle("NegAff"),
  plot(SEMSummary(~ .,
    data = d[, variability_measures(COPEPrc), by = UserID][,-1]),
    order = "asis") +
    ggtitle("COPEPrc"),
  plot(SEMSummary(~ .,
    data = d[, variability_measures(SOLs), by = UserID][,-1]),
    order = "asis") +
    ggtitle("SOLs"),
ncol = 2)

图 13-1 中的图有助于从经验上展示根据计算方法也可以收集到的信息:标准差(SD)、方差(VAR)、均方根连续差(RMSSD)、均方连续差(MSSD)、中位数绝对偏差(MAD)和四分位间距(IQR)都趋向于强相关。一般来说，范围和变异系数有更大的不同。

img/439480_1_En_13_Fig1_HTML.png

图 13-1

应用于个人的四种不同测量的可变性测量之间的相关性

然而，所有这些方法都受到测量误差的限制。尽管这种批评适用于任何计算出来的统计数据，但在专注于均值的研究中，这并不是一个实际问题。方法显示了良好的可靠性，因此测量误差低，重复测量很少。相比之下，ISD 的可靠性很差，测量很少，特别是当重复观测的数量很少，ISDs 的个体差异很小时[31]。通过分析 ISD 和 ISD2 的可靠性，一份可靠的问卷(可靠性 0.9)需要多达 50 次重复观察，以合理的可靠性(可靠性 0.8)估计个体间的变异性[105]。在许多情况下，由于参与者的负担和成本，收集这么多的测量值可能是不可行的。

心理测量学领域已经对如何评估和说明测量误差进行了广泛的研究。例如，潜在变量模型可用于说明测量误差[13]。然而，大多数统计模型是设计来测试位置(平均值)，而不是规模(可变性)的影响。一个值得注意的例外是独立观测，在这种情况下，针对位置和规模的灵活广义加性模型(gam)已经得到发展(见[79]和[89])。然而，位置尺度 gam 不适用于重复测量数据(非独立观察)，因此也不适用于个体间变异性的研究。

评估方面的技术进步，包括自我报告的移动应用程序和提供大量密集测量的可穿戴设备的爆炸，导致越来越多的研究，包括许多重复的人均测量。随后，最近的方法学文献集中于开发新的技术，用于随着时间的推移量化个体的特征，包括 IIV。

Hedeker、Mermelstein 和 Demirtas (2008 年)[42]在最大似然框架内开发了混合效应位置和规模模型。Hedeker 的模型允许解释变量预测受试者之间和受试者内部的因素，包括随机截距和随机生命指数。它已被用于分析生态瞬时评估数据(有关该应用的精彩介绍，请参见 Hedeker、Mermelstein 和 Demirtas，2012 年)[43]。Hedeker、Demirtas 和 Mermelstein (2009) [41]将连续结果模型扩展到有序数据，李和 Hedeker (2012) [56]将位置尺度模型扩展到三级模型。

另一种方法是首先计算连续差的平方，然后使用广义线性混合模型对其建模。这种方法使用连续的差异，因此对系统性的个体内部变化不太敏感。截距，实际上是均方连续差(RMSSD2)，可以通过将每个均方连续差输入广义线性混合模型来预测。这种方法的一个局限性是它处理缺失数据的能力。例如，如果跨三天收集数据，则有两个连续差异，t2–t1和t3–t2，如果缺少第二天( t 2 )，则两个连续差异都是未定义的。

Wang，Hamaker 和 Bergeman (2012) [106]提出了一个直接使用原始数据的贝叶斯多级模型。该模型结合了时间依赖性(通过自相关系数获得)和可变性的大小，而 Hedeker 等人(2008 年)[42]的方法仅模拟了大小。考虑时间相关性对于许多重复测量特别有用。自相关有时也被称为惯性，因为它们表明改变方向有多困难。尽管有这些好处，考虑水平(截距)、时间相关性(自相关)和可变性(IIV)的个体差异会导致更复杂的模型，这往往需要更大的样本量。王及其同事(2012) [106]观察到，在超过 200 名参与者中，当每个参与者使用所有 56 个重复测量时，他们的方法收敛，但当每个参与者使用 7 个甚至 14 个重复测量时，他们的方法不收敛。

总之，除非有许多重复测量(可能超过 50)，否则量化可变性的简单方法(如 ISD 或 RMSSD)不是最佳方法，因为可靠性低且无法解释测量误差。显式位置比例模型是存在的，并且对于较少的重复测量可能是更好的选择。即使有许多重复测量，显式位置比例模型也具有优势，因为它们可以开始分离可变性的来源(例如，通过消除时间依赖性)[42，106]。到目前为止，我们把重点放在 IIV 的成果上。在下一节中，我们将介绍一个贝叶斯变异性模型，该模型提供了 IIV 的估计值，并使用 IIV 作为预测值。

作为预测因子的个体内变异性

将 IIV 作为一个预测因素主要有两个方面。首先，我们必须获得一个可靠的 IIV 度量或 IIV 度量，以及对该度量的不确定性的估计(即，考虑度量误差)。接下来，这个度量可以在另一个模型中用作预测器。第二个模型的细节不是特别重要，因为 IIV 估计实际上可以输入到任何模型中。

估计生命价值的基础是多水平或混合效应模型。我们已经在前几章介绍了这些模型。由于其灵活性，混合效果模型是一个理想的起点。具体来说，根据研究的问题，人们可以用不同的方式来定义 IIV。例如，假设两个人，A 和 B，接受了干预并每周评估一次。随时间变化的轨迹如图 13-2 所示。

img/439480_1_En_13_Fig2_HTML.png

图 13-2

两个假设的人接受了干预，人 A(紫色)和人 B(黄色)，都以相同的速度提高，但人 B 的一致性较差

iivdat <- data.table(
  Assessment = 0:15,
  PersonA = c(1, 3, 2, 4, 3, 5, 4, 6, 5, 7, 6, 8, 7, 9, 8, 10),
  PersonB = c(2, 5, 2, 6, 3, 7, 4, 8, 5, 9, 6, 10, 7, 11, 8, 12))

ggplot(iivdat, aes(Assessment)) +
  stat_smooth(aes(y = PersonA), method = "lm", se=FALSE,
              colour = viridis(2)[1], linetype = 2) +
  geom_line(aes(y = PersonA),
            colour = viridis(2)[1], size = 1) +
  stat_smooth(aes(y = PersonB), method = "lm", se=FALSE,
              colour = viridis(2)[2], linetype = 2) +
  geom_line(aes(y = PersonB),
            colour = viridis(2)[2], size = 1) +
  ylab("Outcome Scores")

该图显示，虽然两个人对干预的反应大致相同，但一个人比另一个人改善得更稳定。这些差异在 ISDs 中显而易见。

## ISD
sd(iivdat$PersonA)

## [1] 2.6

sd(iivdat$PersonB)

## [1] 3

然而，在没有任何调整的情况下，这些 isd 纳入了由于随时间的系统变化和围绕这些系统趋势的波动而导致的结果评分的可变性。如果研究旨在使用总 IIV，那么这些可能是理想的。然而，如果问题在于随着时间的推移，改进的稳定性或可变性如何，那么我们应该首先去除这些系统性的变化。结果如下所示。随着系统性趋势的消失，isd 比以前小得多。

## ISD, after removing systematic improvements
sd(resid(lm(PersonA ~ Assessment, data = iivdat)))

## [1] 0.77

sd(resid(lm(PersonB ~ Assessment, data = iivdat)))

## [1] 1.8

虽然我们不提倡直接提取残差并对其进行操作，但从概念上讲，这是我们的目标。混合效应模型是一个理想的选择，因为它们允许分析师灵活地调整或不调整系统趋势。混合效应模型还允许考虑任何其他相关的预测因素，以便分离出所需的 IIV 来源。根据个人的目标，这可能涉及不添加任何预测因子、添加时间或向模型中添加许多不同的潜在预测因子，并对残差进行 IIV 建模。

出于实际原因，在贝叶斯框架中使用马尔可夫链蒙特卡罗(MCMC)模拟来估计模型是方便的。贝叶斯框架很有帮助，因为

  • 贝叶斯方法允许在指定模型和分布方面的灵活性，而不需要显式地导出似然函数

  • 最大似然法在估计生命年数时很难收敛，而贝叶斯法可能很慢，但通常如果运行时间足够长，就会混合并收敛

  • 通过 MCMC 模拟，来自后验分布的多次提取允许将 iiv 估计中的不确定性捕获为可能估计的采样分布，而不是单个“最佳估计”

下一节将更详细地介绍贝叶斯可变性模型(BVM)。

贝叶斯可变性模型

我们已经在前几章介绍了混合效应模型。如果对这些不熟悉，最好在继续之前回顾一下前面的章节，在这些章节中，只解释了位置混合效应模型。我们之前的技术报告[116]对该模型进行了更全面的介绍和评估。

作为参考，假设Y是人与人之间的结果，而V是人与人之间的变量，这样V在每个人身上被重复测量。iiv 将从V开始估算，并用于预测他们在Y上的得分。此外，该模型可以估计每个人的平均值V，作为Y的附加预测值。在关于 IIV 的文献中，我们认为，在检验 IIV 是否预测了一个结果以证明检验 IIV 的附加价值时，至少对变量的均值进行统计调整是重要的[116，8，6，7]。首先，考虑一个V的多级模型；为了简单和不失一般性，我们从一个无条件模型开始:

$$ {V}_{ij}\sim N\left({\mu}_j,\sigma \right) $$

(13.1)

在本例中，VIj是第 i th (i = 1，2，...、 I j )考核为第 j th (j = 1，2，...，N)主语。每个个体都有自己的估计均值， μ j ，均值的分布假设遵循正态分布:

$$ {\mu}_j\sim N\left({\mu}_{\mu },{\sigma}_{\mu}\right) $$

这个基本的混合效应模型对假设适用于每个人的剩余可变性进行了单一估计。我们可以扩展这个模型，允许标准偏差也因受试者而异。扩展模型仍然假设正态分布，但是现在允许位置 μ 和剩余标准偏差 σ 变化。新模型被指定为

$$ {V}_{ij}\sim N\left({\mu}_j,{\sigma}_j\right) $$

(13.2)

该等式与之前的等式相同，但是μj表示个体标准差，或者在条件模型的情况下，表示个体剩余标准差。基于观测残差估计 ISDs 不能解释模型估计的不确定性可能导致残差差异的事实。然而，作为模型的一部分，位置参数的不确定性将传播到残差中，从而传播到 ISD 估计中。

像假设来自正态分布的单个平均值一样，单个(剩余)标准偏差也假设来自一个分布，特别是具有比例和形状参数 α 和 β 的伽马分布:

$$ {\sigma}_j\sim -\left(\alpha, \beta \right) $$

(13.3)

使用任何标准模型，个体(剩余)标准偏差的估计值j，然后被用作结果的预测值Y。例如，我们可以使用多元线性回归，即

$$ {Y}_j\sim N\left(\mu {2}_j,\sigma \right) $$

*(13.4)

在该模型中，预测值 μ 为

$$ \mu {2}_j={\beta}_0+{\beta}_1 Covariat{e}_1+\dots +{\beta}_k Covariat{e}_k+{\alpha}_1{\sigma}_j+{\alpha}_2{\mu}_j $$

(13.5)

为了突出模型中任何其他预测因子或协变量与混合效应模型中的单个均值和 ISDs 之间的差异，我们使用了一个单独的参数向量。我们用 β 表示常规预测值，用 α 表示潜在平均值和 ISDs。

请注意，尽管我们在这里使用了线性回归，但是我们可以很容易地用几乎任何统计模型替换线性回归模型。

估计生命统计数字的 ISD 方法受到了批评，因为它没有考虑观察值的顺序。然而，这是通过在混合效应模型的背景下估计生命年数来解决的。作为混合效应模型的一部分，随着时间推移的系统趋势和其他相关变量可以作为预测因素添加进来。通过包括滞后的结果措施，也有可能包括自回归效应。这提供了使 ISD 包括所有可变性或仅包括感兴趣部分的灵活性。此外，通过在统计模型中包括去趋势，不确定性再次被捕获并传播到 IIV 估计。

软件实现:瓦里安

贝叶斯可变性模型(BVM)可以在任何通用贝叶斯框架中进行估计，如 JAGS、bug 或 Stan。我们将使用 Stan [35，19]，这是一种通用编程语言，使用马尔可夫链蒙特卡罗(MCMC)进行贝叶斯推理，并使用不掉头采样器进行采样，该采样器是哈密顿蒙特卡罗(Hoffman & Gelman，2014) [44]的扩展。

虽然在 Stan 中手动指定每个模型是可能的，也是最灵活的，但为了使不太熟悉贝叶斯方法的分析师更容易，我们也将使用可从 CRAN 或 GitHub 获得的R包varian【116】:https://github.com/ElkhartGroup/VARIAN。varian链接到 Stan，只需几行代码就能估算出 BVM。目前，varian只支持对连续的、正态分布的变量的可变性建模。

在varian中，默认情况下，先验信息很少，假设变量的标准偏差大约≤ 10。具体来说，均值和回归系数使用均值为零和标准差为 1，000 的正态先验。第二阶段结果的伽马分布和残差方差的比例和形状参数使用半柯西先验，这是一种比方差分量的均匀或逆伽马族更好的弱信息先验[34，74]。具体来说，varian分别使用 0 和 10 的位置和比例参数。根据数据的规模，可能需要指定先验的替代参数或重新调整数据，以使默认先验的信息量较弱。

使用百分比比例缩减系数(PSRF)来估计收敛。因为σj和 μ j 的每个个体估计都是一个参数，所以有很多个体 PSRFs。在varian中，作为一个诊断图，我们展示了一个 Rhats 的直方图，以便对所有参数的收敛性进行直观检查。一项模拟研究表明，只要每个人有五个或更多的重复测量，在varian中描述和实施的 BVM 就会产生最小偏差的估计值。

13.2 R示例

IIV 预测一个连续的结果

为了使用前面描述的 BVM 来预测连续的结果，我们可以使用varian()函数。varian包和Stan用 C++编译模型。因此，为了让这些工作，你需要在你的系统上安装一个 C++编译器，并且可以被R访问。在运行 Windows 操作系统的机器上，最简单的方法就是安装R工具，可从 https://cran.r-project.org/bin/windows/Rtools/ 获得。在运行 Mac OS 的机器上，获得必要编译器的最常见方式是从 app store 安装Xcode。在 linux 或 unix 的不同变体上，使用它们的包管理器来安装 GCC 或另一个 C++编译器应该很简单。如果模型编译时出现错误，尝试更新R和您的编译器(通过安装最新版本的R工具或Xcode或特定的编译器)。最后，请注意，在编译期间，出现大量消息和警告是正常的。如果没有错误，模型通常是好的，大多数消息和警告都可以忽略。

varian()函数有几个参数。首先，人与人之间结果的模型公式被指定给y.formula参数。IIV 估计值被自动包括在内，所以所有需要指定的是结果变量和任何额外的协变量或预测值。接下来，生命统计数字的公式被指定给v.formula。因为生命体征需要重复测量结果，所以必须有一个 ID 变量。照常指定数据。此外，我们指定了design，它指示是否应该单独评估生命体征，它们应该预测一个结果，或者它们应该预测一个中介和一个结果。在下面的示例模型中，我们估计生命年数，并用它们来预测一个连续的结果。此外，有几个关于 MCMC 采样的参数，包括总迭代次数、totaliter;预热迭代次数、warmup;细化间隔、thin;和要使用的独立链的数量、chains。为了让示例运行得更快，我们使用了相对较少的迭代次数和较低的瘦。为了确保最终模型具有良好的收敛性和稳定的估计值，人们可能会选择一个较大的值，这样最终的有效样本量为几千个。在这种情况下，我们测试积极情感的 IIV 是否预测平均消极情感超过平均积极情感。也就是说，积极情绪的不稳定性能唯一预测一个人典型的消极情绪水平吗？

cl <- makeCluster(2)
clusterExport(cl, c("book_directory", "checkpoint_directory" ))

clusterEvalQ(cl, {
  library(checkpoint)
  checkpoint("2018-09-28", R.version = "3.5.1",
  project = book_directory,
  checkpointLocation = checkpoint_directory,
  scanForPackages = FALSE,
  scan.rnw.with.knitr = TRUE, use.knitr = TRUE)

  library(varian)
})

## [[1]]
##  [1] "varian"        "rstan"         "StanHeaders"   "ggplot2"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"
##
## [[2]]
##  [1] "varian"        "rstan"         "StanHeaders"   "ggplot2"
##  [5] "checkpoint"    "RevoUtils"     "stats"         "graphics"
##  [9] "grDevices"     "utils"         "datasets"      "RevoUtilsMath"
## [13] "methods"       "base"

system.time(m <- varian(
  y.formula = BNegAff ~ 1,
  v.formula = PosAff ~ 1 | UserID,
  data = d,
  design = "V -> Y",
  useU = TRUE,
  totaliter = 10000,
  warmup = 500, thin = 5,
  chains = 2, verbose=TRUE,
  cl = cl))

##    user  system elapsed
##     1.3     1.5   510.2

在检查模型估计之前，我们可以使用vm_diagnostics()函数检查一些基本的模型收敛诊断。结果如图 13-3 所示。Rhat 值的范围表明了良好的收敛性。然而，所有参数的有效样本量各不相同，有些相对较低。现在我们将继续，但在实践中，人们可能希望增加迭代次数，并使用更强的先验或其他方法来确保最小有效样本量更大。

img/439480_1_En_13_Fig3_HTML.png

图 13-3

诊断，包括百分比标度缩减系数(Rhat)、有效样本量、单个标准差的分布、单个均值的分布以及单个标准差和均值的单个估计值(具有可信区间)。

## check diagnostics
vm_diagnostics(m)

虽然可能有其他感兴趣的参数，但通常主要的兴趣围绕着生命体征是否真的预测结果。为了检验这一点，我们提取 MCMC 样本并使用vmp_plot()绘制它们。我们专门绘制了Yalpha，它是结果Y的α系数向量。结果如图 13-4 所示。这些图表通过散点图显示了单个 isd 的分布、单个均值及其联合分布。条形图显示了高于和低于 0 的 MCMC 样本的比例，这些用于生成 p 值。在这种情况下，IIV 和个人平均都是重要的预测因素，但方向相反。较高的平均积极情感预示着显著较低的消极情感。然而，独立于平均积极情感，具有不太稳定的积极情感(即，更多变量)的人预期具有更高的典型消极情感。

img/439480_1_En_13_Fig4_HTML.png

图 13-4

经验 p 值的分布图、双变量散点图和零两侧的病例比例

## extract MCMC samples
mcmc.samples <- extract(m$results,
  permute = TRUE)

## examine MCMC samples of
## the alpha regression coefficients
vmp_plot(mcmc.samples$Yalpha)

最后，我们可以使用param_summary()函数获得我们可能需要的任何参数的摘要。以下代码显示了每个组件的摘要:IIV 模型和预测平均负面影响的模型。结果显示，平均负面影响的截距非常低，接近 1(在 1 到 5 的可能范围内)。生命统计研究所的研究结果表明，积极情感的 IIV 越高，消极情感也越高。由于 MCMC 抽样中固有的随机抽样，您的结果可能与本书有所不同，这在有效样本量很小时尤其会影响结果。然而，在这些例子中，高一个单位的 IIV 与高半个点的平均负面影响相关。我们还可以看到积极情绪平均水平的结果，这与消极情绪平均水平呈负相关:人们平均越积极，消极情绪就越少。最后，对于平均负面影响，我们可以得到一个残差的总结，不是由正面影响 IIV 或正面影响个体均值来解释的。

## intercept of average negative affect
param_summary(mcmc.samples$YB[, 1])

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1  1.1    1.1 0.14  0.87    1.4  < .001

## IIV on average negative affect
param_summary(mcmc.samples$Yalpha[, 1])

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1 0.57   0.57 0.19  0.19   0.95    .002

## individual mean on average negative affect
param_summary(mcmc.samples$Yalpha[, 2])

##    Mean Median   SE LL2.5 UL97.5 p-value
## 1 -0.22  -0.22 0.04 -0.31  -0.15  < .001

## residual error of average negative affect
param_summary(mcmc.samples$sigma_Y)

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1 0.43   0.43 0.02  0.38   0.48  < .001

我们还可以获得 IIV 模型的参数汇总，包括截距、包含的任何预测因子的影响，以及 iiv 的随机影响和伽马分布参数的汇总。这些如下所示。

## intercept of positive affect
param_summary(mcmc.samples$VB[, 1])

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1  2.7    2.7 0.06   2.6    2.8  < .001

## positive affect random intercept standard deviation
param_summary(mcmc.samples$sigma_U)

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1  0.8    0.8 0.04  0.73   0.89  < .001

## estimate of the gamma rate parameter for IIVs
param_summary(mcmc.samples$rate)

##   Mean Median  SE LL2.5 UL97.5 p-value
## 1   19     19 2.4    15     24  < .001

## estimate of the gamma shape parameter for IIVs
param_summary(mcmc.samples$shape)

##   Mean Median  SE LL2.5 UL97.5 p-value
## 1   14     13 1.6    11     17  < .001

最后，如果目标是通过varian()函数直接使用 IIV 估计，尽管这不是必需的，但是为了在其他模型中使用估计，必须首先提取它们。提取生命体征的贝叶斯估计有助于在各种模型中使用它们。例如，它们可以用作广义加法模型、机器学习模型等中的预测器。肝脏被命名为Sigma_V。细化后，这将是一个矩阵，数据集中每个未丢失的唯一 ID 对应一列，每个 MCMC 样本对应一行。在这种情况下，它是一个 2,000 x 191 维的矩阵。当用作贝叶斯模型的一部分时，IIV 估计中的不确定性会自动传播到后面参数估计中的不确定性。但是，如果提取结果，必须小心确保不确定性仍在传播。一种方法是将 MCMC 样本视为缺失变量的多重插补。本质上，我们可以认为生命保障指数和个人方法是缺失的价值，因为我们没有观察它们。我们的模型估算我们的最佳估计，但它这样做有一些误差。注意，个别手段也可用，命名为U。

dim(mcmc.samples$Sigma_V)

## [1] 2000  191

str(mcmc.samples$Sigma_V)

##  num [1:2000, 1:191] 0.558 0.478 0.525 0.6 0.44 ...
##  - attr(*, "dimnames")=List of 2
##   ..$ iterations: NULL
##   ..$           : NULL

使用 IIV 估计的最简单但不是最佳的方法是简单地对 MCMC 样本求平均值。下面的代码提取这些，平均它们，合并平均负面影响，并估计一个回归模型。这些结果与一步贝叶斯模型的结果相似，但在平均估计值和置信区间上有很大不同。

avg_dataset <- cbind(
  d[!duplicated(UserID), .(BNegAff)],
  IIV = colMeans(mcmc.samples$Sigma_V),
  IIM = colMeans(mcmc.samples$U))

avg_model <- lm(BNegAff ~ IIV + IIM, data = avg_dataset)

summary(avg_model)

##
## Call:
## lm(formula = BNegAff ~ IIV + IIM, data = avg_dataset)
##
## Residuals:
##     Min      1Q  Median      3Q     Max
## -0.7862 -0.2762 -0.0538  0.1933  1.5671
##
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)
## (Intercept)   1.0518     0.1334    7.88  2.5e-13 ***
## IIV           0.7119     0.1841    3.87  0.00015 ***
## IIM          -0.2321     0.0389   -5.97  1.2e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 '␣' 1
##
## Residual standard error: 0.42 on 188 degrees of freedom
## Multiple R-squared:   0.2,   Adjusted R-squared:  0.192
## F-statistic: 23.5 on 2 and 188 DF,  p-value: 7.72e-10

接下来，我们可以通过使用不同的 MCMC 样本来制作许多数据集。我们不使用所有 1，000 个，而是每 10 个取一个。在每一种情况下，我们可以估计一个回归模型，然后通过使用as.mira()函数转换为一个多重估算分析对象，然后使用pool()函数组合结果，从而组合和汇集结果。我们在缺失数据一章中会更详细地介绍如何处理多重估算数据。

ind_dataset <- lapply(seq(1, 1000, by = 10), function(i) {
  cbind(
  d[!duplicated(UserID), .(BNegAff)],
  IIV = mcmc.samples$Sigma_V[i, ],
  IIM = mcmc.samples$U[i, ])
})

ind_model <- lapply(ind_dataset, function(tmpdat) {
  lm(BNegAff ~ IIV + IIM, data = tmpdat)
})

ind_model_pooled <- pool(as.mira(ind_model))

作为最后的比较，我们可以用简单的 ISD 估计来拟合一个模型。

raw_model <- lm(BNegAff ~ IIV + IIM,
 data = d[, .(BNegAff = BNegAff[1],
              IIV = sd(PosAff, na.rm = TRUE),
              IIM = mean(PosAff, na.rm = TRUE)),
          by = UserID])

为了进行比较，我们展示了贝叶斯模型的结果，并计算了使用平均 IIV 估计值的模型、原始 ISD 模型和将其视为多重估算的模型的回归系数和置信区间。通过比较这些不同的模型，我们可以看到，虽然它们都不完全匹配，但贝叶斯模型的结果更接近，并将估计值视为多重估算值。

## Bayesian Results
param_summary(mcmc.samples$YB[, 1]) ## intercept

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1  1.1    1.1 0.14  0.87    1.4  < .001

param_summary(mcmc.samples$Yalpha[, 1]) ## IIV

##   Mean Median   SE LL2.5 UL97.5 p-value
## 1 0.57   0.57 0.19  0.19   0.95    .002

param_summary(mcmc.samples$Yalpha[, 2]) ## IIM

##    Mean Median   SE LL2.5 UL97.5 p-value
## 1 -0.22  -0.22 0.04 -0.31  -0.15  < .001

## using averages only
cbind(B = coef(avg_model), confint(avg_model))

##                 B 2.5 % 97.5 %
## (Intercept)  1.05  0.79   1.31
## IIV          0.71  0.35   1.08
## IIM         -0.23 -0.31  -0.16

## using raw ISDs
cbind(B = coef(raw_model), confint(raw_model))

##                 B 2.5 % 97.5 %
## (Intercept)  1.82  1.52   2.11
## IIV          0.46  0.15   0.77
## IIM         -0.22 -0.29  -0.14

## treating as multiply imputed
summary(ind_model_pooled, conf.int = TRUE)

##             estimate std.error statistic  df p.value 2.5 % 97.5 %
## (Intercept)     1.14      0.14       8.2 129 5.3e-14  0.87   1.42
## IIV             0.58      0.19       3.0 127 3.0e-03  0.20   0.96
## IIM            -0.22      0.04      -5.6 175 7.2e-08 -0.30  -0.15

这些例子显示了贝叶斯方法如何帮助估计生命年。此外，他们强调了因计算原始 ISDs 或因将 IIV 估计视为无误差测量而产生的偏差。这些结果更加引人注目，因为每个参与者平均有 30 多个积极情感评估可用。因此，与只有 5 或 14 项评估相比，ISDs 的可靠性要高得多。然而，每个模型的估计值和不确定性估计值存在很大差异，只有单步贝叶斯解决方案和将 IIV 估计值视为多重估算的解决方案产生了相当接近的结果。

13.3 摘要

这一章介绍了个体内部可变性(IIV)的概念，以及 IIV 如何能够提供关于重复测量的额外维度的信息。本章总结了计算单个标准差的局限性和量化 IIV 的其他简单方法。它还引入了贝叶斯可变性模型(BVM ),该模型使用混合效应模型来控制任何感兴趣的变量，如时间效应和时间依赖性，并根据残差计算 iiv。通过在贝叶斯框架中一步完成，BVM 可以适应 IIV 估计中的不确定性，这减少了结果中的偏差，并提供了更准确的统计推断。本章中使用的功能汇总在表 13-1 中。

表 13-1

本章中描述的关键功能列表及其功能摘要

|

功能

|

它的作用

|
| --- | --- |
| sd() | 返回样本数据的标准偏差 |
| rmssd() | 返回样本数据连续差的均方根 |
| varian() | 基于在贝叶斯框架中估计的位置尺度混合效应模型来估计贝叶斯可变性模型。可用于使个体间变异(iiv)预测其他结果，或简单地估计 iiv，说明测量误差并提取它们 |
| vm_diagnostics() | 使用varian()函数估计的贝叶斯可变性模型的绘图诊断 |
| extract() | 提取马尔可夫链蒙特卡罗样本，用于绘图、汇总或在其他模型中使用 |
| vmp_plot() | 从贝叶斯可变性模型中绘制参数，以查看其单独和联合分布 |
| param_summary() | 根据贝叶斯变异性模型创建参数摘要，包括平均值、中值、可信区间和经验 p 值 |
| as.mira() | 将模型结果列表转换为多重估算对象类，以允许将模型汇集在一起。当提取多个 IIV 估计值并将其视为多个估算值时，在 IIV 分析中使用 |
| pool() | 不同多重估算数据集上重复的一系列分析的池模型结果 |*

posted @ 2024-10-02 03:52  绝不原创的飞龙  阅读(295)  评论(0)    收藏  举报