Код для поиска оболочки списка кривых ROC (верхний и нижний пределы набора кривых) - PullRequest
Новая
       12

Код для поиска оболочки списка кривых ROC (верхний и нижний пределы набора кривых)

0 голосов
/ 01 февраля 2019

Я создал код, который вычисляет две строки, которые я запрашиваю в вопросе, как показано на рисунке ниже (нужные строки выделены красным).

РЕДАКТИРОВАТЬ: Это ожидаемый график с использованием моего фрагмента для создания кривых ROC (по крайней мере, я уверен, что это правильно):

Hull of set of ROC curves

Проблема в том, что указанный код очень уродливый (слишком длинный, чтобы даже публиковать здесь), и процесс, который я придумал, кажется мне чрезвычайно утомительным.Тем не менее, я не могу придумать ничего лучшего.

Вот небольшой фрагмент кода для создания входного списка кривых ROC. 

library(MASS)
library(dplyr)

simple_roc <- function(labels, scores){
  labels <- labels[order(scores, decreasing=TRUE)]
  return(rbind(c(0,0,0),data.frame(TPR=cumsum(labels)/sum(labels), FPR=cumsum(!labels)/sum(!labels), labels)))
}

diab_data=rbind(data.frame(Pima.tr),data.frame(Pima.te))

roc_curves_list_logisitic=list()

for (k in 1:100) {

  #Set a fixed seed for reproducibility
  set.seed(k)

  # sampled_rows <- createDataPartition(diab_data$type, p = .7, list = FALSE)

  sampled_rows <- sample(1:nrow(diab_data), size=floor(0.7*nrow(diab_data)))

  diab_data_train=diab_data[sampled_rows,]
  diab_data_test=diab_data[-sampled_rows,]
  diab_data_train[,1:7]=scale(diab_data_train[,1:7])
  diab_data_test[,1:7]=scale(diab_data_test[,1:7])

  diab_data_train[,"type"]=as.numeric(as.character(recode_factor(diab_data_train[,"type"],`Yes` = "1", `No` = "0")))

  diab_data_test[,"type"]=as.numeric(as.character(recode_factor(diab_data_test[,"type"],`Yes` = "1", `No` = "0")))


  logistic_model_simple=glm(data=diab_data_train,as.formula(paste(colnames(diab_data_train)[8], "~",
                                                                  paste(colnames(diab_data_train)[-8], collapse = "+"),
                                                                  sep = "")),family=binomial(link = "logit"))

  roc_curves_list_logisitic[[k]]=simple_roc(diab_data_test[,"type"], 
                                            ifelse(predict(logistic_model_simple,diab_data_test,type='response')>0.5,1,0))

}

Теперь я прошу помощи, если у кого-нибудь есть «красивое» решение для получения двух красных линий.на этом графике (в ggplot2) с использованием списка кривых ROC, которые я предоставил в качестве входных данных.

Желательно, чтобы я в итоге получил два кадра данных lower_bound_roc_curves и upper_bound_roc_curves, содержащих необходимые значения для построения двух линийотдельно, если они мне нужны.

Заранее спасибо,

РЕДАКТИРОВАТЬ 2: @denis Вот некоторые части, я думаю, ваш код ошибается:

First plot dennis

1 Ответ

0 голосов
/ 01 февраля 2019

У меня есть решение с data.table и zoo.Первый шаг - иметь общий FPR между всеми вашими кривыми.Это должно быть в состоянии построить максимум и минимум всей кривой.Для этого: 

library(data.table)
library(zoo)

FPRlist <- unique(rbindlist(lapply(roc_curves_list_logisitic,function(ROC){
  rccurve <- as.data.table(ROC)
  rccurve[,.(FPR = FPR)]
})))

Я создаю таблицу FPRlist, содержащую все FPR, существующие во всех ваших кривых.После слияния каждой кривой с этой таблицей, содержащей все FPR, я буду использовать na.locf для завершения пропущенных значений.Я использую rbindlist для создания одной таблицы с идентификатором для каждой кривой ROC 

results <- rbindlist(lapply(seq(roc_curves_list_logisitic),function(idx){
  rccurve <- as.data.table(roc_curves_list_logisitic[[idx]])
  rccurve <- merge(FPRlist,rccurve,all = T)
  rccurve[,TPR := na.locf(TPR,na.rm = F)] # I complete the values
  rccurve[,ID := idx] # I create an ID
  rccurve
}))

Затем я рассчитываю максимальное и минимальное значение для всех идентификаторов (всех кривых ROC) для каждого шага FPR 

resultmax <- results[,.(TPR = max(TPR)),by = FPR]
resultmin <- results[,.(TPR = min(TPR)),by = FPR]

И постройте так же, как вы это делаете 

ggplot()+
  geom_line(data = results,aes(FPR,TPR,color = as.factor(ID)))+
  theme_light() %+replace% theme(legend.position = "none")+
  geom_line(data = resultmax,aes(FPR,TPR),color = "red",size = 1)+
  geom_line(data = resultmin,aes(FPR,TPR),color = "red",size = 1)

enter image description here

Я разрешил перевод dplyr пользователям dplyr, потому что яЯ не привык к.

Редактировать

Я изменил свой график, чтобы сравнить его с графиком только всех необработанных кривых ROC без слияния или na.locf.Можно видеть, что красные линии, которые я предлагаю, следуют за максимумом и минимумом всех кривых.Второй график получается следующим образом: 

results2 <- rbindlist(lapply(seq(roc_curves_list_logisitic),function(idx){
  rccurve <- as.data.table(roc_curves_list_logisitic[[idx]])
  rccurve[,ID := idx] # I create an ID
  rccurve
}))

p2 <- ggplot()+
  geom_line(data = results2,aes(FPR,TPR,color = as.factor(ID)))+
  theme_light() %+replace% theme(legend.position = "none")

Он просто отображает все кривые ROC, содержащиеся в списке, представленном в вопросе об ОС.Двухколоночный график получается с помощью функции multiplot (см. здесь )

...