グループ別に精度がkのカスタムキャレットメトリック

Question

caret::trainで使用するカスタムメトリック関数を作成する適切な方法は、引数を含み、トレーニングデータのサブセットを要約できますか？

クレジットスコアとローンデータがあり、さまざまなカテゴリーのローン（住宅ローン、自動車ローン、学生ローンなど）内のトップ貸出見通しを予測するモデルを訓練したいと考えています。当社のポートフォリオを多様化したいと考えており、それぞれのカテゴリーでいくつかの低リスクローンを特定したいと考えています。

例として、caretパッケージのGermanLoansのデータを使用できます。このトレーニングデータでは、各ローンは「良い」または「不良」のいずれかに分類されます。一部の列を再配置した後、要求されたローンのタイプを識別する列Purposeがあります。

## Load packages 
library(data.table); library(caret); library(xgboost); library(Metrics) 

## Load data and convert dependent variable (Class) to factor 
data(GermanCredit) 
setDT(GermanCredit, keep.rownames=TRUE) 
GermanCredit[, `:=`(rn=as.numeric(rn), Class=factor(Class, levels=c("Good", "Bad")))] 

## Now we need to collapse a few columns... 
## - Columns containing purpose for getting loan 
colsPurpose <- names(GermanCredit)[names(GermanCredit) %like% "Purpose."] 

## - Replace purpose columns with a single factor column 
GermanCredit[, Purpose:=melt(GermanCredit, id.var="rn", measure.vars=colsPurpose)[ 
    value==1][order(rn), factor(sub("Purpose.", "", variable))]] 

## - Drop purpose columns 
GermanCredit[, colsPurpose:=NULL, with=FALSE] 

ここでカスタムメトリック関数を作成する必要があります。 precision at k（ここでは、kは、各カテゴリで作成したいローンの数です）のグループの平均は適切だと思われますが、私は提案に開放しています。どんな場合でも、関数は次のようになります。

twoClassGroup <- function (data, lev=NULL, model=NULL, k, ...) { 
    if(length(levels(data$obs)) > 2) 
    stop(paste("Your outcome has", length(levels(data$obs)), 
       "levels. The twoClassGroup() function isn't appropriate.")) 
    if (!all(levels(data$pred) == levels(data$obs))) 
    stop("levels of observed and predicted data do not match") 

    [subset the data, probably using data$rowIndex] 

    [calculate the metrics, based on data$pred and data$obs] 

    [return a named vector of metrics] 
} 

最後に、モデルを訓練することができます。

## Train a model (just an example; may or may not be appropriate for this problem) 
creditModel <- train(
    Class ~ . - Purpose, data=GermanCredit, method="xgbTree", 
    trControl=trainControl(
    method="cv", number=6, returnResamp="none", summaryFunction=twoClassGroup, 
    classProbs=TRUE, allowParallel=TRUE, verboseIter=TRUE), 
    tuneGrid = expand.grid(
    nrounds=500, max_depth=6, eta=0.02, gamma=0, colsample_bytree=1, min_child_weight=6), 
    metric="someCustomMetric", preProc=c("center", "scale")) 

## Add predictions 
GermanCredit[, `:=`(pred=predict(creditModel, GermanCredit, type="raw"), 
        prob=predict(creditModel, GermanCredit, type="prob")[[levels(creditModel)[1]]])] 

質問

• にはどうすればtrain呼び出しからtwoClassGroupにkの値を渡すのですか？ main関数の引数の中に追加することはできません。trControlまたはtuneGridの中に追加することもできません。
• Purposeの各値内の上位k値のモデル精度を計算するために、twoClassGroup内のデータをサブセット化するにはどうすればよいですか？ twoClassGroup機能内のdataオブジェクトは、元のtrain機能に渡されたものと同じではありません。

Answer 1

この試みはほとんどうまくいきますが、誰かがより良い方法を共有できることを望んでいます。 dtとkの引数をtrainから渡すのではなく、twoClassGroupにハードコードされています。また、Metrics::mapkの値は非常に低いように見えますが、結果として得られるモデルは最良のローン見通しを選ぶように見えます。オリジナルのポストからtrainコールで

library(Metrics) 

twoClassGroup <- function (data, lev=NULL, model=NULL, dt=GermanCredit, k=10) { 
    if(length(levels(data$obs)) > 2) 
    stop(paste("Your outcome has", length(levels(data$obs)), 
       "levels. The twoClassGroup() function isn't appropriate.")) 
    if (!all(levels(data$pred) == levels(data$obs))) 
    stop("levels of observed and predicted data do not match") 

    data <- data.table(data, group=dt[data$rowIndex, Purpose]) 

    ## You can ignore these extra metrics... 
    ## <----- 
    sens <- sensitivity(data$pred, data$obs, positive=lev[1]) 
    spec <- specificity(data$pred, data$obs, positive=lev[1]) 
    precision <- posPredValue(data$pred, data$obs) 
    recall <- sens 

    Fbeta <- function(precision, recall, beta=1) { 
    val <- (1+beta^2)*(precision*recall)/(precision*beta^2 + recall) 
    if(is.nan(val)) val <- 0 
    return(val) 
    } 
    F0.5 <- Fbeta(precision, recall, beta=0.5) 
    F1 <- Fbeta(precision, recall, beta=1) 
    F2 <- Fbeta(precision, recall, beta=2) 

    ## -----> 
    ## This is the important one... 
    mapk <- data[, .(obs=list(obs), pred=list(pred)), by=group][, mapk(k, obs, pred)] 

    return(c(sensitivity=sens, specificity=spec, F0.5=F0.5, F1=F1, F2=F2, mapk=mapk)) 
} 

、metricの値は、むしろ「someCustomMetric」よりも「MAPK」になります。