Applicazioni pratiche di machine learning/Concessione sussidi
Caricamento librerie
[modifica | modifica sorgente]library(dplyr)
library(ggplot2)
library(caret)
library(h2o)
Parte 1: Dati
[modifica | modifica sorgente]Nel dataset scaricabile da qui : https://www.kaggle.com/datasets/vardhansiramdasu/income sono contenute 13 variabili sul reddito di 31978 persone. Dati accurati sul reddito sono tra i più difficili da ottenere in tutto il mondo. Nella pianificazione dell'esborso di sussidi e nel monitoraggio-prevenzione sulla concessione impropria di essi si può utilizzare un dataset di questo tipo . In particolare la variabile SalStat assume 2 valori : "Reddito superiore a 50.000 dollari" e "Reddito inferiore a 50.000 dollari" . Se nella previsione di tale variabile tramite le altre si ottiene un reddito superiore a 50.000 si stabilisce che la persona non merita il sussidio. Le variabili contenute nel dataset sono :
- age: età della persona.
- JobType: Tipo di lavoro
- EdType: Titolo di studio
- maritalstatus: Stato civile
- occupation: Tipo di occupazione
- relationship: Tipo di relazione familiare
- race: razza
- capitalgain: numerica
- capitalloss: numerica
- hours-per-week: ore settimanali
- nativecountry: Stato di appartenenza
- SalStat: "Reddito superiore a 50.000 dollari" o "Reddito inferiore a 50.000 dollari"
Caricamento dati:
df <- read.csv("income.csv", stringsAsFactors = TRUE)
Parte 2: Esplorazione dati
[modifica | modifica sorgente]Si nota che il 75,94% del campione ha un reddito inferiore a 50.000 dollari:
tbl <- table(df$SalStat)
df1<-cbind(tbl,round(prop.table(tbl)*100,2))
colnames(df1) <-c("Totale","Percentuale")
df1
Totale Percentuale greater than 50,000 7695 24.06 less than or equal to 50,000 24283 75.94
Come si vede dal seguente BoxPlot nel campione la mediana dell'età delle persone è maggiore tra chi ha un reddito superiore a 50.000 dollari :
ggplot(df,aes(SalStat,age, fill=SalStat))+
geom_boxplot()
Nel campione chi ha un master, un dottorato o è professore tende ad avere un reddito superiore ai 50.000 dollari:
tbl <-table(df$SalStat,df$EdType)
tbl
10th 11th 12th 1st-4th 5th-6th greater than 50,000 61 59 31 6 14 less than or equal to 50,000 860 1108 386 157 304 7th-8th 9th Assoc-acdm Assoc-voc greater than 50,000 37 26 262 357 less than or equal to 50,000 590 480 793 1009 Bachelors Doctorate HS-grad greater than 50,000 2169 291 1662 less than or equal to 50,000 3041 99 8706 Masters Preschool Prof-school greater than 50,000 936 0 414 less than or equal to 50,000 738 50 145 Some-college greater than 50,000 1370 less than or equal to 50,000 5817
Soltanto il 3,63% delle donne ha un reddito superiore a 50.000 dollari:
tbl <-table(df$SalStat,df$gender)
tbl
round(prop.table(tbl)*100,2)
Female Male greater than 50,000 1162 6533 less than or equal to 50,000 9446 14837 Female Male greater than 50,000 3.63 20.43 less than or equal to 50,000 29.54 46.40
Parte 3: Modellizzazione e previsione
[modifica | modifica sorgente]Si divide il dataset df in un training set fatto dal 75% delle osservazioni e su cui si addestra il modello ed il rimanente 25% costituisce il testing set su cui verrà testato il modello :
trainIndex <- createDataPartition(df$SalStat,p=0.75, list = FALSE)
training <- df[trainIndex,]
testing <- df[-trainIndex,]
Si inizializza la libreria h2o necessaria per automatizzare la ricerca dell'algoritmo di machine learning migliore:
h2o.init()
Starting H2O JVM and connecting: ....... Connection successful! R is connected to the H2O cluster: H2O cluster uptime: 5 seconds 743 milliseconds H2O cluster timezone: Europe/Rome H2O data parsing timezone: UTC H2O cluster version: 3.38.0.1 H2O cluster version age: 1 month and 13 days H2O cluster name: H2O_started_from_R_gian_sdc414 H2O cluster total nodes: 1 H2O cluster total memory: 1.91 GB H2O cluster total cores: 2 H2O cluster allowed cores: 2 H2O cluster healthy: TRUE H2O Connection ip: localhost H2O Connection port: 54321 H2O Connection proxy: NA H2O Internal Security: FALSE R Version: R version 4.2.1 (2022-06-23)
Si addestra il modello :
train <- as.h2o(training)
y <- "SalStat"
x <- setdiff(names(train), y)
aml <- h2o.automl(x = x, y = y,
training_frame = train,
max_runtime_secs =300)
Si ottengono i seguenti modelli per cui il migliore risulta : StackedEnsemble_AllModels_3_AutoML_1_20221102_51613 con un auc=92,66%
lb <- aml@leaderboard
lb
model_id auc 1 StackedEnsemble_AllModels_3_AutoML_1_20221102_51613 0.9266060 2 StackedEnsemble_AllModels_2_AutoML_1_20221102_51613 0.9265063 3 StackedEnsemble_BestOfFamily_3_AutoML_1_20221102_51613 0.9263296 4 XGBoost_3_AutoML_1_20221102_51613 0.9253232 5 StackedEnsemble_AllModels_1_AutoML_1_20221102_51613 0.9251552 6 StackedEnsemble_BestOfFamily_2_AutoML_1_20221102_51613 0.9248050
Si prova il modello sul testing set ottenendo la matrice di confusione e un'accuracy del 88,10% :
test <- as.h2o(testing)
model <- aml@leader
p1 = h2o.predict(model, newdata=test)
confusionMatrix(df2$predict,testing$SalStat)
Confusion Matrix and Statistics
Reference Prediction greater than 50,000 less than or equal to 50,000 greater than 50,000 1274 302 less than or equal to 50,000 649 5768 Accuracy : 0.881 95% CI : (0.8737, 0.888) No Information Rate : 0.7594 P-Value [Acc > NIR] : < 2.2e-16 Kappa : 0.653 Mcnemar's Test P-Value : < 2.2e-16 Sensitivity : 0.6625 Specificity : 0.9502 Pos Pred Value : 0.8084 Neg Pred Value : 0.8989 Prevalence : 0.2406 Detection Rate : 0.1594 Detection Prevalence : 0.1972 Balanced Accuracy : 0.8064 'Positive' Class : greater than 50,000
Controversie sull'uso del modello
[modifica | modifica sorgente]Questo modello può creare delle discriminazioni. Ad esempio per un padre di famiglia, di colore, di 35 anni, sposato, di cultura superiore che lavora nelle vendite per 50 ore settimanali il modello predice un reddito superiore a 50.000 dollari al 66,28%, quindi non avrebbe diritto al sussidio...:
df3 <- data.frame(age=35, JobType=" Private", EdType=" Bachelors", maritalstatus=" Married-civ-spouse", occupation=" Sales", relationship =" Husband", race=" Black", gender=" Male", capitalgain=0,capitalloss=0, hoursperweek=50, nativecountry=" United-States")
test_df <- as.h2o(df3)
model <- aml@leader
h2o.predict(model, newdata=test_df)
predict greater than 50,000 less than or equal to 50,000 greater than 50,000 0.6628661 0.3371339
e di questi casi se ne trovano tanti altri...