R插入符号保留样本和测试集ROC
R caret held-out sample and testing set ROC
我正在构建两个不同的分类器来预测二元结果。然后我想通过使用ROC曲线及其下的面积（AUC）来比较两个模型的结果。
我将数据集拆分为训练集和测试集。在训练集上，我执行了一种交叉验证形式。从交叉验证的保留样本中，我能够为每个模型构建一条 ROC 曲线。然后我在测试集上使用模型并构建另一组 ROC 曲线。
结果是矛盾的，这让我很困惑。我不确定哪个结果是正确的，或者我是否做错了什么。保留样本ROC曲线表明RF是更好的模型，训练集ROC曲线表明SVM是更好的模型。
分析
library(ggplot2)
library(caret)
library(pROC)
library(ggthemes)
library(plyr)
library(ROCR)
library(reshape2)
library(gridExtra)
my_data <- read.csv("http://www.ats.ucla.edu/stat/data/binary.csv")
str(my_data)
names(my_data)[1] <- "Class"
my_data$Class <- ifelse(my_data$Class == 1, "event", "noevent")
my_data$Class <- factor(emr$Class, levels = c("noevent", "event"), ordered = TRUE)
set.seed(1732)
ind <- createDataPartition(my_data$Class, p = 2/3, list = FALSE)
train <- my_data[ ind,]
test <- my_data[-ind,]
接下来我训练两个模型：随机森林和SVM。在这里，我还使用 Max Kuhns 函数从两个模型的保留样本中获取平均 ROC 曲线，并将这些结果与曲线中的 AUC 一起保存到另一个 data.frame 中。
#Train RF
ctrl <- trainControl(method = "repeatedcv",
number = 5,
repeats = 3,
classProbs = TRUE,
savePredictions = TRUE,
summaryFunction = twoClassSummary)
grid <- data.frame(mtry = seq(1,3,1))
set.seed(1537)
rf_mod <- train(Class ~ .,
data = train,
method = "rf",
metric = "ROC",
tuneGrid = grid,
ntree = 1000,
trControl = ctrl)
rfClasses <- predict(rf_mod, test)
#This is the ROC curve from held out samples. Source is from Max Kuhns 2016 UseR! code here: https://github.com/topepo/useR2016
roc_train <- function(object, best_only = TRUE, ...) {
lvs <- object$modelInfo$levels(object$finalModel)
if(best_only) {
object$pred <- merge(object$pred, object$bestTune)
}
## find tuning parameter names
p_names <- as.character(object$modelInfo$parameters$parameter)
p_combos <- object$pred[, p_names, drop = FALSE]
## average probabilities across resamples
object$pred <- plyr::ddply(.data = object$pred,
.variables = c("obs", "rowIndex", p_names),
.fun = function(dat, lvls = lvs) {
out <- mean(dat[, lvls[1]])
names(out) <- lvls[1]
out
})
make_roc <- function(x, lvls = lvs, nms = NULL, ...) {
out <- pROC::roc(response = x$obs,
predictor = x[, lvls[1]],
levels = rev(lvls))
out$model_param <- x[1,nms,drop = FALSE]
out
}
out <- plyr::dlply(.data = object$pred,
.variables = p_names,
.fun = make_roc,
lvls = lvs,
nms = p_names)
if(length(out) == 1) out <- out[[1]]
out
}
temp <- roc_train(rf_mod)
plot_data_ROC <- data.frame(Model='Random Forest', sens = temp$sensitivities, spec=1-temp$specificities)
#This is the AUC of the held-out samples roc curve for RF
auc.1 <- abs(sum(diff(1-temp$specificities) * (head(temp$sensitivities,-1)+tail(temp$sensitivities,-1)))/2)
#Build SVM
set.seed(1537)
svm_mod <- train(Class ~ .,
data = train,
method = "svmRadial",
metric = "ROC",
trControl = ctrl)
svmClasses <- predict(svm_mod, test)
#ROC curve into df
temp <- roc_train(svm_mod)
plot_data_ROC <- rbind(plot_data_ROC, data.frame(Model='Support Vector Machine', sens = temp$sensitivities, spec=1-temp$specificities))
#This is the AUC of the held-out samples roc curve for SVM
auc.2 <- abs(sum(diff(1-temp$specificities) * (head(temp$sensitivities,-1)+tail(temp$sensitivities,-1)))/2)
接下来我将绘制结果
#Plotting Final
#ROC of held-out samples
q <- ggplot(data=plot_data_ROC, aes(x=spec, y=sens, group = Model, colour = Model))
q <- q + geom_path() + geom_abline(intercept = 0, slope = 1) + xlab("False Positive Rate (1-Specificity)") + ylab("True Positive Rate (Sensitivity)")
q + theme(axis.line = element_line(), axis.text=element_text(color='black'),
axis.title = element_text(colour = 'black'), legend.text=element_text(), legend.title=element_text())
#ROC of testing set
rf.probs <- predict(rf_mod, test,type="prob")
pr <- prediction(rf.probs$event, factor(test$Class, levels = c("noevent", "event"), ordered = TRUE))
pe <- performance(pr, "tpr", "fpr")
roc.data <- data.frame(Model='Random Forest',fpr=unlist(pe@x.values), tpr=unlist(pe@y.values))
svm.probs <- predict(svm_mod, test,type="prob")
pr <- prediction(svm.probs$event, factor(test$Class, levels = c("noevent", "event"), ordered = TRUE))
pe <- performance(pr, "tpr", "fpr")
roc.data <- rbind(roc.data, data.frame(Model='Support Vector Machine',fpr=unlist(pe@x.values), tpr=unlist(pe@y.values)))
q <- ggplot(data=roc.data, aes(x=fpr, y=tpr, group = Model, colour = Model))
q <- q + geom_line() + geom_abline(intercept = 0, slope = 1) + xlab("False Positive Rate (1-Specificity)") + ylab("True Positive Rate (Sensitivity)")
q + theme(axis.line = element_line(), axis.text=element_text(color='black'),
axis.title = element_text(colour = 'black'), legend.text=element_text(), legend.title=element_text())
#AUC of hold out samples
data.frame(Rf = auc.1, Svm = auc.2)
#AUC of testing set. Source is from Max Kuhns 2016 UseR! code here: https://github.com/topepo/useR2016
test_pred <- data.frame(Class = factor(test$Class, levels = c("noevent", "event"), ordered = TRUE))
test_pred$Rf <- predict(rf_mod, test, type = "prob")[, "event"]
test_pred$Svm <- predict(svm_mod, test, type = "prob")[, "event"]
get_auc <- function(pred, ref){
auc(roc(ref, pred, levels = rev(levels(ref))))
}
apply(test_pred[, -1], 2, get_auc, ref = test_pred$Class)
保留样本和测试集的结果完全不同（我知道它们会不同，但相差这么多？）。
Rf Svm
0.656044 0.5983193
Rf Svm
0.6326531 0.6453428
从保留样本中选择 RF 模型，但从测试集中选择 SVM 模型。
选择模型的“正确”或“更好”方法是什么？
我是不是在某个地方犯了一个大错误或者没有正确理解某些事情？
如果我没理解错的话，那么你有 3 个带标签的数据集：
- 培训
- 保留来自训练的 CV 样本
- "Testing" 简历样本
虽然，是的，在保留样本 CV 策略下，您通常会根据保留样本选择模型，但您通常也不会拥有更大的验证数据样本。
显然，如果保留数据集和测试数据集都 (a) 已标记并且 (b) 与训练数据中的正交性水平尽可能接近，那么您将选择基于以样本量较大者为准。
在您的情况下，您所谓的保留样本似乎只是训练中重复的 CV 重采样。在这种情况下，您更有理由更喜欢测试数据集验证的结果。请参阅 Steffen 的相关 note 重复简历。
从理论上讲，随机森林的套袋具有通过 OOB 统计数据进行交叉验证的继承形式，并且在训练阶段进行的 CV 应该会给您一些验证措施。然而，在实践中，通常会观察到缺乏正交性和过度拟合的可能性增加，因为样本来自训练数据本身，并且可能会加强过度拟合的错误。
我可以在一定程度上从理论上解释这一点，除此之外，我只需要告诉你，根据经验，我发现从训练数据计算出的所谓 CV 和 OOB 误差的性能结果可以具有高度误导性，true 在训练期间从未接触过的保留（测试）数据是更好的验证。
您真正的保留样本 是 测试数据集，因为 none 的数据在训练期间使用。使用这些结果。
我正在构建两个不同的分类器来预测二元结果。然后我想通过使用ROC曲线及其下的面积（AUC）来比较两个模型的结果。
我将数据集拆分为训练集和测试集。在训练集上，我执行了一种交叉验证形式。从交叉验证的保留样本中，我能够为每个模型构建一条 ROC 曲线。然后我在测试集上使用模型并构建另一组 ROC 曲线。
结果是矛盾的，这让我很困惑。我不确定哪个结果是正确的，或者我是否做错了什么。保留样本ROC曲线表明RF是更好的模型，训练集ROC曲线表明SVM是更好的模型。
分析
library(ggplot2)
library(caret)
library(pROC)
library(ggthemes)
library(plyr)
library(ROCR)
library(reshape2)
library(gridExtra)
my_data <- read.csv("http://www.ats.ucla.edu/stat/data/binary.csv")
str(my_data)
names(my_data)[1] <- "Class"
my_data$Class <- ifelse(my_data$Class == 1, "event", "noevent")
my_data$Class <- factor(emr$Class, levels = c("noevent", "event"), ordered = TRUE)
set.seed(1732)
ind <- createDataPartition(my_data$Class, p = 2/3, list = FALSE)
train <- my_data[ ind,]
test <- my_data[-ind,]
接下来我训练两个模型：随机森林和SVM。在这里，我还使用 Max Kuhns 函数从两个模型的保留样本中获取平均 ROC 曲线，并将这些结果与曲线中的 AUC 一起保存到另一个 data.frame 中。
#Train RF
ctrl <- trainControl(method = "repeatedcv",
number = 5,
repeats = 3,
classProbs = TRUE,
savePredictions = TRUE,
summaryFunction = twoClassSummary)
grid <- data.frame(mtry = seq(1,3,1))
set.seed(1537)
rf_mod <- train(Class ~ .,
data = train,
method = "rf",
metric = "ROC",
tuneGrid = grid,
ntree = 1000,
trControl = ctrl)
rfClasses <- predict(rf_mod, test)
#This is the ROC curve from held out samples. Source is from Max Kuhns 2016 UseR! code here: https://github.com/topepo/useR2016
roc_train <- function(object, best_only = TRUE, ...) {
lvs <- object$modelInfo$levels(object$finalModel)
if(best_only) {
object$pred <- merge(object$pred, object$bestTune)
}
## find tuning parameter names
p_names <- as.character(object$modelInfo$parameters$parameter)
p_combos <- object$pred[, p_names, drop = FALSE]
## average probabilities across resamples
object$pred <- plyr::ddply(.data = object$pred,
.variables = c("obs", "rowIndex", p_names),
.fun = function(dat, lvls = lvs) {
out <- mean(dat[, lvls[1]])
names(out) <- lvls[1]
out
})
make_roc <- function(x, lvls = lvs, nms = NULL, ...) {
out <- pROC::roc(response = x$obs,
predictor = x[, lvls[1]],
levels = rev(lvls))
out$model_param <- x[1,nms,drop = FALSE]
out
}
out <- plyr::dlply(.data = object$pred,
.variables = p_names,
.fun = make_roc,
lvls = lvs,
nms = p_names)
if(length(out) == 1) out <- out[[1]]
out
}
temp <- roc_train(rf_mod)
plot_data_ROC <- data.frame(Model='Random Forest', sens = temp$sensitivities, spec=1-temp$specificities)
#This is the AUC of the held-out samples roc curve for RF
auc.1 <- abs(sum(diff(1-temp$specificities) * (head(temp$sensitivities,-1)+tail(temp$sensitivities,-1)))/2)
#Build SVM
set.seed(1537)
svm_mod <- train(Class ~ .,
data = train,
method = "svmRadial",
metric = "ROC",
trControl = ctrl)
svmClasses <- predict(svm_mod, test)
#ROC curve into df
temp <- roc_train(svm_mod)
plot_data_ROC <- rbind(plot_data_ROC, data.frame(Model='Support Vector Machine', sens = temp$sensitivities, spec=1-temp$specificities))
#This is the AUC of the held-out samples roc curve for SVM
auc.2 <- abs(sum(diff(1-temp$specificities) * (head(temp$sensitivities,-1)+tail(temp$sensitivities,-1)))/2)
接下来我将绘制结果
#Plotting Final
#ROC of held-out samples
q <- ggplot(data=plot_data_ROC, aes(x=spec, y=sens, group = Model, colour = Model))
q <- q + geom_path() + geom_abline(intercept = 0, slope = 1) + xlab("False Positive Rate (1-Specificity)") + ylab("True Positive Rate (Sensitivity)")
q + theme(axis.line = element_line(), axis.text=element_text(color='black'),
axis.title = element_text(colour = 'black'), legend.text=element_text(), legend.title=element_text())
#ROC of testing set
rf.probs <- predict(rf_mod, test,type="prob")
pr <- prediction(rf.probs$event, factor(test$Class, levels = c("noevent", "event"), ordered = TRUE))
pe <- performance(pr, "tpr", "fpr")
roc.data <- data.frame(Model='Random Forest',fpr=unlist(pe@x.values), tpr=unlist(pe@y.values))
svm.probs <- predict(svm_mod, test,type="prob")
pr <- prediction(svm.probs$event, factor(test$Class, levels = c("noevent", "event"), ordered = TRUE))
pe <- performance(pr, "tpr", "fpr")
roc.data <- rbind(roc.data, data.frame(Model='Support Vector Machine',fpr=unlist(pe@x.values), tpr=unlist(pe@y.values)))
q <- ggplot(data=roc.data, aes(x=fpr, y=tpr, group = Model, colour = Model))
q <- q + geom_line() + geom_abline(intercept = 0, slope = 1) + xlab("False Positive Rate (1-Specificity)") + ylab("True Positive Rate (Sensitivity)")
q + theme(axis.line = element_line(), axis.text=element_text(color='black'),
axis.title = element_text(colour = 'black'), legend.text=element_text(), legend.title=element_text())
#AUC of hold out samples
data.frame(Rf = auc.1, Svm = auc.2)
#AUC of testing set. Source is from Max Kuhns 2016 UseR! code here: https://github.com/topepo/useR2016
test_pred <- data.frame(Class = factor(test$Class, levels = c("noevent", "event"), ordered = TRUE))
test_pred$Rf <- predict(rf_mod, test, type = "prob")[, "event"]
test_pred$Svm <- predict(svm_mod, test, type = "prob")[, "event"]
get_auc <- function(pred, ref){
auc(roc(ref, pred, levels = rev(levels(ref))))
}
apply(test_pred[, -1], 2, get_auc, ref = test_pred$Class)
保留样本和测试集的结果完全不同（我知道它们会不同，但相差这么多？）。
Rf Svm
0.656044 0.5983193
Rf Svm
0.6326531 0.6453428
从保留样本中选择 RF 模型，但从测试集中选择 SVM 模型。
选择模型的“正确”或“更好”方法是什么？ 我是不是在某个地方犯了一个大错误或者没有正确理解某些事情？
如果我没理解错的话，那么你有 3 个带标签的数据集：
- 培训
- 保留来自训练的 CV 样本
- "Testing" 简历样本
虽然，是的，在保留样本 CV 策略下，您通常会根据保留样本选择模型，但您通常也不会拥有更大的验证数据样本。
显然，如果保留数据集和测试数据集都 (a) 已标记并且 (b) 与训练数据中的正交性水平尽可能接近，那么您将选择基于以样本量较大者为准。
在您的情况下，您所谓的保留样本似乎只是训练中重复的 CV 重采样。在这种情况下，您更有理由更喜欢测试数据集验证的结果。请参阅 Steffen 的相关 note 重复简历。
从理论上讲，随机森林的套袋具有通过 OOB 统计数据进行交叉验证的继承形式，并且在训练阶段进行的 CV 应该会给您一些验证措施。然而，在实践中，通常会观察到缺乏正交性和过度拟合的可能性增加，因为样本来自训练数据本身，并且可能会加强过度拟合的错误。
我可以在一定程度上从理论上解释这一点，除此之外，我只需要告诉你，根据经验，我发现从训练数据计算出的所谓 CV 和 OOB 误差的性能结果可以具有高度误导性，true 在训练期间从未接触过的保留（测试）数据是更好的验证。
您真正的保留样本 是 测试数据集，因为 none 的数据在训练期间使用。使用这些结果。