Ha pasado algún tiempo y creo que podría tener una solución a mano. Describiré brevemente mi enfoque para darle una idea general. El código debería ser suficiente para descubrir los detalles. Me gusta adjuntar código aquí, pero es mucho y stackexchange hace que no sea fácil hacerlo. Por supuesto, estoy feliz de responder cualquier comentario, también agradezco cualquier crítica.
El código se puede encontrar a continuación.
La estrategia:
- Aproximar una curva ROC suave utilizando la función logística en el intervalo [0,6]
- Al agregar un parámetro k se puede influir en la forma de la curva para que se ajuste a la calidad del modelo deseada, medida por AUC (Área bajo la curva). La función resultante es . Si k-> 0, AUC se acerca a 0.5 (sin optimización), si k -> Inf, AUC se acerca a 1 (modelo óptimo). Como método práctico, k debe estar en el intervalo [0.0001,100]. Según algunos cálculos básicos, se puede crear una función para asignar k a AUC y viceversa.Fk( x ) = 1( 1 + e x p ( - k ∗ x ) )
- Ahora, dado que tiene una curva roc que coincide con el AUC deseado, determine un puntaje por muestra de [0,1] uniformemente. Esto representa la fpr ( tasa de falsos positivos ) en la curva ROC. Por simplicidad, la puntuación se calcula entonces como 1-fpr.
- La etiqueta ahora se determina mediante el muestreo de una distribución de Bernoulli con p calculado utilizando la pendiente de la curva ROC en esta fpr y la precisión general deseada de los puntajes. En detalle: peso (etiqueta = "1"): = pendiente (fpr) multiplicada por generalPrecision, peso (etiqueta = "0"): = 1 multiplicado por (1-OverallPrecision). Normalice los pesos para que sumen 1 para determinar py 1-p.
Aquí hay un ejemplo de curva ROC para AUC = 0.6 y precisión general = 0.1 (también en el código a continuación)
Notas:
- el AUC resultante no es exactamente el mismo que el AUC de entrada, de hecho, hay un pequeño error (alrededor de 0.02). Este error se origina en la forma en que se determina la etiqueta de una puntuación. Una mejora podría ser agregar un parámetro para controlar el tamaño del error.
- el puntaje se establece como 1-fpr. Esto es arbitrario ya que a la curva ROC no le importa cómo se vean los puntajes siempre que se puedan ordenar.
código:
# 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)")