Applicazioni pratiche di machine learning/Concessione sussidi

Applicazioni pratiche di machine learning

Categoria · Copertina · Sviluppo · Modifica il template

Caricamento librerie

library(dplyr)
library(ggplot2)
library(caret)
library(h2o)

Parte 1: Dati

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

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

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

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...