复制套索模拟示例1

时间:2018-10-09 07:03:19

标签: r simulation lasso

我想在页面280上的原始lasso paper中复制示例1的结果。

  • 模型为y = X*beta + sigma*epsilon,其中epsilonN(0,1)
  • 模拟50个数据集,其中包括20/20/200个观测值 培训/验证/测试集。
  • True beta = (3, 1.5, 0, 0, 2, 0, 0, 0)
  • sigma = 3
  • x_ix_j之间的对数相关性设置为corr(i,j) = 0.5^|i-j|

    我使用了训练,验证,测试拆分方法来找到test MSE的估计值。我尝试手动计算一些test MSE估算值,以检查模拟重复之前是否在正确的方向上。但是我发现test MSE的估算值(在[9,15] 之间)似乎比原始论文给出的估算值(中位数 2.43 )要大得多。我附加了用于生成test MSE的代码。

有什么建议吗?

    library(MASS)
    library(glmnet)

    simfun <- function(trainn = 20, validationn = 20, testn = 200, corr =0.5, sigma = 3, beta) { 


      n <- trainn + testn + validationn
      p <- length(beta)
      Covmatrix <- outer(1:p, 1:p, function(x,y){corr^abs(x-y)})
      X <- mvrnorm(n, rep(0,p), Covmatrix) # MASS
      X <- X[sample(n),]
      y <- X%*%beta + rnorm(n,mean = 0,sd=sigma)
      trainx <- X[1:trainn,]
      validationx <- X[(trainn+1):(trainn+validationn),]
      testx <- X[(trainn+validationn+1):n,]
      trainy <- y[1:trainn,]
      validationy <- y[(trainn+1):(trainn+validationn),]
      testy <- y[(trainn+validationn+1):n,]
      list(trainx = trainx, validationx = validationx, testx = testx, 
           trainy = trainy, validationy = validationy, testy = testy)
    }

    beta <- c(3,1.5,0,0,2,0,0,0)
    data <- simfun(20,20,200,corr=0.5,sigma=3,beta)
    trainx <- data$trainx
    trainy <- data$trainy
    validationx <- data$validationx
    validationy <- data$validationy
    testx <- data$testx
    testy <- data$testy


    # training: find betas for all the lambdas
    betas <- coef(glmnet(trainx,trainy,alpha=1))

    # validation: compute validation test error for each lambda and find the minimum
    J.val <- colMeans((validationy-cbind(1,validationx)%*%betas)^2)
    beta.opt <- betas[, which.min(J.val)]

    # test
    test.mse <- mean((testy-cbind(1,testx)%*%beta.opt)^2)
    test.mse

1 个答案:

答案 0 :(得分:1)

这是模拟研究,因此我认为您不必使用训练验证方法。由于其随机性,它只会引起变化。您可以使用其定义实现预期的测试错误

  1. 构建后生成多个训练数据集
  2. 生成独立的测试集
  3. 根据每个训练集调整每个模型
  4. 针对测试集计算错误
  5. 取平均值

    set.seed(1)
    simpfun <- function(n_train = 20, n_test = 10, simul = 50, corr = .5, sigma = 3, beta = c(3, 1.5, 0, 0, 2, 0, 0, 0), lam_grid = 10^seq(-3, 5)) {
      require(foreach)
      require(tidyverse)
      # true model
      p <- length(beta)
      Covmatrix <- outer(
        1:p, 1:p,
        function(x, y) {
          corr^abs(x - y)
        }
      )
      X <- foreach(i = 1:simul, .combine = rbind) %do% {
        MASS::mvrnorm(n_train, rep(0, p), Covmatrix)
      }
      eps <- rnorm(n_train, mean = 0, sd = sigma)
      y <- X %*% beta + eps # generate true model
      # generate test set
      test <- MASS::mvrnorm(n_test, rep(0, p), Covmatrix)
      te_y <- test %*% beta + rnorm(n_test, mean = 0, sd = sigma) # test y
      simul_id <- gl(simul, k = n_train, labels = 1:n_train)
      # expected test error
      train <-
        y %>%
        as_tibble() %>%
        mutate(m_id = simul_id) %>%
        group_by(m_id) %>% # for each simulation
        do(yhat = predict(glmnet::cv.glmnet(X, y, alpha = 1, lambda = lam_grid), newx = test, s = "lambda.min")) # choose the smallest lambda
      MSE <- # (y0 - fhat0)^2
        sapply(train$yhat, function(x) {
          mean((x - te_y)^2)
        })
      mean(MSE) # 1/simul * MSE
    }
    simpfun()
    

编辑:用于调整参数,

    find_lambda <- function(.data, x, y, lambda, x_val, y_val) {
      .data %>%
        do(
          tuning = predict(glmnet::glmnet(x, y, alpha = 1, lambda = lambda), newx = x_val)
        ) %>%
        do( # tuning parameter: validation set
          mse = apply(.$tuning, 2, function(yhat, y) {
            mean((y - yhat)^2)
          }, y = y_val)
        ) %>%
        mutate(mse_min = min(mse)) %>%
        mutate(lam_choose = lambda[mse == mse_min]) # minimize mse
    }

使用此功能,可以添加验证步骤

    simpfun <- function(n_train = 20, n_val = 20, n_test = 10, simul = 50, corr = .5, sigma = 3, beta = c(3, 1.5, 0, 0, 2, 0, 0, 0), lam_grid = 10^seq(10, -1, length.out = 100)) {
    require(foreach)
    require(tidyverse)
    # true model
    p <- length(beta)
    Covmatrix <- outer(
      1:p, 1:p,
      function(x, y) {
        corr^abs(x - y)
      }
    )
    X <- foreach(i = 1:simul, .combine = rbind) %do% {
      MASS::mvrnorm(n_train, rep(0, p), Covmatrix)
    }
    eps <- rnorm(n_train, mean = 0, sd = sigma)
    y <- X %*% beta + eps # generate true model
    # generate validation set
    val <- MASS::mvrnorm(n_val, rep(0, p), Covmatrix)
    val_y <- val %*% beta + rnorm(n_val, mean = 0, sd = sigma) # validation y
    # generate test set
    test <- MASS::mvrnorm(n_test, rep(0, p), Covmatrix)
    te_y <- test %*% beta + rnorm(n_test, mean = 0, sd = sigma) # test y
    simul_id <- gl(simul, k = n_train, labels = 1:n_train)

    Y <-
      y %>%
      as_tibble() %>%
      mutate(m_id = simul_id) %>%
      group_by(m_id) %>% # for each simulation: repeat
      rename(y = V1)

    # Tuning parameter
    Tuning <-
      Y %>%
      find_lambda(x = X, y = y, lambda = lam_grid, x_val = val, y_val = val_y)

    # expected test error
    test_mse <-
      Tuning %>%
      mutate(
        test_err = mean(
          (predict(glmnet::glmnet(X, y, alpha = 1, lambda = lam_choose), newx = test) - te_y)^2
        )
      ) %>%
      select(test_err) %>%
      pull()
    mean(test_mse)
  }
  simpfun()