如何迭代训练预测模型(GAM，MARS，.)根据选定的天数计算时间段内的变量重要性。

Question

我有一个数据表，它总是有不同的列数和列名，还有一个名为days的数值变量(这个变量也不同；现在/这里: 50)：

library(data.table)
library(caret)

days -> 50  
## Create random data table: ##
dt.train <- data.table(date = seq(as.Date('2020-01-01'), by = '1 day', length.out = 366),
                       "DE" = rnorm(366, 35, 1), "Wind" = rnorm(366, 5000, 2), "Solar" = rnorm(366, 3, 2),
                       "Nuclear" = rnorm(366, 100, 5), "ResLoad" = rnorm(366, 200, 3),  check.names = FALSE)

我正在建模/训练一个线性模型(= LM)，在这里我想预测DE列，并计算相对于days变量的变量重要性。请参见以下代码片段：

## MODEL FITTING: ##
## Linear Model: ##

## Function that calculates the iteratively prediction: ##
calcPred <- function(data){
  ## Model fitting: ##
  xgbModel <- stats::lm(DE ~ .-1-date, data = data)
  ## Model training: ##
  stats::predict.lm(xgbModel, data)
}

## Function that calculates the iteratively variable importance: ##
varImportance <- function(data){
  ## Model fitting: ##
  xgbModel <- stats::lm(DE ~ .-1-date, data = data)
  
  terms <- attr(xgbModel$terms , "term.labels")
  varimp <- caret::varImp(xgbModel)
  importance <- data[, .(date, imp = t(varimp))]
} 


## Train Data PREDICTION with iteratively xgbModel: ##
dt.train <- dt.train[, c('prediction') := calcPred(.SD), by = seq_len(nrow(dt.train)) %/% days]

## Iteratively variable importance:##
dt.importance <- data.table::copy(dt.train[, c("prediction") := NULL])
dt.importance <- dt.importance[, varImportance(.SD), by = seq_len(nrow(dt.train)) %/% days]

这里发生的事情:我的模型总是训练50天，然后准确地说，在这段时间里，有一个预测，这些训练的50天完成。一直持续到我桌子的结束日期。此外，varImportance()函数给出了训练间隔中预测器(所有列，不包括date和DE)的变量重要性(此处为每50天)。

最初，我认为我可以使用函数calcPred()和varImportance()，用于广义加法模型(= GAM)和多变量自适应回归样条(= MARS)或梯度增强(= GB)，但不幸的是，这个版本只适用于LM。

我现在想简单地描述一下适合于其他三种模型的模型，但我也需要你的帮助，以便最终计算出GAM、MARS和GB模型以及LM。

GAM:

## Create data-vector with dates of dt.train: ##
v.trainDate <- dt.train$date
## Delete column "date" of train data for model fitting: ##
dt.train <- dt.train[, c("date") := NULL]

## Preparation for GAM: ##
trainDataNames <- names(dt.train)
responseVar <- trainDataNames[1]
trainDataNames <- trainDataNames[trainDataNames != responseVar]
## Create right-hand side of GAM model in string/character format: ##
formulaRight <- paste('s(', trainDataNames, ')', sep = '', collapse = ' + ')
## Create the whole formula for GAM model in string/character format: ##
formulaGAM <- paste(responseVar, '~', formulaRight, collapse = ' ')
## Coerce to a formula object: ##
formulaGAM <- as.formula(formulaGAM)

## MODEL FITTING: ##
## Generalized Additive Model: ##
xgbModel <- mgcv::gam(formulaGAM, data = dt.train)

## Train and Test Data PREDICTION with xgbModel: ##
dt.train$prediction <- mgcv::predict.gam(xgbModel, dt.train)

## Add date columns to dt.train and dt.test: ##
dt.train <- data.table(date = v.trainDate, dt.train)

火星：

## Create vectors with all DE values of train data set: ##
v.trainY <- dt.train$DE
## Save dates of train data in an extra vector: ##
v.trainDate <- dt.train$date
## Create train matrices for GB model fitting: ##
m.trainData <- as.matrix(dt.train[, c("date", "DE") := list(NULL, NULL)])
## Model fitting with grid-search: ##: ##
hyper_grid <- expand.grid(degree = 1:3, 
                          nprune = seq(2, 100, length.out = 10) %>% floor()
              )
              
## MODEL FITTING: ##
## Multivariate Adaptive Regression Spline: ##
xgbModel <- caret::train(x = m.trainData, 
                         y = v.trainY,
                         method = "earth",
                         metric = "RMSE",
                         trControl = trainControl(method = "cv", number = 10),
                                       tuneGrid = hyper_grid
              )
              
              
## Train Data PREDICTION with xgbModel: ##
dt.train$prediction <- stats::predict(xgbModel, dt.train)

GB:

## Create vectors with all DE values of train data set: ##
v.trainY <- dt.train$DE
## Save dates of train data in an extra vector: ##
v.trainDate <- dt.train$date
## Create train matrices for GB model fitting: ##
m.trainData <- as.matrix(dt.train[, c("date", "DE") := list(NULL, NULL)])

## Gradient Boosting with hyper parameter tuning: ##
xgb_trcontrol <- caret::trainControl(method = "cv",
                                     number = 3,
                                     allowParallel = TRUE,
                                     verboseIter = TRUE,
                                     returnData = FALSE
)

xgbgrid <- base::expand.grid(nrounds = c(15000), # 15000
                             max_depth = c(2),
                             eta = c(0.01),
                             gamma = c(1),
                             colsample_bytree = c(1),
                             min_child_weight = c(2),
                             subsample = c(0.6)
)

## MODEL FITTING: ##
## Gradient Boosting: ##
xgbModel <- caret::train(x = m.trainData, 
                         y = v.trainY,
                         trControl = xgb_trcontrol,
                         tuneGrid = xgbgrid,
                         method = "xgbTree"
)

## Train data PREDICTION with xgbModel: ##
dt.train$prediction <- stats::predict(xgbModel, m.trainData)

## Add DE and date columns to dt.train: ##
dt.train <- data.table(DE = v.trainY, dt.train)
dt.train <- data.table(date = v.trainDate, dt.train)

，我怎么计算其他三种模型和LM?一样，我希望有人能帮我。很抱歉这个问题提得太久了。

Answer 1

您可以将模型定义为作为参数传递给calcPred和varImportance的函数。

例如，使用LM

model <- function(data) {stats::lm(DE ~ .-1-date, data = data)}

用GAM

model <- function(data) {mgcv::gam(formulaGAM, data = data)}

用MARS

model <- function(data) {
  hyper_grid <- expand.grid(degree = 1:3, 
                            nprune = seq(2, 100, length.out = 10) %>% floor())
  caret::train(x = subset(data, select = -DE),
               y = data$DE,
               method = "earth",
               metric = "RMSE",
               trControl = trainControl(method = "cv", number = 10),
               tuneGrid = hyper_grid)
}

我更新了代码以考虑到这个新的论点：

library(data.table)
library(caret)
library(magrittr)


days <- 50
## Create random data table: ##
dt.train <- data.table(date = seq(as.Date('2020-01-01'), by = '1 day', length.out = 366),
                       "DE" = rnorm(366, 35, 1), "Wind" = rnorm(366, 5000, 2), "Solar" = rnorm(366, 3, 2),
                       "Nuclear" = rnorm(366, 100, 5), "ResLoad" = rnorm(366, 200, 3),  check.names = FALSE)

dt.importance <- data.table::copy(dt.train)

## Define model & prediction functions ##

model <- function(data) {stats::lm(DE ~ .-1-date, data = data)}

predict <- function(data,model) {stats::predict(model, data)}

calcPred <- function(data,model){
  if (nrow(data)==days) {
  stats::predict(model,data) } else {
  NULL }
}

## Function that calculates the iteratively variable importance: ##
varImportance <- function(data,model){
  cat(nrow(data),'\n')
  if (nrow(data)==days) {
  terms <- attr(model$terms , "term.labels")
  varimp <- caret::varImp(model)
  importance <- data[, .(date, imp = t(varimp))]} else
  { NULL }
}


## Train Data PREDICTION with iteratively xgbModel: ##
dt.train <- dt.train[, c('prediction') := calcPred(.SD,model(.SD)), by = (seq_len(nrow(dt.train))-1) %/% days]

## Iteratively variable importance:##

dt.importance <- dt.importance[, varImportance(.SD,model(.SD)), by = (seq_len(nrow(dt.train))-1) %/% days]

要使用其他模型，只需在上面的代码中使用您希望的模型函数。这适用于您提供的数据集上的LM或GAM。

不幸的是，varImp似乎不能在您的数据集上使用MARS，尽管这个似乎是可行的。