Пользовательская метрика (hmeasure) для сводки Классификация функций каретки

Я пытаюсь использовать метрику hmeasure Hand, 2009 в качестве настраиваемой метрики для обучения SVM работе с курсором. Поскольку я относительно новичок в использовании R, я попытался адаптировать функцию twoClassSummary. Все, что мне нужно, это передать истинные метки классов и прогнозируемую вероятность класса из модели (svm) в функцию HMeasure из пакета hmeasure вместо использования ROC или других показателей эффективности классификации в каретке.

Например, вызов функции HMeasure в R - HMeasure (true.class, predictedProbs [, 2]) - приводит к вычислению Hmeasure. Использование приведенной ниже адаптации кода twoClassSummary приводит к возврату ошибки: «x» должно быть числовым.

Возможно, эта функция поезда не может «видеть» предсказанные вероятности для оценки функции HMeasure. Как я могу это исправить?

Я прочитал документацию и связанные вопросы, заданные на SO о регрессии < / а>. Это немного помогло мне. Буду благодарен за любую помощь или указатели на решение.

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)

r r-caret classification
person RVNorman    schedule 01.07.2014    source источник

Ответы (1)


arrow_upward
6
arrow_downward

Этот код работает. Я публикую решение на случай, если кто-то еще захочет использовать / улучшить это. Проблемы были вызваны неправильной ссылкой на объект 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)
person RVNorman    schedule 02.07.2014
comment
не уверен, каков этикет при принятии собственного ответа. Кто-нибудь может дать мне знать? - person RVNorman; 02.07.2014
comment
Если ответ вам помог, ничего страшного, не волнуйтесь. - person DrDom; 07.07.2014