MALLOWS模型平均-R代码
（本文仅做学习记录所用。）
我要用我最后的力气喊出那句：“Hansen大佬！！好人一生平安！！”
文章是Hansen大佬2017年的《NOTES AND COMMENTS LEAST SQUARES MODEL A VERAGING》，代码在大佬个人网页。
4.20更新
每一行后面的注释是我写的，希望没写错，为后面的逻辑回归模型平均做铺垫。
## This R function computes the Mallows Model Average (MMA) and
## the Jackknife Model Average (JMA) least-squares estimates.
##
## written by
## Bruce E. Hansen
## Department of Economics
## University of Wisconsin
##
## Format:
##
## result <- gma(y,x,method,subset)
## result$betahat
##
## Inputs:
## y nx1 dependent variable
## x nxp regressor matrix
## method 1x1 set to 1 for Mallows model average estimates
## set to 2 for Jackknife model average estimates
## subset 1x1 set to 1 for pure nested subsets
## set to 2 for all combinations of subsets
## mxp input the (mxp) selection matrix, where m is
## the number of models
## Example:
## Suppose there are 3 candidate models.
## Model 1: y=beta1*x1+beta2*x2+e
## Model 2: y=beta1*x1+beta3*x3+e
## Model 3: y=beta1*x1+beta2*x2+beta4*x4+e
## Then subset <- matrix(c(1,1,1,1,0,1,0,1,0,0,0,1),3,4)
##
## Outputs:
## betahat px1 parameter estimate
## w mx1 weight vector
## yhat nx1 fitted values
## ehat nx1 fitted residuals
## r2 1x1 R-squared
## cn 1x1 Value of Mallows criterion or Cross-Validation criterion
##
## Note:
## Package "quadprog" is required.
## For pure nested subsets, the regressors columns should be ordered, with the
## intercept first and then in order of relevance.
## For all combinations of subsets, p is less than about 20.
library(quadprog)
gmaN <- function(y,x,method,subset){
y <- as.matrix(y)
x <- as.matrix(x)
s <- as.matrix(subset)
n <- nrow(x) ##n:样本量
p <- ncol(x) ##p:变量数
##########变量选择矩阵的建立########
if ((nrow(s)==1) && (ncol(s)==1)){ ##如果subset的形式是嵌套或不进行变量筛选（全模型平均）
if (subset == 1){ ##如果是纯嵌套模型平均
s <- matrix(1,nrow=p,ncol=p) ##生成（pxp）的矩阵，元素都是1 <-共p个备选模型
s[upper.tri(s)] <- 0 ##矩阵的上三角部分改为0
zero <- matrix(0,nrow=1,ncol=p) ##元素为0的（1xp）的矩阵
s <- rbind(zero,s) ##将zero和s两个矩阵上下拼接 <-变量选择矩阵
}
if (subset == 2){ ##如果是全模型平均
s <- matrix(0,nrow=2^p,ncol=p) ##生成一个（2^p x p）的矩阵，元素都是0 <-共2^p个备选模型
s0 <- matrix(c(1,rep(0,p-1)),1,p) ##生成一个(1xp)的矩阵，[1,1]是1，后面全是0
s1 <- matrix(c(rep(0,p)),1,p) ##生成一个(1xp)的矩阵，元素为0
for (i in 2:2^p){ ##从2:2^p
s1 <- s0 + s1 ##初始化s1，在上一个s1的基础上加了一个s0，利用下面这个
####2进制推动变量选择矩阵的变化
for (j in 1:p){ ##从1:p |
if (s1[1,j] == 2){ ##如果s1[1,j]是2 |<- 2进制机制
s1[1,j+1] <- s1[1,j+1]+1 ##s1[1,j+1]在原来的基础上加1 | 利用这个做变量选择
s1[1,j] <- 0 ##s1[1,j]赋值0 |
}
}
s[i,] <- s1 ##将s1存到s的第i行
}
}
}
#########
m <- nrow(s) ##m是s的行数，备选模型的个数
bbeta <- matrix(0,nrow=p,ncol=m) ##bbeta是（pxm）的矩阵，元素为0 <-所有备选模型的系数
if (method == 2) ee <- matrix(0,nrow=n,ncol=m) ##如果是刀切模型平均，ee是（nxm）矩阵，元素为0
for (j in 1:m){ ##从1:m,遍历每一个备选模型
ss <- matrix(1,nrow=n,ncol=1) %*% s[j,] ##（nx1）元素为1的矩阵 X s[j,]
indx1 <- which(ss[,]==1) ##indx1是被选中变量的索引
xs <- as.matrix(x[indx1]) ##|
xs <- matrix(xs,nrow=n,ncol=nrow(xs)/n) ##|xs是剔除未选中变量的样本矩阵
if (sum(ss)==0){ ##如果备选模型中不含变量
xs <- x ##样本矩阵xs
betas <- matrix(0,nrow=p,ncol=1) ##系数矩阵为(px1)的0矩阵
indx2 <- matrix(c(1:p),nrow=p,ncol=1) ##indx2是一个(px1)的矩阵，元素为1:p
}
if (sum(ss)>0){ ##如果备选模型含有至少一个变量
betas <- solve(t(xs)%*%xs)%*%t(xs)%*%y ##第j个备选模型的估计系数
indx2 <- as.matrix(which(s[j,]==1)) ##indx2是第j个候选模型包含的变量索引
}
beta0 <- matrix(0,nrow=p,ncol=1) ##beta0是(px1)的矩阵，元素为0
beta0[indx2] <- betas ##|将第j个候选模型的系数填入bbeta的第j列
bbeta[,j] <- beta0 ##|
if (method == 2){ ##如果是刀切模型平均
ei <- y - xs %*% betas ##ei是残差
hi <- diag(xs %*% solve(t(xs) %*% xs) %*% t(xs))##hi是pm的n个对角元素
ee[,j] <- ei*(1/(1-hi)) ##第j个备选模型的残差估计ee
}
}
if (method == 1){ ##如果是MMA
ee <- y %*% matrix(1,nrow=1,ncol=m) - x %*% bbeta ##ee是残差矩阵，(nxm)
ehat <- y - x %*% bbeta[,m] ##第m个备选矩阵的残差估计
sighat <- (t(ehat) %*% ehat)/(n-p) ##方差矩阵的估计值
}
a1 <- t(ee) %*% ee ##a1:(n-p)方差矩阵
if (qr(a1)$rank0) ##保留大于0的权重，小于0的记为0
w <- w/sum(w0) ##?????sum(w0)不是1吗???
###########由最佳权重W计算得一堆结果########
betahat <- bbeta %*% w ##估计系数
ybar <- mean(y) ##y的均值
yhat <- x %*% betahat ##y的估计值
ehat <- y-yhat ##残差e的估计值
r2 <- sum((yhat-ybar)^2)/sum((y-ybar)^2) ##R^2
if (method == 1) cn=(t(w) %*% a1 %*% w - 2*t(a2) %*% w)/n ##MMA
if (method == 2) cn=(t(w) %*% a1 %*% w)/n ##JMA
list(betahat=betahat,w=w,yhat=yhat,ehat=ehat,r2=r2,cn=cn) ##显示结果
}
4.20更新
##HANSEN大佬的实验
##文章来源：LEAST SQUARES MODEL AVERAGING
##需要使用的gma函数先运行
#用到的包
library(MASS)
#参数设定
n <- 50 ##c(50,150,400,1000)
alpha <- 0.5 ##c(0.5, 1.0, 1.0)
M <- round(3*n^(1/3))
p <- M
beta <- matrix(1, nrow = p, ncol = 1)
R2 <- seq(0.1,0.9,by=0.1)
c <- ((1-R2)/R2)^(-0.5)
t <- 1000000
method=1;subset=1
result <- matrix(nrow = t+1, ncol = 9)
i=1
a <- matrix(nrow = t+1, ncol = 9)
options(digits = 8)
for(T in 1:t){
for (i in 1:9){
for(j in 1:p){beta[j] <- c[i]*(2*alpha)^0.5*j^(-alpha-0.5)}
x1 <- matrix(1, nrow = n, ncol = 1)
x_sigma <- diag(1,p-1,p-1)
x_mean <- matrix(0, nrow=p-1, ncol = 1)
xp <- mvrnorm(n,x_mean,x_sigma)
x <- cbind(x1,xp)
e <- rnorm(n, 0 ,1)
y <- x%*%beta+e
r <- gmaN(y,x,method,subset)
d <- lm(y~x)$coefficients[2:11]
d[is.na(d)] <- 0
a[T,i] <- t(d-beta)%*%(d-beta)
result[T,i]<-t(r$betahat-beta)%*%(r$betahat-beta)/a[T,i] ##<-这个地方有问题
}
}
for (i in 1:9){
result[t+1,i]<-mean(result[1:t,i])
}
plot(R2,result[t+1,],type = "l")
points(R2,result[t+1,])
实验重复的是文章中的实验第一张图，但是文中说的评价标准是Risk(expected squared error)感觉是我理解有误，图片出来不对，后补。
但是流程是这么个流程没问题。