r语言XGBoost

library(xgboost)


library(tidyverse)
library(skimr)
library(DataExplorer)
library(caret)
library(pROC)


cPriceData <- read.csv(file.choose()) 

set.seed(42)
trains <- createDataPartition(
  y = cPriceData$price,
  p = 0.85,
  list = F,
  times = 1
)

trains2 <- sample(trains, nrow(cPriceData)*0.7)
valids <- setdiff(trains, trains2)

data_train <- cPriceData[trains2, ]
data_valid <- cPriceData[valids, ]
data_test <- cPriceData[-trains, ]

#训练集
dvfunc <- dummyVars(~., data = data_train[, 1:5], fullRank = T)
data_trainx <- predict(dvfunc, newdata = data_train[, 1:5])
data_trainy <- data_train$price
 
data_validx <- predict(dvfunc, newdata = data_valid[, 1:5])
data_validy <- data_valid$price

data_testx <- predict(dvfunc, newdata = data_test[, 1:5])
data_testy <- data_test$price

dtrain <- xgb.DMatrix(data = data_trainx, label = data_trainy)
dvalid <- xgb.DMatrix(data = data_validx, label = data_validy)
dtest <- xgb.DMatrix(data = data_testx, label = data_testy)
watchlist <- list(train = dtrain, test = dvalid)


fit_xgb_reg <- xgb.train(
  data = dtrain,
  eta = 0.3,
  gamma = 0.001,
  max_depth = 2,
  subsample = 0.7,
  colsample_bytree = 0.4,
  objective = "reg:squarederror",
  
  nrounds = 1000,
  watchlist = watchlist,
  verbose = 1,
  print_every_n = 100,
  early_stopping_rounds = 200
)


fit_xgb_reg


importance_matrix <- xgb.importance(model = fit_xgb_reg)
print(importance_matrix)
xgb.plot.importance(importance_matrix = importance_matrix,
                    measure = "Cover")


xgb.plot.shap(data = data_trainx, 
              model = fit_xgb_reg,
              top_n = 5)

#训练集合预测结果
trainpred <- predict(fit_xgb_reg,
                     newdata = dtrain)

defaultSummary(data.frame(obs = data_train$price,
                          pred = trainpred))


plot(
  x = data_train$price,
  y = trainpred,
  xlab = "Actrue",
  ylab = "Predction",
  main = "实际值与预测值比较",
  sub = "训练集"
)

trainlinmod <- lm(trainpred ~ data_train$price)
abline(trainlinmod, col = "blue", lwd = 2.5, lty = "solid")
abline(a = 0, b = 1, col = "red",lwd = 0.25, lty = "dashed")



#测试集预测结果
testpred <- predict(
  fit_xgb_reg,
  newdata = dtest
)

defaultSummary(
  data.frame(
    obs = data_test$price,
    pred = testpred
  )
)

plot(
  x = data_test$price,
  y = testpred,
  xlab = "Actrue",
  ylab = "Predction",
  main = "实际值与预测值比较",
  sub = "测试集"
)
testlinmod <- lm(testpred ~ data_test$price)
abline(testlinmod, col = "blue", lwd = 2.5, lty = "solid")
abline(a = 0, b = 1, col = "red", lwd = 2.5, lty = "dashed")




predresult <- 
  data.frame(
    obs = c(data_train$price, data_test$price),
    pred = c(trainpred, testpred),
    group = c(rep("Train",length(trainpred)),
              rep("Test",length(testpred)))
  )

ggplot(
  predresult,
  aes(x = obs, y = pred, fill = group, colour = group)
) + geom_point(shape = 21, size = 3) +
  geom_smooth(method = "lm", se = F) +
  geom_abline(intercept = 0, slope = 1) +
  labs(fill = NULL, colour = NULL,
       x = "实际值", y = "预测值",
       title = "XGBoost实际值与预测试比较") +
  theme_classic()+
  theme(legend.position = "bottom",
        plot.title = element_text(hjust = 0.5))