r R脚本用于从数据生成和绘制ROC曲线

Posted 2021-05-24

library('ROCR')
library('ggplot2')

## test data for example
# classification is a vector of:
  # 0's for true negatives
  # 1's for true positives
# method1 and method2 are (ideally) monotonic functions of 'classification'
# that are *not* limited to 0's and 1's
# in this example, method1 and method2 are normally distributed
classification <- sample(c(0,1),100,replace=TRUE)
method1 <- rnorm(length(classification),classification,1)
method2 <- rnorm(length(classification),classification,2)

# bind all classifications to a data frame
rocData <- as.data.frame(cbind(classification,method1,method2))

predictions <- sapply(rocData[-classification], function(x) prediction(x,rocData$classification))

# AUC for ROC
performances <- sapply(predictions,function(x) performance(x,measure="auc"))
for(i in 1:length(performances)){
        print(paste("AUC",names(performances[i]),slot(performances[i][[1]],"y.values")[[1]]))
}

## Choose one of ROC or Precision-Recall
chooseROC <- TRUE # set to TRUE for ROC or FALSE for Precision-Recall

if(chooseROC){
  # ROC
  performances <- sapply(predictions, function(x) performance(x, measure = "tpr", x.measure = "fpr"))
} else{
  # Precision-Recall
  performances <- sapply(predictions, function(x) performance(x, measure="prec", x.measure="rec"))
}

metaData <- c()
for(i in 1:length(performances))
    {
        metaData <- rbind(metaData,cbind(rep(names(performances[i]),length(performances[i][[1]]@alpha.values[[1]]))))
    }
rocCurve <- do.call(rbind,lapply(performances, function(x) cbind(unlist(slot(x,"x.values")[[1]]),unlist(slot(x,"y.values")[[1]]))))
rocCurve <- as.data.frame(cbind(metaData,rocCurve))
colnames(rocCurve) <- c("StatisticID","X","Y")
rocCurve$X <- as.numeric(levels(rocCurve$X))[rocCurve$X]
rocCurve$Y <- as.numeric(levels(rocCurve$Y))[rocCurve$Y]

# write data
# write.table(rocCurve,"roc_data.Rdat")

# to read cached data
# rocCurve <- read.table("roc_data.Rdat",header=TRUE)
g <- ggplot(data=rocCurve,aes(x=X,y=Y,color=factor(StatisticID)))
# for (potentially ragged) line
g <- g + geom_line()
# for (smoothed) line uncomment following line and comment above line
# g <- g + geom_smooth(se=FALSE,method="loess")
# draws y=x line for 'random' classification
g <- g + geom_abline(intercept = 0, slope = 1, linetype="dotted")
if(chooseROC){
  g <- g + xlab("false positive rate") + ylab("true positive rate") + ggtitle("Receiver Operating Characteristic")
} else{
  g <- g + xlab("recall") + ylab("precision") + ggtitle("Precision-Recall")
}
g <- g + theme_bw() # white background
g <- g + theme(text = element_text(size=18), axis.text.x = element_text(size=18), axis.text.y = element_text(size=18), # text size
          panel.border = element_blank(), # no plot border
          panel.grid.major = element_blank(), # no major axis gridlines
          panel.grid.minor = element_blank(), # no minor axis gridlines
          legend.title=element_blank(), # no legend title
          legend.position=c(0.75,0.3), # manual legend position
          axis.line = element_line(colour = "black")) # axis line black
print(g)
# to save plot
# ggsave(file="roc_curve.png")