summaryFunction 插入符号分类的自定义指标 (hmeasure)

Question

我正在尝试使用 hmeasure 指标 Hand,2009 作为我在插入符号中训练 SVM 的自定义指标。由于我对使用 R 比较陌生，因此我尝试调整 twoClassSummary 函数。我所需要的只是将模型（svm）中的真实类标签和预测的类概率传递给 hmeasure 包中的 HMeasure 函数，而不是使用 ROC 或插入符号中的其他分类性能度量。

例如，调用 R 中的 HMeasure 函数 - HMeasure(true.class,predictedProbs[,2])- 会导致计算 Hmeasure。使用以下 twoClassSummary 代码的改编会导致返回错误：“x”必须是数字。

也许该 train 函数无法“看到”评估 HMeasure 函数的预测概率。我怎样才能解决这个问题？

我已阅读文档，并链接了在 SO dealing with regression 上提出的问题。这让我有点办法。我将不胜感激任何有关解决方案的帮助或指示。

library(caret)
library(doMC)
library(hmeasure)
library(mlbench)

set.seed(825)

data(Sonar)
table(Sonar$Class) 
inTraining <- createDataPartition(Sonar$Class, p = 0.75, list = FALSE)
training <- Sonar[inTraining, ]
testing <- Sonar[-inTraining, ]


# using caret
fitControl <- trainControl(method = "repeatedcv",number = 2,repeats=2,summaryFunction=twoClassSummary,classProbs=TRUE)

svmFit1 <- train(Class ~ ., data = training,method = "svmRadial",trControl =    fitControl,preProc = c("center", "scale"),tuneLength = 8,metric = "ROC")

predictedProbs <- predict(svmFit1, newdata = testing , type = "prob")
true.class<-testing$Class
hmeas<- HMeasure(true.class,predictedProbs[,2]) # suppose its Rocks we're interested in predicting
hmeasure.probs<-hmeas$metrics[c('H')] # returns the H measure metric 

hmeasureCaret<-function (data, lev = NULL, model = NULL,...) 
{ 
# adaptation of twoClassSummary
require(hmeasure)
if (!all(levels(data[, "pred"]) == levels(data[, "obs"]))) 
 stop("levels of observed and predicted data do not match")
#lev is a character string that has the outcome factor levels taken from the training   data
hObject <- try(hmeasure::HMeasure(data$obs, data[, lev[1]]),silent=TRUE)
hmeasH <- if (class(hObject)[1] == "try-error") {
NA
} else {hObject$metrics[[1]]  #hObject$metrics[c('H')] returns a dataframe, need to    return a vector 
}
out<-hmeasH 
names(out) <- c("Hmeas")
#class(out)
}
environment(hmeasureCaret) <- asNamespace('caret')

下面的非工作代码。

ctrl <- trainControl(method = "cv", summaryFunction = hmeasureCaret,classProbs=TRUE,allowParallel = TRUE,
                  verboseIter=TRUE,returnData=FALSE,savePredictions=FALSE)
set.seed(1)

svmTune <- train(Class.f ~ ., data = training,method = "svmRadial",trControl =    ctrl,preProc = c("center", "scale"),tuneLength = 8,metric="Hmeas",
              verbose = FALSE)

Answer 1

此代码有效。我正在发布一个解决方案，以防其他人想要使用/改进它。 问题是由于 Hmeasure 对象的不正确引用和函数返回值的拼写错误/注释引起的。

library(caret)
library(doMC)
library(hmeasure)
library(mlbench)

set.seed(825)
registerDoMC(cores = 4)

data(Sonar)
table(Sonar$Class) 

inTraining <- createDataPartition(Sonar$Class, p = 0.5, list = FALSE)
training <- Sonar[inTraining, ]
testing <- Sonar[-inTraining, ]

hmeasureCaret<-function (data, lev = NULL, model = NULL,...) 
{ 
  # adaptation of twoClassSummary
  require(hmeasure)
  if (!all(levels(data[, "pred"]) == levels(data[, "obs"]))) 
    stop("levels of observed and predicted data do not match")
  hObject <- try(hmeasure::HMeasure(data$obs, data[, lev[1]]),silent=TRUE)
  hmeasH <- if (class(hObject)[1] == "try-error") {
    NA
  } else {hObject$metrics[[1]]  #hObject$metrics[c('H')] returns a dataframe, need to return a vector 
  }
  out<-hmeasH 
  names(out) <- c("Hmeas")
  out 
}
#environment(hmeasureCaret) <- asNamespace('caret')


ctrl <- trainControl(method = "repeatedcv",number = 10, repeats = 5, summaryFunction = hmeasureCaret,classProbs=TRUE,allowParallel = TRUE,
                     verboseIter=FALSE,returnData=FALSE,savePredictions=FALSE)
set.seed(123)

svmTune <- train(Class ~ ., data = training,method = "svmRadial",trControl = ctrl,preProc = c("center", "scale"),tuneLength = 15,metric="Hmeas",
                 verbose = FALSE)
svmTune

predictedProbs <- predict(svmTune, newdata = testing , type = "prob")

true.class<-testing$Class

hmeas.check<- HMeasure(true.class,predictedProbs[,2])

summary(hmeas.check)