Question

我想在R中为'beta回归'模型构建回归子集算法。 R中有一个betareg包符合beta回归，我感兴趣的是最大化“对数似然”的模型。

基本上，这是通过选择最佳k因子回归模型，对于k = 1,2，...，p，其中p是你拥有的变量数。

例如，如果我将x_1，x_2，x_3作为我的变量，并将y作为我的响应。我想要做一些事情：

步骤1：找到最佳1因子模型

mod1 <- betareg(y~x_1, data = test)
mod1.sum <- summary(mod1)

mod2 <- betareg(y~x_2, data = test)
mod2.sum <- summary(mod2)

mod3 <- betareg(y~x_3, data = test)
mod3.sum <- summary(mod3)

现在我已经适应了所有模型，我想比较每个模型的对数可能性：

 likelihoods <- c( mod1.sum$loglik, mod2.sum$loglik, mod3.sum$loglik)
which.max(likelihoods)

步骤2：找到添加到最佳1因子模型的最佳因子，假设x_1在上一步中是最好的。然后在这一步中，我们将模型与x_1和x_2进行比较，将模型与x_1和x_3进行比较，选择具有最大对数似然的模型。

步骤3：将最好的两个变量作为给定，找到第三个变量，对对数似然性贡献最大。

步骤4：返回最佳1因子模型，最佳2因子模型，...，最佳p因子模型，包含的因子及其对应的对数似然。

当p很大时，我很难有效地做到这一点，比如40左右。

Answer 1

据我所知，没有专门有效实施β回归的最佳子集选择（在R或其他方面）。然而，存在一些通用实现，其提供近似解决方案，例如，基于遗传算法，例如kofnGA包（在CRAN上并在JSS中发布）。请参阅下面的示例。（要使用转发搜索而不是最佳子集选择，请参阅我的其他答案。）

或者，您可以使用近似betareg所做的（广义）线性模型，并使用子集选择。例如，您可以对响应进行logit转换（即qlogis(y)），然后通过leaps（CRAN）或lmSubsets使用线性回归运行最佳子集选择（ R-Forge）。或者您可以使用family = quasibinomial的GLM并使用glmulti（CRAN，JSS）。然后，您可以使用该近似模型的最佳子集结果，并将其用于beta回归。当然，这不会给你最佳 beta回归结果，但它可能是进一步分析的有用起点。

因此，回到β回归的直接遗传算法。为了说明如何使用kofnGA完成此操作，我们首先加载包和示例数据：

library("betareg")
library("kofnGA")
data("FoodExpenditure", package = "betareg")

然后，我们构建一个包含响应变量y和回归矩阵x的列表。请注意，我们在此处省略了截距，以便稍后将其强制进入模型（即，截距不应受到选择）。

fe_data <- list(
  y = with(FoodExpenditure, food/income),
  x = model.matrix(~ income + persons, data = FoodExpenditure)[, -1]
)

除了上面设置的两个回归量之外，我们现在将40个随机噪声变量添加到回归矩阵

fe_data$x <- cbind(fe_data$x,
  matrix(rnorm(40 * nrow(fe_data$x)), ncol = 40))
colnames(fe_data$x)[3:42] <- paste0("x", 1:40)

现在我们可以使用kofnGA从潜在的42个回归量中选择具有2个回归量的最佳模型（加上总是包含的拦截）。由于kofnGA最小化了一个目标，我们使用betareg提供的负对数似然。使用主力函数betareg.fit而不是betareg来避免不必要的公式解析等。

nll <- function(v, data) -betareg.fit(x = cbind(1, data$x[, v]),
  y = data$y)$loglik

最后，我们将遗传算法运行100代，以节省一些计算时间：

set.seed(1)
ga <- kofnGA(n = 42, k = 2, OF = nll, data = fe_data, ngen = 100)

结果输出

summary(ga)
## Genetic algorithm search, 100 generations
## Number of unique solutions in the final population: 1 
## 
## Objective function values:
##                      average   minimum
## Initial population -36.56597 -41.74583
## Final population   -45.33351 -45.33351
## 
## Best solution (found at generation 1):
## 1 2

因此，在这个非常简单的人工设置中，遗传算法确实选择了前2个回归量（来自真实数据）而不是我们添加的任何无关的随机40回归量。所以我们现在可以继续使用回归器重新构建适当的β回归模型

colnames(fe_data$x)[ga$bestsol]
## [1] "income"  "persons"

等。请注意，此处使用的beta回归仅使用固定的精度参数（带有日志链接）。如果您想要一个可变色散，那么您需要相应地修改nll。

Answer 2

除了我的另一个答案，它显示了如何使用kofnGA进行β回归的最佳子集选择，我还提供了一个如何做转发的示例手动选择。

我们再次开始加载包和数据：

library("betareg")
data("FoodExpenditure", package = "betareg")

我还设置了响应加上所有回归的列表（包括40个随机的回归符。（请注意，与其他我不同的是，我在x保持拦截，这在这里更方便。）

fe_data <- list(
  y = with(FoodExpenditure, food/income),
  x = model.matrix(~ income + persons, data = FoodExpenditure)
)
set.seed(123)
fe_data$x <- cbind(fe_data$x,
  matrix(rnorm(40 * nrow(fe_data$x)), ncol = 40))
colnames(fe_data$x)[4:43] <- paste0("x", 1:40)

然后我们再次为负对数似然设置一个函数（但不需要手动包含截距，因为它仍在x中）。

nll <- function(v, data) -betareg.fit(x = data$x[, v, drop = FALSE],
  y = data$y)$loglik

然后我们存储所有可能的回归量vall的索引，并使用截距（v <- 1）和相应的负对数似然（n）初始化我们的搜索。

vall <- 1:ncol(fe_data$x)
v <- 1
n <- nll(v, data = fe_data)

然后我们迭代前向搜索15次迭代（以避免这个小数据集上的数值不稳定，以获得更多的变量）。我们总是选择最能减少负对数似然性的附加变量：

for(i in 1:15) {
  vi <- vall[-v]
  ni <- sapply(vi, function(vii) nll(v = c(v, vii), data = fe_data))
  v <- c(v, vi[which.min(ni)])
  n <- c(n, ni[which.min(ni)])
}

选择变量的顺序如下。请注意，首先选择实际回归量，然后选择随机噪声回归量。（但尝试set.seed(1)以上将包含随机回归量之前的真实值......）

colnames(fe_data$x)[v]
##  [1] "(Intercept)" "income"      "persons"     "x28"         "x18"        
##  [6] "x29"         "x22"         "x11"         "x5"          "x8"         
## [11] "x38"         "x24"         "x13"         "x23"         "x36"        
## [16] "x16"

负对数似然和相关BIC的相应减少可以看作：

m <- seq_along(v)
plot(m, n, type = "b",
  xlab = "Number of regressors", ylab = "Log-likelihood")
plot(m, n + log(nrow(fe_data$x)) * (m + 1), type = "b",
  xlab = "Number of regressors", ylab = "BIC")

所以这确实会选择三个真正的回归量作为最佳BIC模型的模型。

Answer 3

这是一种不使用betareg的替代解决方案。输出类似，并考虑您的问题。

这是我使用的数据集：

set.seed(12345)
dat <- data.frame(y=runif(50), x_1=runif(50), x_2=runif(50), x_3=runif(50))

使用leaps库创建所有可能组合的列表：

library(leaps)
subs<-regsubsets(y~., data=dat, nbest=10, nvmax=100, really.big=T)
subs<-summary(subs)$which[,-1]
all.mods<-lapply(1:nrow(subs), function(x)paste("y", paste(names(which(subs[x,])), collapse="+"), sep="~"))

all.mods

[[1]]
[1] "y~x_2"

[[2]]
[1] "y~x_1"

[[3]]
[1] "y~x_3"

[[4]]
[1] "y~x_2+x_3"

[[5]]
[1] "y~x_1+x_2"

[[6]]
[1] "y~x_1+x_3"

[[7]]
[1] "y~x_1+x_2+x_3"

对所有模型运行线性回归：

all.lm<-lapply(all.mods, function(x)lm(as.formula(x), data=dat))

检查每个模型的logLikihood：

lapply(all.lm, logLik)

[[1]]
'log Lik.' -7.051835 (df=3)

[[2]]
'log Lik.' -9.288776 (df=3)

[[3]]
'log Lik.' -9.334048 (df=3)

[[4]]
'log Lik.' -6.904604 (df=4)

[[5]]
'log Lik.' -7.051584 (df=4)

[[6]]
'log Lik.' -9.215915 (df=4)

[[7]]
'log Lik.' -6.888849 (df=5)

R

3 个答案: