Einige Zeit ist vergangen und ich denke, ich könnte eine Lösung zur Hand haben. Ich werde meinen Ansatz kurz beschreiben, um Ihnen die allgemeine Idee zu geben. Der Code sollte ausreichen, um die Details herauszufinden. Ich mag es, hier Code anzuhängen, aber es ist viel und Stackexchange macht es nicht einfach, dies zu tun. Ich beantworte natürlich gerne Kommentare und freue mich über jede Kritik.
Den Code finden Sie unten.
Die Strategie:
- Approximieren Sie eine glatte ROC-Kurve mithilfe der Logistikfunktion im Intervall [0,6].
- fk( x ) = 1( 1 + e x p ( - k ∗ x ) )
- Wenn Sie nun eine Roc-Kurve haben, die der gewünschten AUC entspricht, bestimmen Sie eine Punktzahl nach Stichprobe aus [0,1] gleichmäßig. Dies repräsentiert die fpr ( False-Positive-Rate ) auf der ROC-Kurve. Der Einfachheit halber wird die Punktzahl dann als 1-fpr berechnet.
- Die Markierung wird nun durch Abtasten aus einer Bernoulli-Verteilung bestimmt, wobei p unter Verwendung der Steigung der ROC-Kurve bei diesem fpr und der gewünschten Gesamtgenauigkeit der Bewertungen berechnet wird. Im Detail: Gewicht (label = "1"): = Steigung (fpr) multipliziert mit totalPrecision, Gewicht (label = "0"): = 1 multipliziert mit (1-totalPrecision). Normalisieren Sie die Gewichte so, dass sie sich zu 1 summieren, um p und 1-p zu bestimmen.
Hier ist ein Beispiel für eine ROC-Kurve für AUC = 0,6 und Gesamtgenauigkeit = 0,1 (auch im folgenden Code).
Anmerkungen:
- Die resultierende AUC ist nicht genau die gleiche wie die Eingangs-AUC. Tatsächlich liegt ein kleiner Fehler vor (etwa 0,02). Dieser Fehler ergibt sich aus der Art und Weise, wie die Bezeichnung einer Partitur bestimmt wird. Eine Verbesserung könnte darin bestehen, einen Parameter hinzuzufügen, um die Größe des Fehlers zu steuern.
- Die Punktzahl wird auf 1-fpr gesetzt. Dies ist willkürlich, da es der ROC-Kurve egal ist, wie die Ergebnisse aussehen, solange sie sortiert werden können.
Code:
# This function creates a set of random scores together with a binary label
# n = sampleSize
# basePrecision = ratio of positives in the sample (also called overall Precision on stats.stackexchange)
# auc = Area Under Curve i.e. the quality of the simulated model. Must be in [0.5,1].
#
binaryModelScores <- function(n,basePrecision=0.1,auc=0.6){
# determine parameter of logistic function
k <- calculateK(auc)
res <- data.frame("score"=rep(-1,n),"label"=rep(-1,n))
randUniform = runif(n,0,1)
runIndex <- 1
for(fpRate in randUniform){
tpRate <- roc(fpRate,k)
# slope
slope <- derivRoc(fpRate,k)
labSampleWeights <- c((1-basePrecision)*1,basePrecision*slope)
labSampleWeights <- labSampleWeights/sum(labSampleWeights)
res[runIndex,1] <- 1-fpRate # score
res[runIndex,2] <- sample(c(0,1),1,prob=labSampleWeights) # label
runIndex<-runIndex+1
}
res
}
# min-max-normalization of x (fpr): [0,6] -> [0,1]
transformX <- function(x){
(x-0)/(6-0) * (1-0)+0
}
# inverse min-max-normalization of x (fpr): [0,1] -> [0,6]
invTransformX <- function(invx){
(invx-0)/(1-0) *(6-0) + 0
}
# min-max-normalization of y (tpr): [0.5,logistic(6,k)] -> [0,1]
transformY <- function(y,k){
(y-0.5)/(logistic(6,k)-0.5)*(1-0)+0
}
# logistic function
logistic <- function(x,k){
1/(1+exp(-k*x))
}
# integral of logistic function
intLogistic <- function(x,k){
1/k*log(1+exp(k*x))
}
# derivative of logistic function
derivLogistic <- function(x,k){
numerator <- k*exp(-k*x)
denominator <- (1+exp(-k*x))^2
numerator/denominator
}
# roc-function, mapping fpr to tpr
roc <- function(x,k){
transformY(logistic(invTransformX(x),k),k)
}
# derivative of the roc-function
derivRoc <- function(x,k){
scalFactor <- 6 / (logistic(6,k)-0.5)
derivLogistic(invTransformX(x),k) * scalFactor
}
# calculate the AUC for a given k
calculateAUC <- function(k){
((intLogistic(6,k)-intLogistic(0,k))-(0.5*6))/((logistic(6,k)-0.5)*6)
}
# calculate k for a given auc
calculateK <- function(auc){
f <- function(k){
return(calculateAUC(k)-auc)
}
if(f(0.0001) > 0){
return(0.0001)
}else{
return(uniroot(f,c(0.0001,100))$root)
}
}
# Example
require(ROCR)
x <- seq(0,1,by=0.01)
k <- calculateK(0.6)
plot(x,roc(x,k),type="l",xlab="fpr",ylab="tpr",main=paste("ROC-Curve for AUC=",0.6," <=> k=",k))
dat <- binaryModelScores(1000,basePrecision=0.1,auc=0.6)
pred <- prediction(dat$score,as.factor(dat$label))
performance(pred,measure="auc")@y.values[[1]]
perf <- performance(pred, measure = "tpr", x.measure = "fpr")
plot(perf,main="approximated ROC-Curve (random generated scores)")