биннинг непрерывных переменных по значению IV в R

Question

Я строю модель логистической регрессии в R. Я хочу оптимально связывать непрерывные предикторы с целевой переменной.Я знаю две вещи:

1. непрерывные переменные сгруппированы так, что их IV (информационное значение) максимизируется

2. максимизироватьхи-квадрат в двухсторонней таблице сопряженности - у цели есть два значения 0 и 1, а у непрерывной переменной с двоичными значениями есть двоичные сегменты

Кто-нибудь знает какие-либо функции в Rможно выполнить такой биннинг?

Ваша помощь будет принята с благодарностью.

Answer 1

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

library(woeBinning)

# get the bin cut points from your dataframe
cutpoints <- woe.binning(dataset, "target_name", "Variable_name")
woe.binning.plot(cutpoints)

# apply the cutpoints to your dataframe
dataset_woe <- woe.binning.deploy(dataset, cutpoint, add.woe.or.dum.var = "woe")

.набор данных с двумя дополнительными столбцами

• Variable_name.binned, который представляет собой метки
• Variable_name.woe.binned, которые представляют собой замененные значения, которые затем можно проанализировать в регрессии вместо Variable_name

Во втором пункте, на chi2, дискретизация пакета , кажется, справляется с этим, но я не проверял это.

Answer 2

Могут быть рассмотрены методы, используемые сплайнами регрессии для задания местоположения узлов. Пакет rpart, вероятно, имеет соответствующий код. Вам действительно необходимо наказать статистику логического вывода, потому что это приводит к неявному сокрытию степеней свободы, затрачиваемых в процессе перемещения разрывов, чтобы получить наилучшее соответствие. Другим распространенным методом является определение разрывов в одинаково расположенных квантилях (квартилях или квинтилях) в подмножестве с IV = 1. Примерно такой непроверенный код:

cont.var.vec <- # names of all your continuous variables
breaks <- function(var,n) quantiles( dfrm[[var]], 
                                     probs=seq(0,1,length.out=n), 
                                     na.rm=TRUE)
lapply(dfrm[ dfrm$IV == 1 , cont.var.vec] , breaks, n=5)

Answer 3

s

etwd("D:")
rm(list=ls())
options (scipen = 999)
read.csv("dummy_data.txt") -> dt

head(dt)
summary(dt)
mydata <- dt
head(mydata)
summary(mydata)
##Capping
for(i in 1:ncol(mydata)){
  if(is.numeric(mydata[,i])){
    val.quant <- unname(quantile(mydata[,i],probs = 0.75))
    mydata[,i] = sapply(mydata[,i],function(x){if(x > (1.5*val.quant+1)){1.5*val.quant+1}else{x}})
  }
}

library(randomForest)
x <- mydata[,!names(mydata) %in% c("Cust_Key","Y")]
y <- as.factor(mydata$Y)

set.seed(21)
fit <- randomForest(x,y,importance=T,ntree = 70)

mydata2 <- mydata[,!names(mydata) %in% c("Cust_Key")]
mydata2$Y <- as.factor(mydata2$Y)
fit$importance
####var reduction#####
vartoremove <- ncol(mydata2) - 20
library(rminer)
##### 
for(i in 1:vartoremove){
  rf <- fit(Y~.,data=mydata2,model = "randomForest", mtry = 10 ,ntree = 100)
  varImportance <- Importance(rf,mydata2,method="sensg")
  Z <- order(varImportance$imp,decreasing = FALSE)
  IND <- Z[2]
  var_to_remove <- names(mydata2[IND])
  mydata2[IND] = NULL
  print(i)
}
###########
library(smbinning)
as.data.frame(mydata2) -> inp
summary(inp)
attach(inp)
rm(result)
str(inp)
inp$target <- as.numeric(inp$Y) *1
table(inp$target)
ftable(inp$Y,inp$target)
inp$target <- inp$target -1
result= smbinning(df=inp, y="target",  x="X37", p=0.0005) 
result$ivtable
smbinning.plot(result,option="badrate",sub="test")
summary(inp)
result$ivtable
boxplot(inp$X2~inp$Y,horizontal=T, frame=F, col="red",main="Distribution")
###Sample
require(caTools)
inp$Y <- NULL
sample = sample.split(inp$target, SplitRatio = .7)
train = subset(inp, sample == TRUE)
test = subset(inp, sample == FALSE)
head(train)
nrow(train)

fit1 <- glm(train$target~.,data=train,family = binomial)  

summary(rf)
prediction1 <- data.frame(actual = test$target, predicted = predict(fit1,test ,type="response") )

result= smbinning(df=prediction1, y="actual",  x="predicted", p=0.005) 
result$ivtable

smbinning.plot(result,option="badrate",sub="test")

tail(prediction1)

write.csv(prediction1 , "test_pred_logistic.csv")
predict_train <- data.frame(actual = train$target, predicted = predict(fit1,train ,type="response") )
write.csv(predict_train , "train_pred_logistic.csv")
result= smbinning(df=predict_train, y="actual",  x="predicted", p=0.005) 
result$ivtable
smbinning.plot(result,option="badrate",sub="train")


####random forest

rf <- fit(target~.,data=train,model = "randomForest", mtry = 10 ,ntree = 200)

prediction2 <- data.frame(actual = test$target, predicted = predict(rf,train))
result= smbinning(df=prediction2, y="actual",  x="predicted", p=0.005) 
result$ivtable
smbinning.plot(result,option="badrate",sub="train")











###########IV

library(devtools)
install_github("riv","tomasgreif")
library(woe)

##### K-fold Validation ########

library(caret)
cv_fold_count = 2
folds = createFolds(mydata2$Y,cv_fold_count,list=T);

smpl = folds[[i]];
g_train = mydata2[-smpl,!names(mydata2) %in% c("Y")];
g_test = mydata2[smpl,!names(mydata2) %in% c("Y")];

cost_train = mydata2[-smpl,"Y"];
cost_test = mydata2[smpl,"Y"];

rf <- randomForest(g_train,cost_train)
logit.data <- cbind(cost_train,g_train)
logit.fit <- glm(cost_train~.,data=logit.data,family = binomial)

prediction <- data.f

rame (фактический = тест $ Y, прогнозируемый = прогноз (rf, тест))