Mineria de dades: PRA2 - Projecte de mineria de dades
Autor: Joan Manel Ramírez Jávega
Juny 2024
1 Enunciat
Com a continuació de l’estudi iniciat a la Pràctica 1, procedim a aplicar models analítics, tant no supervisats com supervisats, sobre el joc de dades seleccionat i preparat. En aquesta Pràctica 2 haureu de carregar les dades prèviament preparades a la Pràctica 1.
Punt comú per a tots els exercicis
En tots els apartats dels exercicis d’aquesta pràctica es demana a l’estudiant, a més d’aplicar els diferents mètodes i d’analitzar correctament el problema, detallar de manera exhaustiva ressaltant el perquè i com s’ha realitzat, incloent-hi elements visuals, explicant els resultats i realitzant les comparatives oportunes amb les seves conclusions.
Per a tota la pràctica és necessari documentar cada apartat de l’exercici pràctic que s’ha fet, el perquè s’ha fet i com s’ha fet. Així mateix, totes les decisions i conclusions hauran de ser presentades de forma raonada i clara, contextualitzant els resultats, és a dir, especificant tots i cadascun dels passos que s’hagin dut a terme per resoldre’ls.
D’aquesta manera es demana a l’estudiant que completi els passos següents amb el job de dades preparat a la Practica 1:
Models no supervisats
Aplicar un model no supervisat basat en el concepte de distància, sobre el joc de dades.
Aplicar de nou el model anterior, però usant una mètrica de distància diferent a la distància euclidiana i comparar-ne els resultats amb els mètodes anteriors.
Utilitzar els algorismes DBSCAN i OPTICS, provant amb diferents valors del paràmetre
epsiminPts, i es comparen els resultats amb els mètodes anteriors.
Models supervisats
Seleccionar una mostra d’entrenament i una de test utilitzant les proporcions que es considerin més adequades en funció de la disponibilitat de dades. Justificar aquesta selecció.
Aplicar un model de generació de regles a partir d’ arbres de decisió ajustant les diferents opcions de creació (mida mínima dels nodes, criteris de divisió, …). Obtenir l’arbre sense i amb opcions de poda. Obtenir la matriu de confusió. Finalment, comparar-ne els resultats.
Aplicar un model supervisat diferent del del punt 5.. S’ha de triar entre els que s’han vist al material docent de l’assignatura. Comparar el resultat amb el model generat anteriorment.
Identificar eventuals limitacions del dataset seleccionat i analitzar els riscos per al cas d’ús del model per a classificar una nova dada.
NOTA IMPORTANT: Recordeu que si les variables a la vostra base de dades tenen unitats de mesura molt diferents és recomanable transformar les variables per evitar l’efecte escala a causa de les diferents unitats de mesura.
2 Recursos de programació
Incloem en aquest apartat una llista de recursos de programació per a mineria de dades on podreu trobar exemples, idees i inspiració:
3 Format i data de lliurament
El format de lliurament és: l’output generat en format .html amb nom username_estudiant-PRA2.
La data límit de lliurament és el 19/06/2024.
4 RESPOSTES
4.1 Exercici 0
En aquest partat ens limitarem a realitzar les tasques de càrrega de les dades i el seu preprocessament ja realitzat en la PRA1. En el cas que es realitzi algun canvi o tasca no recollida en l’anterior pràctica, aquest s’explicitarà amb el comentari corresponent.
Realitzem una comprovació visual que les tasques de preprocessament realitzades aquí són les mateixes que en la PRA1:
aggEs_mon_treball <- aggregate(dades$Numero_expedient,
by=dades["Es_mon_treball"], FUN=length)
ggplot(aggEs_mon_treball, aes(x="", y=x, fill=Es_mon_treball)) +
geom_bar(width = 1, stat = "identity", color = "black") +
ggtitle(glue("Fig. 1. Diagrama de barres apilades del recompte dels
conductors en funció de si el motiu del seu desplaçament tenia
relació amb el món del treball.")) +
xlab(glue("Es_mon_treball")) +
ylab("Nombre")
nNo_Es_mon_treball <- aggEs_mon_treball[1, 2]
nSi_Es_mon_treball <- aggEs_mon_treball[2, 2]
print(glue("Del conjunt de conductors a estudiar, {nSi_Es_mon_treball} es desplaçaven per algun motiu
relacionat amb el món del treball i altres {nNo_Es_mon_treball} no."))## Del conjunt de conductors a estudiar, 1330 es desplaçaven per algun motiu
## relacionat amb el món del treball i altres 1528 no.Addicionalment a totes les tasques de preprocessament a la PRA1, trobem oportú codificar la variables dels horaris a una variable dicotòmica que cerqui respondre si l’accident de trànsit en qüestió va tenir lloc en, d’acord a la terminologia de l’Enquesta de mobilitat en dia feiner de l’any 2022 per l’Autoritat del Transport Metropolità en l’àrea de Barcelona - que és la darrera publicada- en horari “ocupacional” o “no ocupacional” (ATM, 2023: 41). Tot i així, observem en elsd resultats que les franjes horàries més accentuades són un xic més àmplies que les delimitades en l’informe citat i, per això, extendrem la etiqueta “Ocupacional” a aquells accidents que es van produir en dia laborable - amb la categoria “Si” en la variable “Es_laborable”- i en l’horari des de les 6 fins les 10h. del matí i des de les 13 fins les 16h. per la tarda.
dades["Es_ocupacional"] <- "No"
horaOcupacional <- c(6, 7, 8, 9, 13, 14, 15)
maskHorari <- dades$Hora_dia %in% horaOcupacional
maskLaborable <- dades$Es_laborable == "Si"
dades$Es_ocupacional[maskHorari & maskLaborable] <- "Si"
aggEs_ocupacional <- aggregate(dades$Numero_expedient,
by=dades["Es_ocupacional"], FUN=length)
ggplot(aggEs_ocupacional, aes(x="", y=x, fill=Es_ocupacional)) +
geom_bar(width = 1, stat = "identity", color = "black") +
ggtitle(glue("Fig. 2. Diagrama de barres apilades del recompte dels
conductors en funció de si l'accident va tenir lloc durant
horari ocupacional o no.")) +
xlab(glue("Es_ocupacional")) +
ylab("Nombre")
nNo_Es_ocupacional <- aggEs_ocupacional[1, 2]
nSi_Es_ocupacional <- aggEs_ocupacional[2, 2]
print(glue("Del conjunt de conductors a estudiar, {nSi_Es_ocupacional} es desplaçaven durant horari ocupacional i altres {nNo_Es_ocupacional} no."))## Del conjunt de conductors a estudiar, 842 es desplaçaven durant horari ocupacional i altres 2016 no.En aquest cas, coneixem de la pràctica anterior de la existència d’un cert nombre d’observacions en les que constava la variable de “Nom_districte” com “Desconegut” i, atès que a l’hora de treballar-lo amb un model supervisat podria causar confusió en la interpretació dels resultats i que es tracta d’un nombre reduït, tot i que sí manualment es podria indicar en quin Districte s’ubiquen a partir de la dada de l’adreça postal que sí en disposaríem, trobem oportú excloure’ls del conjunt de dades a treballar:
maskDistDescon <- dades$Nom_districte == "Desconegut"
dadesDistDescon <- dades[maskDistDescon, ]
nDadesDistDescon <- nrow(dadesDistDescon)
dades_ <- dades[!maskDistDescon, ]
aggEs_mon_treball <- aggregate(dades_$Numero_expedient,
by=dades_["Es_mon_treball"], FUN=length)
ggplot(aggEs_mon_treball, aes(x="", y=x, fill=Es_mon_treball)) +
geom_bar(width = 1, stat = "identity", color = "black") +
ggtitle(glue("Fig. 4. Diagrama de barres apilades del recompte dels
conductors en funció de si el motiu del seu desplaçament tenia
relació amb el món del treball en Districte conegut.")) +
xlab(glue("Es_mon_treball")) +
ylab("Nombre")
nNo_Es_mon_treball <- aggEs_mon_treball[1, 2]
nSi_Es_mon_treball <- aggEs_mon_treball[2, 2]
print(glue(
"Del conjunt de conductors a estudiar, {nSi_Es_mon_treball} es desplaçaven per
algun motiu relacionat amb el món del treball i altres {nNo_Es_mon_treball} no.
En totals'han eliminat {nDadesDistDescon} conductors dels qui es desconeixia en
quin Districte va tenir lloc l'accident."))## Del conjunt de conductors a estudiar, 1316 es desplaçaven per
## algun motiu relacionat amb el món del treball i altres 1507 no.
## En totals'han eliminat 35 conductors dels qui es desconeixia en
## quin Districte va tenir lloc l'accident.I es constata que no s’ha produït cap modificació substancial en la variable depenent “Es_mon_treball”.
colsAnalisi <- c("Descripcio_sexe", "Tipus_vehicle_estandaritzat",
"VM2R_CODIF", "VM4R_CODIF", "V_no_permis_CODIF",
"Victimitzacio_est", "Nom_districte",
"Descripcio_dia_setmana", "Nom_mes", "Lleus_CODIF",
"Greus_CODIF", "Morts_CODIF", "VM2R_CODIF", "VUP_CODIF",
"Numero_victimes",
"Es_laborable", "Es_atropellament",
"Interve_conductor_novell"
)
for (i in seq(1, length(colsAnalisi), 1)){
colLabel <- colsAnalisi[i]
index <- i + 4
string <- glue("Fig. {index}. Variable {colLabel}.")
g <- ggplot(data=dades_, aes_string(x=colLabel)) +
geom_histogram(stat= 'count', fill = 'steelblue', color = "black") +
xlab(glue("{colLabel}")) + ylab("Freqüències") + ggtitle(string) +
theme(axis.text.x = element_text(angle = 290, vjust = 0.6, hjust = 0.1))
print(g)
}
Constatem que tant la variable estandaritzada de victimització com la nova variable “Es_atropellament” com també en les variables codificades i les variables que quantifiquen els diversos tipus de víctimes - morts, ferits greus i ferits lleus- presenten totes una classe predominant que representa més del 90% de les observacions i, per tant, no sembla recomenable emprar-les per bastir cap model predictiu ja que, en la pràctica, hi afegeixen complexitat al model sense aportar gaire càrrega explicativa.
En canvi, sí observem que la variable numèrica “Numero_victimes” (v. Fig. 19) tindria sentit mantenir-la; atès que en l’anterior PRA1 vam observar que estava correlacionada amb la variable que quantificava els ferits lleus en un accident de trànsit determinat, al prescindir d’aquesta segona resulta lògic poder-la recuperar. En tot cas, sí serà oportú també codificar-la, tot cercant respondre si en l’accident en qüestió va haver-hi 2 o més víctimes - “dosVictimes_CODIF”-
Per altra banda, fem un nom cop d’ull a la variable “Descripcio_victimitzacio”:
aggVictmitzacio <- aggregate(dades_$Numero_expedient,
by=dades_["Descripcio_victimitzacio"],
FUN=length)
ggplot(aggVictmitzacio, aes(x="", y=x, fill=Descripcio_victimitzacio)) +
geom_bar(width = 1, stat = "identity", color = "black") +
ggtitle(glue("Fig. 23. Diagrama de barres apilades del recompte dels
conductors en funció del tipus de victimització.")) +
xlab(glue("Descripcio_victimitzacio")) +
ylab("Nombre")
I hi observem que podem extreure informació d’interès a partir de les classes que fan referència als ferits lleus, tot i que facilitar-ne la comprensió pels humans convindrà retocar un xic les etiquetes corresponents a cada classe, a més d’unificar les dues classes de “mort”:
dades_["Victimitizacio_est_"] <- ""
dades_$Victimitzacio_est_ <- sapply(strsplit(dades_$Descripcio_victimitzacio,
": "), "[", 2)
maskMorts <- grepl("Mort", dades_$Descripcio_victimitzacio)
dades_$Victimitzacio_est_[maskMorts] <- "Mort"
dades_$Victimitzacio_est_ <- str_to_sentence(dades_$Victimitzacio_est_)
aggVictmitzacio <- aggregate(dades_$Numero_expedient,
by=dades_["Victimitzacio_est_"],
FUN=length)
ggplot(aggVictmitzacio, aes(x="", y=x, fill=Victimitzacio_est_)) +
geom_bar(width = 1, stat = "identity", color = "black") +
ggtitle(glue("Fig. 24. Diagrama de barres apilades del recompte dels
conductors en funció del tipus de victimització amb nova estandarització.")) +
xlab(glue("Victimitzacio_est_")) +
ylab("Nombre")
També preparem el conjunt de dades sel·leccionant també les variables categòriques “Descripcio_sexe”, “Nom_districte”, “Nom_mes” i “Descripcio_causa_mediata”. També realitzem la normalització amb les variables numèriques, tot realitzant la sincretització seguint l’exemple descrit en l’obra de P. Bruce, A. Bruce i P. Gedeck (BRUCE, BRUCE i GEDECK, 2022: 242):
dummies_cat <- as.data.frame(model.matrix(~ -1 + Tipus_vehicle_estandaritzat +
Victimitzacio_est_ +
Descripcio_sexe +
Nom_districte +
Nom_mes +
Descripcio_causa_mediata +
Es_laborable +
Es_mon_treball +
Es_ocupacional +
Interve_conductor_novell,
data=dades_))
vars_num_ <- c( "Numero_victimes", "Numero_vehicles_implicats",
"Antiguitat_carnet_min", "Edat",
"Vehicles motoritzats de 2 rodes implicats",
"Vehicles motoritzats de quatre rodes implicats",
"Vehicles sense permís de conducció implicats",
"Vehicles d'Ús Professional implicats")
dadesNoSup <- scale(dades_[vars_num_], center=TRUE, scale=TRUE)
dadesNoSup <- merge(x=dadesNoSup, y=dummies_cat, by=0)
dadesNoSup <- dadesNoSup[2:length(colnames(dadesNoSup))]De la mateixa manera, també preparem un conjunt de dades preparat per la seva modelització amb un model supervisat emprant tant les 4 variables del dataset original, les 4 variables noves, les 2 variables estandaritzades i les 8 variables codificades. També s’acaben d’eliminar alguns caràcters que resulten problemàtics per alguns dels mètodes que s’empraran més endavant:
varsGower <- c("Descripcio_sexe", "Tipus_vehicle_estandaritzat",
"Victimitzacio_est_", "Descripcio_causa_mediata",
"Nom_mes", "Nom_districte",
"Numero_victimes", "Numero_vehicles_implicats",
"Antiguitat_carnet_min", "Edat",
"Vehicles motoritzats de 2 rodes implicats",
"Vehicles motoritzats de quatre rodes implicats",
"Vehicles sense permís de conducció implicats",
"Vehicles d'Ús Professional implicats",
"Es_laborable", "Es_ocupacional", "Es_mon_treball")
dadesGower <- dades_[varsGower]
colsFactorGower <- c("Descripcio_sexe", "Tipus_vehicle_estandaritzat",
"Nom_districte",
"Victimitzacio_est_", "Nom_mes", "Descripcio_causa_mediata",
"Es_laborable", "Es_ocupacional", "Es_mon_treball")
dadesGower[colsFactorGower] <- lapply(dadesGower[colsFactorGower],
as.factor)
dades_$Tipus_vehicle_estandaritzat <- gsub("d'", "",
dades_$Tipus_vehicle_estandaritzat)
dades_$Victimitzacio_est_ <- gsub("d'", "",
dades_$Victimitzacio_est_)
dades_$Descripcio_causa_mediata <- gsub("d'", "",
dades_$Descripcio_causa_mediata)
dades_$Nom_mes <- gsub("ç", "s", dades_$Nom_mes)
dades_$Tipus_vehicle_estandaritzat <-
stri_trans_general(str = dades_$Tipus_vehicle_estandaritzat,
id = "Latin-ASCII")
dades_$Victimitzacio_est_ <-
stri_trans_general(str = dades_$Victimitzacio_est_,
id = "Latin-ASCII")
dades_$Descripcio_causa_mediata <-
stri_trans_general(str = dades_$Descripcio_causa_mediata,
id = "Latin-ASCII")
dades_$Nom_districte <-
stri_trans_general(str = dades_$Nom_districte,
id = "Latin-ASCII")
varsSup <- c("Descripcio_sexe", "Tipus_vehicle_estandaritzat",
"Victimitzacio_est_", "Nom_mes", "Nom_districte",
"Descripcio_causa_mediata",
"Victimes_CODIF",
"Vehicles_CODIF", "VM2R_CODIF", "VM4R_CODIF",
"V_no_permis_CODIF", "VUP_CODIF", "Interve_conductor_novell",
"Edat_CODIF",
"Es_laborable", "Es_ocupacional", "Es_mon_treball")
dadesSup <- dades_[varsSup]
# dadesSup[varsSup] <- lapply(dadesSup[varsSup],as.factor)4.2 Exercici 1
Es genera un model no supervisat. S’analitzen, mostren i comenten les mesures de qualitat del model generat. Es comenten les conclusions.
En primer lloc, comprovem formalment si és factible o no la clusterització d’aquest conjunt de dades mitjançant el coeficient de Hopkins, tal i com es suggereix en aquest article de Data Novia:
res <- get_clust_tendency(dadesNoSup, 50, graph = FALSE)
# Hopkins statistic
res$hopkins_stat## [1] 0.780252Atès que el valor del coeficient de Hopkins té uns distribució 0,1 i que un valor proper a 1 indica una alta probabilitat que el conjunt de dades contingui clústers naturals; en aquest cas el resultat - 0.78025- ens indica que sí hi ha una probabilitat força elevada que existeixin clústers naturals.
Atès que la pregunta que plantejem en aquest projecte és conèixer si els conductos accidentats es traslladaven per un motiu relacionat amb el món del treball i, per tant, ens interessa conèixer si existirien dos grups ben definits. En canvi, si observèssim que hi ha grups millor definits amb tres o més grups, caldria pensar que aquest tipus de modelització no seria el més adequat. Per això, realitzarem la comprovació amb la hipòtesi 2 , 3, i 4 grups amb el model K-means que empra la distància euclidiana per la seva classificació, tot fent-ne la seva representació gràfica amb la funció fviz_cluster() tal i com es suggereix en aquest article de Data Novia:
lstResultats <- c()
for (i in c(2,3,4,5))
{
res.km <- kmeans(dadesNoSup, centers=i)
lstResultats <- c(lstResultats, res.km)
index <- i + 24 - 1
title <- glue("Fig. {index}. Representació amb {i} clústers.")
print(fviz_cluster(res.km, data = dadesNoSup,
geom = "point",
ellipse.type = "convex",
ggtheme = theme_bw(), main=title ))
}
És constatable que el resultat està ben lluny, tant en el cas d’obtenir el resultat per només dos grups com pels casos de valor k de tres o quatre. Aquest resultat serrtia fruït de la existència de les 7 variables categòriques que, simplement, no encaixen bé a l’hora de realitzar el càlcul mitjançant la distància euclidiana, es a dir, amb la mitjana del centroide del polígon delimitat pels punts. Això, tal i com adverteixen P. Bruce, A. Bruce i P. Gedeck pot conduir a resultats molt problemàtics amb el model K-means (veure BRUCE, BRUCE i GEDECK, 2022: 308).
També comprovarem si la división entre dos grups - k=2- seria la classificació més òptima, tot realitzant-ne la selecció mitjançant els criteris de la silueta mitja i el de Calisnki-Harabasz:
fit_ch <- kmeansruns(dadesNoSup, krange = 1:10, criterion = "ch")
fit_asw <- kmeansruns(dadesNoSup, krange = 1:10, criterion = "asw")
ch <- fit_ch$bestk
asw <- fit_asw$bestk
print(glue("Segons el criteri de la silueta mitja, el citeri k més òptim seria
{asw} mentres que segons el criteri de Calisnki-Harabasz seria {ch}."))## Segons el criteri de la silueta mitja, el citeri k més òptim seria
## 5 mentres que segons el criteri de Calisnki-Harabasz seria 5.plot(1:10,fit_ch$crit,type="o",col="#de41f0",pch=1,lwd = 2,xlab="Número de clústers",ylab="Criteri Calinski-Harabasz",
main = "Fig. 29. Representació gràfica del nombre de clúster optimitzats
segons el criteri de Calinski-Harabasz.")
grid()
plot(1:10,fit_asw$crit,type="o",col="#de41f0",pch=1,lwd = 2,xlab="Número de clústers",ylab="Criteri silueta mitja",
main = "Fig. 30. Representació gràfica del nombre de clúster optimitzats
segons el criteri de la silueta mitja.")
grid()
S’observa que en ambdós criteris la k òptima seria 5. En tot cas, també cerquem experimentar quin seria el nombre òptim de grups d’acord amb l’anomenat mètode del colze, tal i com es proposa en aquest article de R-Bloggers:
set.seed(123)
# Compute and plot wss for k = 2 to k = 15.
k.max <- 15
wss <- sapply(1:k.max,
function(k){kmeans(dadesNoSup, k,
nstart=50,
iter.max = 15 )$tot.withinss})
plot(1:k.max, wss,
type="b", pch = 19, frame = FALSE,
xlab="Nombre de clústers K",
ylab="Total de la suma dels quadrats del grup",
main="Figura 31. Representació del mètode del colze.")
Observem que el nombre òptim de grups seria amb k=5. Es a dir, el model identifica fins 5 grups òptims per classificar als conductors del present conjunt de dades.
A continuació, cerquem comparar la classificació realitzada pel model amb k=2 amb la variable “Es_mon_treball”:
res.km <- kmeans(dadesNoSup, centers=2)
dadesNoSup["predKmeans"] <- as.factor(res.km$cluster)
dadesNoSup["Es_mon_treball"] <- as.factor(dades_$Es_mon_treball)
tb <- table(dadesNoSup$Es_mon_treball, dadesNoSup$predKmeans)
precisio <- round((tb[4] + tb[1]) / (tb[1] + tb[2] + tb[3] + tb[4]), 5) * 100
print(glue("La coincidència entre l'agrupament realitzat i la variable d'interès
és del {precisio} %."))## La coincidència entre l'agrupament realitzat i la variable d'interès
## és del 46.794 %.I representarem gràficament la relació entre les variables “Edat” i “Numero_victimes” (Fig. 32) per comparar-la amb l’agrupació que obtindríem amb la classificació de la variable “Es_mon_treball”:
ggplot(dadesNoSup, aes(x=Edat, y=Numero_victimes, color=predKmeans)) +
geom_point(shape=19) +
labs(title = glue("Fig. 32. Clustering Edat i Nombre de víctimes (2 grups).")) +
theme_minimal()
ggplot(dadesNoSup, aes(x=Edat, y=Numero_victimes, color=Es_mon_treball)) +
geom_point(shape=19) +
labs(title =
glue("Fig. 33. Agrupació segons la variable dicotòmica Es_mon_treball
de les variables Edat i Nombre de víctimes.")) +
theme_minimal()
Constatem que la precisió és del 46.8 % de coincidències amb la variable “Es_mon_treball” però, en canvi, observem que la classificació d’aquests dos grups no semblaria ajustar-se a la classificació amb la variable “Es_mon_treball”.
4.3 Exercici 2
Es genera de nou el model no supervisat anterior, però usant una mètrica de distància diferent. Es mostren i es comenten les mesures de qualitat del model generat. Addicionalment es comparen els dos models no supervisats amb mètriques de distància diferents. Es comenten les conclusions.
En aquest cas, seguirem la proposta que fan P. Bruce, A. Bruce i P. Gedeck per emprar la distància de Gower com la més adequada per treballar amb dades categòriques (BRUCE, BRUCE i GEDECK; 2022: 311-314), complementant la seva implementació amb R amb les indicacions d’aquest article en RPubs:
d <- cluster::daisy(dadesGower, metric='gower')
hcl <- hclust(d)
plot(hcl, main= "Fig. 33. Dendograma de classificació jeràrquica amb la distància de Gower.",
hang=-1)
rect.hclust(hcl, k = 2, border = "blue")
A primer cop d’ull, s’observa que un dels grups és força predominant; en canvi, si ho comparem amb la distribució original de la variable “Es_mon_treball”, resulta obvi que la classificació no sembla ajustar-se a aquesta categoria. En tot cas, cercarem comprovar-ho mitjançant la classificació que en fa la funció pam() de la llibreria cluster, que també estudiem en aquest article de ML for Analytics:
clusters <- cluster::pam(x = d, k = 2)I cerquem comparar les coincidències entre l’agrupació feta pel model amb les categories de la variable dicotòmica “Es_mon_treball”:
dadesGower['clusteringGower'] <- clusters$clustering
dadesGower$clusteringGower <- as.factor(dadesGower$clusteringGower)
tb <- table(dadesGower$Es_mon_treball, dadesGower$clusteringGower)
precisio <- round((tb[4] + tb[1]) / (tb[1] + tb[2] + tb[3] + tb[4]), 5) * 100
print(glue("La coincidència entre l'agrupament realitzat i la variable d'interès
és del {precisio} %."))## La coincidència entre l'agrupament realitzat i la variable d'interès
## és del 3.507 %.ggplot(dadesGower, aes(x=Edat, y=Numero_victimes, color=clusteringGower)) +
geom_point(shape=19) +
labs(title = glue("Fig. 35. Clustering Edat i Nombre de víctimes (2 grups)
amb la distància de Gower.")) +
theme_minimal()
ggplot(dadesGower, aes(x=Edat, y=Numero_victimes, color=Es_mon_treball)) +
geom_point(shape=19) +
labs(title =
glue("Fig. 36. Agrupació segons la variable dicotòmica Es_mon_treball
de les variables Edat i Nombre de víctimes.")) +
theme_minimal()
I, per una banda, constatem que amb el cas de la distància de Gower k=2 resultar en dos grups poc òptims (v. Fig. 35) i també que el nombre de coincidències entre l’agrupament realitzat i la variable d’interès que cerquem poder predir és molt baix (V. Fig. 36). Per aquest motiu, concloem que aquest mètode no resultaria gens útil per poder identificar com dos grups ben definits les classes positiva i negativa de la variable “Es_mon_treball”.
4.4 Exercici 3
S’apliquen els algorismes DBSCAN i OPTICS de forma correcta.
Es proven, descriuen i interpreten els resultats amb diferents valors
d’eps i minPts. S’obté una mesura de com és de
bo l’agrupament. Es comparen els resultats obtinguts dels models
anteriors i DBSCAN. Es comenten les conclusions.
Realitzarem la implementació dels algorismes OPTICS i DBSCAN amb la llibreria DBSCAN. En primer lloc, implementem OPTICS assignant al paràmetre minPts o la densitat mínima acceptada al voltant d’un centroide i en representarem la seva accessibilitat:
dropCol <- c("Es_mon_treball", "predKmeans")
dadesNoSup <- dadesNoSup[ , !(colnames(dadesNoSup) %in% dropCol)]
opt_res50 <- dbscan::optics(dadesNoSup, minPts=50)
opt_res50## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 50, eps = 9.30663550014333, eps_cl = NA, xi = NA
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xiplot(opt_res50, main = "Fig. 36. Accessibilitat amb densitat mínima de 50.")
opt_res10 <- optics(dadesNoSup, minPts=10)
opt_res10## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 10, eps = 8.03338573057149, eps_cl = NA, xi = NA
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xiplot(opt_res10, main = "Fig. 37. Accessibilitat amb densitat mínima de 10.")
En el cas d’una parametrització de de densitat mínima de 50, s’observen fins quatre intervals diferents en el conjunt de dades, sent l’interval més clar entre 2 dels grups a la banda dreta de l’ordenació, estant delimitats pels intervals vall que s’observen (v. Fig. 36). En canvi, si reduïm la densitat mínima a només 10 s’hi observen molt més intervals i, per tant, més grups.
En canvi, per implementar DBSCAN, emprem el mètode extractDBSCAN() de la mateixa llibreria utilitzada i, tot consultant tant la documentació oficial i aquest article de STHDA emprem el paràmetre eps per definir-hi la distància entre els punts per que l’algorisme l’identifiqui com grup:
eps <- c(2, 3, 4, 5)
for (i in seq(1, length(eps), 1)){
e <- eps[i]
res <- extractDBSCAN(opt_res50, eps=e)
print(res)
index <- i + 36
title1 <- glue("Fig. {index}a. Accessibilitat DBSCAN amb eps={e}
amb densitat mínima 50.")
plot(res, main=title1)
title2 <- glue("Fig. {index}b. Clustering DBSCAN amb eps={e}
amb densitat mínima 50.")
hullplot(dadesNoSup, res, main=title2)
}## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 50, eps = 9.30663550014333, eps_cl = 2, xi = NA
## The clustering contains 0 cluster(s) and 2823 noise points.
##
## 0
## 2823
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 50, eps = 9.30663550014333, eps_cl = 3, xi = NA
## The clustering contains 1 cluster(s) and 444 noise points.
##
## 0 1
## 444 2379
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 50, eps = 9.30663550014333, eps_cl = 4, xi = NA
## The clustering contains 2 cluster(s) and 60 noise points.
##
## 0 1 2
## 60 2673 90
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 50, eps = 9.30663550014333, eps_cl = 5, xi = NA
## The clustering contains 1 cluster(s) and 27 noise points.
##
## 0 1
## 27 2796
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
for (i in seq(1, length(eps), 1)){
e <- eps[i]
res <- extractDBSCAN(opt_res10, eps=e)
print(res)
index <- i + 40
title1 <- glue("Fig. {index}a. Accessibilitat DBSCAN amb eps={e}
amb densitat mínima 10.")
plot(res, main=title1)
title2 <- glue("Fig. {index}b. Clustering DBSCAN amb eps={e}
amb densitat mínima 10.")
hullplot(dadesNoSup, res, main=title2)
}## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 10, eps = 8.03338573057149, eps_cl = 2, xi = NA
## The clustering contains 5 cluster(s) and 2627 noise points.
##
## 0 1 2 3 4 5
## 2627 150 9 5 6 26
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 10, eps = 8.03338573057149, eps_cl = 3, xi = NA
## The clustering contains 4 cluster(s) and 231 noise points.
##
## 0 1 2 3 4
## 231 2528 3 2 59
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 10, eps = 8.03338573057149, eps_cl = 4, xi = NA
## The clustering contains 4 cluster(s) and 16 noise points.
##
## 0 1 2 3 4
## 16 2686 19 93 9
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
## OPTICS ordering/clustering for 2823 objects.
## Parameters: minPts = 10, eps = 8.03338573057149, eps_cl = 5, xi = NA
## The clustering contains 2 cluster(s) and 5 noise points.
##
## 0 1 2
## 5 2808 10
##
## Available fields: order, reachdist, coredist, predecessor, minPts, eps,
## eps_cl, xi, cluster
Observem que, en el cas de densitat mínima de 50, només obtenim dos grups amb distància 4 però, en canvi, el tamany d’ambdós grups és molt dispar (v. Fig. 39a i 39b) i mols allunyat de la distribució de la variable “Es_mon_treball” (v. Fig. 4). I en el cas de la densitat mínina 10 només s’obtenen 2 grups clarament diferenciats amb distància 5 però, una vegada més, es constat que el tamany dels grup (v. Fig. 44a i 44b) és massa disjunt per poder-los considerar que tenen alguna relació amb la variable “Es_mon_treball”.
En darrer lloc, tot seguint la proposta de l’article de STHDA anteriorment referenciat, cercarem conèixer quina seria la distància més òptima per obtenir 2 grups en aquest conjunt de dades amb l’algorisme DBSCAN mitjançant la funció representada pel mètode KNNdistplot():
print(glue_col("{bold Fig. 45. Representació de la distància k.}"))## Fig. 45. Representació de la distància k.dbscan::kNNdistplot(dadesNoSup, k=2)
abline(h = 0, lty = 6)
I observem que la distància més òptima seria entre 3 i 4.
Si comparem el resultat obtingut amb el dels altre dos models no supervisats, novament hem de concloure que no resulta útil per poder predir el resultat de la varaible “Es_mon_treball”. Addicionalment, també constatem que amb l’agorisme DBSCAN s’observa que hi ha un grup predominant d’observacions en tot el conjunt de dades i el soroll en aquest conjunt de dades, una vegada indicada una distància adequada, és relativament reduït.
4.5 Exercici 4
Es seleccionen les mostres d’entrenament i de prova. Es justifiquen les proporcions seleccionades.
En primer lloc, apliquem els tests de Phi i Cramer
cols <- colnames(dadesSup)
colsTests <- cols[cols != "Es_mon_treball"]
fn_tables <- function(nm) {table(dadesSup[[nm]],
dadesSup[["Es_mon_treball"]])}
lstTables <- lapply(colsTests, fn_tables)
for (i in seq(1, length(lstTables), 1)) {
t <- lstTables[[i]]
col <- colsTests[i]
phi <- round(Phi(t), 5)
cramer <- round(CramerV(t), 5)
print(glue_col("{underline {bold Taula {i}. Variable {col}}}"))
print(t)
print(glue("\n\nPer la variable {col} el valor del test de
Cramer és {cramer} i pel test de Phi és {phi}.\n\n"))
nFig <- 45 + i
string <- glue("Fig. {nFig}. Representació gràfica d'Es_mon_treball
vs. {col}.")
plot <- plot(t, col = c("lightblue","darkblue"), main = string)
}## Taula 1. Variable Descripcio_sexe
##
## No Si
## Dona 427 378
## Home 1080 938
##
## Per la variable Descripcio_sexe el valor del test de
## Cramer és 0.0043 i pel test de Phi és 0.0043.
## Taula 2. Variable Tipus_vehicle_estandaritzat
##
## No Si
## Vehicles motoritzats de 2 rodes 974 847
## Vehicles motoritzats de quatre rodes 310 230
## Vehicles sense permis de conduccio 221 161
## Vehicles Us Professional 2 78
##
## Per la variable Tipus_vehicle_estandaritzat el valor del test de
## Cramer és 0.17838 i pel test de Phi és 0.17838.
## Taula 3. Variable Victimitzacio_est_
##
## No Si
## Amb assistencia sanitaria en lloc accident 362 280
## Hospitalitzacio fins a 24h 990 884
## Hospitalitzacio superior a 24h 45 26
## Mort 2 2
## Rebutja assistencia sanitaria 108 124
##
## Per la variable Victimitzacio_est_ el valor del test de
## Cramer és 0.05886 i pel test de Phi és 0.05886.
## Taula 4. Variable Nom_mes
##
## No Si
## Abril 121 144
## Agost 108 87
## Desembre 115 85
## Febrer 108 77
## Gener 132 107
## Juliol 153 114
## Juny 133 130
## Maig 147 134
## Mars 109 107
## Novembre 140 132
## Octubre 128 105
## Setembre 113 94
##
## Per la variable Nom_mes el valor del test de
## Cramer és 0.0712 i pel test de Phi és 0.0712.
## Taula 5. Variable Nom_districte
##
## No Si
## Ciutat Vella 67 53
## Eixample 446 386
## Gracia 66 56
## Horta-Guinardo 123 70
## Les Corts 88 118
## Nou Barris 80 61
## Sant Andreu 127 71
## Sant Marti 196 184
## Sants-Montjuic 137 173
## Sarria-Sant Gervasi 177 144
##
## Per la variable Nom_districte el valor del test de
## Cramer és 0.11801 i pel test de Phi és 0.11801.
## Taula 6. Variable Descripcio_causa_mediata
##
## No Si
## Avancament defectuos/improcedent 62 71
## Canvi de carril sense precaucio 169 179
## Desobeir altres senyals 105 86
## Desobeir semafor 169 154
## Envair calcada contraria 3 2
## Fallada mecanica o avaria 1 0
## Gir indegut o sense precaucio 212 179
## Manca atencio a la conduccio 408 326
## Manca precaucio efectuar marxa enrera 16 14
## Manca precaucio incorporacio circulacio 60 58
## No cedir la dreta 24 22
## No respectar distancies 270 217
## No respectat pas de vianants 8 8
##
## Per la variable Descripcio_causa_mediata el valor del test de
## Cramer és 0.05884 i pel test de Phi és 0.05884.
## Taula 7. Variable Victimes_CODIF
##
## No Si
## No 978 951
## Si 529 365
##
## Per la variable Victimes_CODIF el valor del test de
## Cramer és 0.07901 i pel test de Phi és 0.07901.
## Taula 8. Variable Vehicles_CODIF
##
## No Si
## No 79 30
## Si 1428 1286
##
## Per la variable Vehicles_CODIF el valor del test de
## Cramer és 0.07671 i pel test de Phi és 0.07671.
## Taula 9. Variable VM2R_CODIF
##
## No Si
## No 311 251
## Si 1196 1065
##
## Per la variable VM2R_CODIF el valor del test de
## Cramer és 0.01954 i pel test de Phi és 0.01954.
## Taula 10. Variable VM4R_CODIF
##
## No Si
## No 1100 953
## Si 407 363
##
## Per la variable VM4R_CODIF el valor del test de
## Cramer és 0.00645 i pel test de Phi és 0.00645.
## Taula 11. Variable V_no_permis_CODIF
##
## No Si
## No 1044 906
## Si 463 410
##
## Per la variable V_no_permis_CODIF el valor del test de
## Cramer és 0.00466 i pel test de Phi és 0.00466.
## Taula 12. Variable VUP_CODIF
##
## No Si
## No 1460 1257
## Si 47 59
##
## Per la variable VUP_CODIF el valor del test de
## Cramer és 0.03581 i pel test de Phi és 0.03581.
## Taula 13. Variable Interve_conductor_novell
##
## No Si
## No 1033 955
## Si 474 361
##
## Per la variable Interve_conductor_novell el valor del test de
## Cramer és 0.04396 i pel test de Phi és 0.04396.
## Taula 14. Variable Edat_CODIF
##
## No Si
## Conductors d'entre 38 i 49 anys edat 338 352
## Conductors entre 30 i 37 anys edat 340 317
## Conductors fins 29 anys edat 470 300
## Conductors majors de 49 anys edat 359 347
##
## Per la variable Edat_CODIF el valor del test de
## Cramer és 0.09601 i pel test de Phi és 0.09601.
## Taula 15. Variable Es_laborable
##
## No Si
## No 494 195
## Si 1013 1121
##
## Per la variable Es_laborable el valor del test de
## Cramer és 0.20862 i pel test de Phi és 0.20862.
## Taula 16. Variable Es_ocupacional
##
## No Si
## No 1221 770
## Si 286 546
##
## Per la variable Es_ocupacional el valor del test de
## Cramer és 0.24631 i pel test de Phi és 0.24631.
En primer lloc, constatem que no s’observa cap correlació forta entre les 16 variables en consideració amb la variable dependent “Es_mon_treball”. Tot i així, observem que en el cas de dues les variables hi és de forma predominant una de les classes binàries: en el cas de “Vehicles_CODIF” (v. Taula 7), que respon de forma binària Si/No a la pregunta de si va haver-hi més de 2 vehicles en l’accident en el que va intervenir-hi la Guàrdia Urbana; i en el cas de la variable “VUP_CODIF” (v. Taula 11), que respon de forma binària Si/No respecte a si en l’accident va estar-hi implicat un vehicle d’ús professional com pot ser un autocar, taxi, furgoneta, maquinària d’obra… Per aquest motiu trobem oportú excloure ambdues variables per reduir el soroll i facilitar també la seva interpretabilitat.
Per altra banda, també comprovem que en el cas de tres variables - “Tipus_vehicle_estandaritzat” (v. Taula 2), “Victimitzacio_est_” (v. Taula 3) i “Descripcio_causa_mediata” (v. Taula 5)- el tamany de les classes respectives estaria molt desacompensat i, possiblement, una partició estàndard de 4/5 pel conjunt d’entrenamen i tot deixant 1/5 pel conjunt de testeig comportaria que el conjunt d’entrenament molt fàcilment resultés esbiaixat excloent classes senceres. Una possible solució podria ser aplicar una tècnica de sobremostreig per aquells registres amb classes de tamany molt reduït (v. BRUCE, BRUCE i GEDECK, 2022: 226-227), tot i que en aquest cas potser no seria el mètode més adequat atès que es tracta d’un mostreig amb 2823 observacions i, per tant, no es pot considerar de tamany petit i que és el cas d’ús més freqüent per aquest primer mètode proposat.
En canvi, trobem més adequat recòrrer a la validació creuada, generant 5 conjunts de dades d’entrenament cadascun amb les 4/5 de les observacions i que cercarà validar-se amb la 1/5 de les dades restants (v. BRUCE, BRUCE i GEDECK, 2022: 152; i NIELD, 2022: 185-190). Per això, en l’Exercici 5 aplicarem una proporció de 4/5 pel dataset d’entrenament i 1/5 pel de testeig, mentres que en l’Exercici 6 posarem en pràctica la validació creuada amb 5 subconjunts de dades de testeig diferents.
4.6 Exercici 5
Es generen regles i es comenten i interpreten les més significatives. S’extreuen les regles del model en format text i gràfic. Addicionalment, es genera la matriu de confusió per a mesurar la capacitat predictiva de l’algoritme, tenint en compte les diferents mètriques associades a aquesta matriu (precisió, sensibilitat, especificitat…). Es comparen i interpreten els resultats (sense i amb opcions de poda), explicant els avantatges i els inconvenients del model generat respecte a un altre mètode de construcció. S’avalua la taxa d’error de l’arbre generat, l’eficiència a la classificació (a les mostres d’entrenament i test) i la comprensibilitat del resultat. Es comenten les conclusions.
En primer lloc, generem el conjunt de dades d’entrenament amb 4/5 de les observacions:
dummy <- dadesSup
dummy[] <- lapply(dummy, factor)
colsExcloses <- c("VUP_CODIF", "Vehicles_CODIF", "Es_mon_treball")
y <- dummy$Es_mon_treball
colsSup <- !colnames(dummy) %in% colsExcloses
x <- dummy[colsSup]
split_prop <- 5
indexes = sample(1:nrow(dummy),
size=floor(((split_prop-1)/split_prop)*nrow(dummy)))
train_x <- x[indexes, ]
train_y <- y[indexes]
test_x <- x[-indexes, ]
test_y <- y[-indexes]
summary(train_x)## Descripcio_sexe Tipus_vehicle_estandaritzat
## Dona: 629 Vehicles motoritzats de 2 rodes :1460
## Home:1629 Vehicles motoritzats de quatre rodes: 422
## Vehicles sense permis de conduccio : 312
## Vehicles Us Professional : 64
##
##
##
## Victimitzacio_est_ Nom_mes
## Amb assistencia sanitaria en lloc accident: 503 Maig :235
## Hospitalitzacio fins a 24h :1508 Novembre:231
## Hospitalitzacio superior a 24h : 59 Abril :214
## Mort : 4 Juliol :210
## Rebutja assistencia sanitaria : 184 Juny :204
## Gener :185
## (Other) :979
## Nom_districte Descripcio_causa_mediata
## Eixample :666 Manca atencio a la conduccio :591
## Sant Marti :293 No respectar distancies :393
## Sarria-Sant Gervasi:259 Gir indegut o sense precaucio :317
## Sants-Montjuic :247 Canvi de carril sense precaucio:275
## Les Corts :171 Desobeir semafor :250
## Horta-Guinardo :164 Desobeir altres senyals :153
## (Other) :458 (Other) :279
## Victimes_CODIF VM2R_CODIF VM4R_CODIF V_no_permis_CODIF
## No:1562 No: 452 No:1631 No:1578
## Si: 696 Si:1806 Si: 627 Si: 680
##
##
##
##
##
## Interve_conductor_novell Edat_CODIF
## No:1589 Conductors d'entre 38 i 49 anys edat:560
## Si: 669 Conductors entre 30 i 37 anys edat :509
## Conductors fins 29 anys edat :618
## Conductors majors de 49 anys edat :571
##
##
##
## Es_laborable Es_ocupacional
## No: 550 No:1599
## Si:1708 Si: 659
##
##
##
##
## summary(train_y)## No Si
## 1202 1056summary(test_x)## Descripcio_sexe Tipus_vehicle_estandaritzat
## Dona:176 Vehicles motoritzats de 2 rodes :361
## Home:389 Vehicles motoritzats de quatre rodes:118
## Vehicles sense permis de conduccio : 70
## Vehicles Us Professional : 16
##
##
##
## Victimitzacio_est_ Nom_mes
## Amb assistencia sanitaria en lloc accident:139 Juny : 59
## Hospitalitzacio fins a 24h :366 Octubre: 59
## Hospitalitzacio superior a 24h : 12 Juliol : 57
## Mort : 0 Gener : 54
## Rebutja assistencia sanitaria : 48 Abril : 51
## Agost : 46
## (Other):239
## Nom_districte Descripcio_causa_mediata
## Eixample :166 Manca atencio a la conduccio :143
## Sant Marti : 87 No respectar distancies : 94
## Sants-Montjuic : 63 Gir indegut o sense precaucio : 74
## Sarria-Sant Gervasi: 62 Canvi de carril sense precaucio: 73
## Sant Andreu : 51 Desobeir semafor : 73
## Nou Barris : 37 Desobeir altres senyals : 38
## (Other) : 99 (Other) : 70
## Victimes_CODIF VM2R_CODIF VM4R_CODIF V_no_permis_CODIF
## No:367 No:110 No:422 No:372
## Si:198 Si:455 Si:143 Si:193
##
##
##
##
##
## Interve_conductor_novell Edat_CODIF
## No:399 Conductors d'entre 38 i 49 anys edat:130
## Si:166 Conductors entre 30 i 37 anys edat :148
## Conductors fins 29 anys edat :152
## Conductors majors de 49 anys edat :135
##
##
##
## Es_laborable Es_ocupacional
## No:139 No:392
## Si:426 Si:173
##
##
##
##
## summary(test_y)## No Si
## 305 260I cerquem bastir el model:
model1 <- C50::C5.0(train_x, train_y, rules=TRUE)
summary(model1)##
## Call:
## C5.0.default(x = train_x, y = train_y, rules = TRUE)
##
##
## C5.0 [Release 2.07 GPL Edition] Tue Aug 13 14:47:52 2024
## -------------------------------
##
## Class specified by attribute `outcome'
##
## Read 2258 cases (15 attributes) from undefined.data
##
## Rules:
##
## Rule 1: (7, lift 1.7)
## Victimitzacio_est_ = Amb assistencia sanitaria en lloc accident
## Nom_mes = Agost
## Nom_districte in {Ciutat Vella, Eixample, Nou Barris}
## Victimes_CODIF = No
## Es_laborable = Si
## Es_ocupacional = No
## -> class No [0.889]
##
## Rule 2: (7, lift 1.7)
## Victimitzacio_est_ = Rebutja assistencia sanitaria
## Descripcio_causa_mediata = Manca atencio a la conduccio
## Victimes_CODIF = No
## VM4R_CODIF = No
## Es_ocupacional = No
## -> class No [0.889]
##
## Rule 3: (23/4, lift 1.5)
## Tipus_vehicle_estandaritzat in {Vehicles motoritzats de 2 rodes,
## Vehicles motoritzats de quatre rodes,
## Vehicles sense permis de conduccio}
## Nom_districte in {Gracia, Horta-Guinardo, Nou Barris,
## Sarria-Sant Gervasi}
## Descripcio_causa_mediata = Desobeir semafor
## Es_laborable = Si
## Es_ocupacional = No
## -> class No [0.800]
##
## Rule 4: (23/4, lift 1.5)
## Victimitzacio_est_ in {Hospitalitzacio superior a 24h, Mort}
## Victimes_CODIF = No
## Es_ocupacional = No
## -> class No [0.800]
##
## Rule 5: (521/124, lift 1.4)
## Tipus_vehicle_estandaritzat in {Vehicles motoritzats de 2 rodes,
## Vehicles motoritzats de quatre rodes,
## Vehicles sense permis de conduccio}
## Es_laborable = No
## -> class No [0.761]
##
## Rule 6: (46/11, lift 1.4)
## Victimitzacio_est_ = Hospitalitzacio fins a 24h
## Nom_districte = Eixample
## Descripcio_causa_mediata = Gir indegut o sense precaucio
## Interve_conductor_novell = No
## Es_ocupacional = No
## -> class No [0.750]
##
## Rule 7: (208/57, lift 1.4)
## Tipus_vehicle_estandaritzat in {Vehicles motoritzats de 2 rodes,
## Vehicles motoritzats de quatre rodes,
## Vehicles sense permis de conduccio}
## Victimitzacio_est_ = Amb assistencia sanitaria en lloc accident
## Nom_mes in {Febrer, Gener, Juliol, Maig, Novembre, Octubre, Setembre}
## Es_ocupacional = No
## -> class No [0.724]
##
## Rule 8: (495/139, lift 1.3)
## Tipus_vehicle_estandaritzat in {Vehicles motoritzats de 2 rodes,
## Vehicles motoritzats de quatre rodes,
## Vehicles sense permis de conduccio}
## Victimes_CODIF = Si
## Es_ocupacional = No
## -> class No [0.718]
##
## Rule 9: (80/23, lift 1.3)
## Tipus_vehicle_estandaritzat in {Vehicles motoritzats de 2 rodes,
## Vehicles motoritzats de quatre rodes,
## Vehicles sense permis de conduccio}
## Victimitzacio_est_ = Hospitalitzacio fins a 24h
## Descripcio_causa_mediata = Manca atencio a la conduccio
## Edat_CODIF = Conductors entre 30 i 37 anys edat
## Es_ocupacional = No
## -> class No [0.707]
##
## Rule 10: (62/18, lift 1.3)
## Tipus_vehicle_estandaritzat in {Vehicles motoritzats de 2 rodes,
## Vehicles motoritzats de quatre rodes,
## Vehicles sense permis de conduccio}
## Nom_districte in {Ciutat Vella, Gracia, Horta-Guinardo, Nou Barris,
## Sants-Montjuic, Sarria-Sant Gervasi}
## Descripcio_causa_mediata = Gir indegut o sense precaucio
## Es_ocupacional = No
## -> class No [0.703]
##
## Rule 11: (167/54, lift 1.3)
## Tipus_vehicle_estandaritzat = Vehicles motoritzats de 2 rodes
## Descripcio_causa_mediata = No respectar distancies
## Es_ocupacional = No
## -> class No [0.675]
##
## Rule 12: (76/25, lift 1.3)
## Descripcio_causa_mediata = Desobeir altres senyals
## Interve_conductor_novell = No
## Es_ocupacional = No
## -> class No [0.667]
##
## Rule 13: (64/2, lift 2.0)
## Tipus_vehicle_estandaritzat = Vehicles Us Professional
## -> class Si [0.955]
##
## Rule 14: (659/219, lift 1.4)
## Es_ocupacional = Si
## -> class Si [0.667]
##
## Rule 15: (1562/792, lift 1.1)
## Victimes_CODIF = No
## -> class Si [0.493]
##
## Default class: No
##
##
## Evaluation on training data (2258 cases):
##
## Rules
## ----------------
## No Errors
##
## 15 701(31.0%) <<
##
##
## (a) (b) <-classified as
## ---- ----
## 824 378 (a): class No
## 323 733 (b): class Si
##
##
## Attribute usage:
##
## 91.10% Victimes_CODIF
## 70.99% Es_ocupacional
## 49.78% Tipus_vehicle_estandaritzat
## 24.40% Es_laborable
## 20.42% Descripcio_causa_mediata
## 16.43% Victimitzacio_est_
## 9.52% Nom_mes
## 6.11% Nom_districte
## 5.40% Interve_conductor_novell
## 3.54% Edat_CODIF
## 0.31% VM4R_CODIF
##
##
## Time: 0.0 secs
predicted_model1 <- predict( model1, test_x, type="class" )
print(sprintf("La precisió de l'arbre sense podar és del %.4f %%.",
100*sum(predicted_model1 == test_y) / length(predicted_model1)))## [1] "La precisió de l'arbre sense podar és del 62.4779 %."mat_conf <- table(test_y, Predicted=predicted_model1); mat_conf## Predicted
## test_y No Si
## No 199 106
## Si 106 154# TN: mat_conf[1]
# FP: mat_conf[2]
# FN: mat_conf[3]
# TP: mat_conf[4]
# sensitivity
sensitivitat <- mat_conf[4] / (mat_conf[4] + mat_conf[3])
print(glue("\n\nLa sensitivitat de la predicció és {round(sensitivitat, 4)}."))##
## La sensitivitat de la predicció és 0.5923.# specifity
especificitat <- mat_conf[1] / (mat_conf[1] + mat_conf[2])
print(glue("\n\nLa especificitat de la predicció és {round(especificitat, 4)}."))##
## La especificitat de la predicció és 0.6525.En primer lloc, tal i com ja vam apuntar en l’anterior exercici 5, s’observa una alta variabilitat de resultats que és fruït del reduït nombre d’alguns grups que, al ser exclosos del conjunt de dades d’entrenament, resulta en que tant les regles com les prediccions presenten una variabilitat relativament elevada. En tot cas, sí s’observa que la precisió dels model es trobaria al voltant del 64 % i també una sensitivitat molt més elevada que l’especificitat, podent-se qualificar la seva capacitat predictiva com només acceptable.
En el darrer resultat observat s’han observat fins 102 nodes però només amb només amb una regal que poguem tenir en veritable consideració si tenim en compte tant la proporció de l’encert com el nombre de casos: la Regla 4 referent a que s’observa una tendència quasi total a que siguin conductors que conduïssin un vehicle d’ús professional els que es desplacessin per una causa relacionada mb el món del treball.
A continuació, ara presentarem la mateixa predicció però podant-ne l’arbre resultant parametritzant que només accepti nodes amb més de 30 mostres:
control30 = C5.0Control(minCases = 30)
png(file = 'arbre_decisio_model_Fig_61.png', width = 6000, height = 4000)
model30 <- C50::C5.0(train_x, train_y, control = control30)
plot(model1, type="s")
dev.off()## png
## 2if (.Platform['OS.type'] == "windows"){
shell.exec(getwd())
} else {
system(paste(Sys.getenv("R_BROWSER"), getwd()))
}
predicted_model30 <- predict( model30, test_x, type="class" )
mat_conf <- table(test_y, Predicted=predicted_model30); mat_conf## Predicted
## test_y No Si
## No 203 102
## Si 118 142print(glue("\n"))print(sprintf("La precisió de l'arbre és: %.4f %%.",100*sum(predicted_model30 == test_y) / length(predicted_model30)))## [1] "La precisió de l'arbre és: 61.0619 %."# sensitivity
sensitivitat <- mat_conf[4] / (mat_conf[4] + mat_conf[3])
print(glue("\n\nLa sensitivitat de la predicció és {round(sensitivitat, 4)}."))##
## La sensitivitat de la predicció és 0.582.# specifity
especificitat <- mat_conf[1] / (mat_conf[1] + mat_conf[2])
print(glue("\n\nLa especificitat de la predicció és {round(especificitat, 4)}."))##
## La especificitat de la predicció és 0.6324.En aquest cas, l’arbre es redueix considerablement en el nombre de nodes (v. Fig. 61), tot reduint-se un xic la precisió però també reduint-se de forma perceptible la capacitat del model per poder classificar correctament la classe positiva, es a dir, per classificar si un conductor accidentat i ferit es desplaçava per una causa relacionada amb el món del treball. L’única regla clara seria que identifica una tendència a que siguin conductors de ciclomotors i motocicletes en horari ocupacional - de 6 a 10h. i de 13 a 16h.
Atès a la comparació dels resultats observats a partir del mateix conjunt de dades d’entrenament, entenem que el millor model tots tres seria el segon, amb l’arbre podat per que el nombre mínim de casos observats sigui 30 ja que resulta molt més comprensible pels humans. També constatem que en el cas concret d’aquest problema, la modelització mitjançant l’arbre de decisió ens permet obtenir conclusions més rellevants que no pas amb els models no supervisats emprats en Exercicis anteriors.
4.7 Exercici 6
Es prova amb una variació o un altre enfocament algorítmic. Es detalla, comenta i avalua la qualitat de classificació. Es comparen i es comenten els resultats de manera exhaustiva amb el mètode de construcció anterior.
Tal i com vam indicar en l’anterior Exercici 4, cercarem ara aplicar el model de l’arbre de decisió aplicant-ne el mètode de la validació creuada i seguirem la proposta per sel·leccionar quina és la manera més òptima per obtenir l’arbre podat - mitjançant la funció prune.misClass - descrita en aquest article de R. Kelly en RPubs tot fent ús de la llibreria tree i el mètode createDataPartion() de la llibreria caret:
dummy <- dadesSup
dummy[] <- lapply(dummy, factor)
colsExcloses <- c("VUP_CODIF", "Vehicles_CODIF")
colsSup <- !colnames(dummy) %in% colsExcloses
dummy_ <- dummy[colsSup]
split <- createDataPartition(y=dummy_$Es_mon_treball, p=4/5, list=FALSE)
train <- dummy_[split,]
test <- dummy_[-split,]
#Create tree model
trees <- tree(Es_mon_treball~., train)
# plot(trees)
# text(trees, pretty=0)
cv.trees <- cv.tree(trees, FUN=prune.misclass)
plot(cv.trees,
main="Fig. 64. Puntuació dels models per classificacions errònies.")
S’observa que seri a partir de 3 només branques quan s’obtindria la poda més òptima, al menys des de la perspectiva d’obtenir el menor nombre de classificacions errònies:
prune.trees <- prune.tree(trees, best=3)
png(file = 'arbre_decisio_model4.png', width = 3000, height = 1000)
plot(prune.trees)
text(prune.trees, pretty=0)
dev.off()## png
## 2if (.Platform['OS.type'] == "windows"){
shell.exec(getwd())
} else {
system(paste(Sys.getenv("R_BROWSER"), getwd()))}
I constatem que obtenim un resultat molt similar al de l’anterior Figura 61, tot i que en aquest cas el model ens explicitaria que, de les quatre tipologies de vehicles accidentats, només no estaria clarament relacionada amb la classe negativa de l’atribut “Es_mon_treball” la corresponent al vehicles d’ús professional; en canvi, sí coincideix en indicar que la variable més important és “Es_ocupacional”, es a dir, la franja horària.
tree.pred <- predict(prune.trees, test, type='class')
confusionMatrix(tree.pred, test$Es_mon_treball, positive = "Si")## Confusion Matrix and Statistics
##
## Reference
## Prediction No Si
## No 245 141
## Si 56 122
##
## Accuracy : 0.6507
## 95% CI : (0.6098, 0.6901)
## No Information Rate : 0.5337
## P-Value [Acc > NIR] : 1.185e-08
##
## Kappa : 0.2836
##
## Mcnemar's Test P-Value : 2.167e-09
##
## Sensitivity : 0.4639
## Specificity : 0.8140
## Pos Pred Value : 0.6854
## Neg Pred Value : 0.6347
## Prevalence : 0.4663
## Detection Rate : 0.2163
## Detection Prevalence : 0.3156
## Balanced Accuracy : 0.6389
##
## 'Positive' Class : Si
## Ara bé, al comprovar la seva precisió, sensitivitat i especificitat constatem que aquest model, si bé és molt eficaç per encertar quins conductors es desplaçaven per una causa no relacionada amb el món del treball - l’especificitat té un valor elevat de 0.81-, en canvi resultaria descartable per que identifica amb un ajust inacceptablement baix - només 0.46- als conductors corresponents a la classe positiva.
4.8 Exercici 7
S’identifica quines possibles limitacions tenen les dades que has seleccionat per obtenir conclusions amb els models (supervisat i no supervisat). S’identifiquen possibles riscos de fer servir el model (mínim 300 paraules).
En primer lloc, presentarem la Taula de resultats més rellevants per, d’aquesta amnera, facilitar el desenvolupament de l’anàlisi posterior:
| Índex | Descripció de la mètrica | Mètrica |
|---|---|---|
| #1 | Nombre de variables quantitatives contínues | 8 |
| #2 | Nombre de variables categòriques | 19 |
| #3 | Nombre de variables quantitatives contínues descartades | 2 |
| #4 | Nombre de variables categòriques descartades | 4 |
| #5 | Coincidència entre classificacions k=2 mitjançant el mètode K-Means amb la variable dependent “Es_mon_treball” (percentils) | 46.8 |
| #6 | Coincidència entre classificacions k=2 mitjançant fent ús de la distància de Gower amb la variable dependent “Es_mon_treball” (percentils) | 3.5 |
| #7 | eps més òptim per k=2 | {3,4} |
| #8 | eps amb el nombre màxim de grups (5) i densitat mínima = 10 | {2, 3} |
| #9 | eps amb el nombre màxim de grups (2) i densitat mínima = 50 | 4 |
| #10 | Nombre de nodes en l’arbre de decisió sense podar | 102 |
| #11 | Nombre més òptim de nodes en l’arbre podat | 3 |
| #12 | Precisió (percentils) | 63.65 |
| #13 | Sensitivitat | 0.46 |
| #14 | Especificitat | 0.81 |
Atès als resultats observats, cal concloure que cap dels models resulta de tot satisfactori per donar resposta al problema plantejat: podem cercar predir si un conductor en un accident de trànsit en el que hi intervingués la Guàrdia Urbana de Barcelona durant l’any 2023 es desplaçava per un motiu relacionat amb el món del treball.
Ja la mateixa naturalesa de la pregunta plantejada ja imposa limitacions en l’adequació dels models emprats en aquest projecte. En el cas del models no supervisats ens trobaríem que, inclús si la classificació assignada pel model s’ajustés amb un elevat nombre d’observacions de la variable dependent binària, no es podria tampoc tenir la certesa si la classificació proposada pel model es correspon a aquesta classe o algun altra tendència subjacent en el conjunt de dades (v. Taula de resultats #9). En un altre cas, on la variable dependent hagués sigut multiclasse, potser llavors els resultats haurien sigut de més interès per donar resposta al problema plantejat.
En el cas dels models d’arbres de decisió implementats, si bé s’han demostrat eines més útils per donar resposta a la pregunta plantejada, també han possat de relleu una altra mancança ja referida al mateix conjunt de dades emprat i que fa referència al fet que moltes de les variables incloses i que formaven part del conjunt de dades treballat no s’han demostrat prou adequades per donar resposta a la pregunta d’estudi. En aquesta línia, resulta d’interès observar que una de les variables que s’ha demostrat més rellevants a l’hora de modelitzar la classificació mitjançant l’arbre de decisió, com és el cas de la delimitació de les franjes horàries que estan relacionades amb l’anada o tornada al loc de treball - “Es_ocupacional”- (v. Figures 63 i 65) i que s’ha generat a partir de les dades secundàries obtingudes d’una font externa com és l’anomenada Enquesta de mobilitat en dia feiner. Entenem que l’enriquiment d’aquest conjunt de dades, ja sigui facilitant-ne una estructuració diferent o bé amb l’addició de variables rellevants - altres que facin referència a usos socials generalitzats, a les condicions meteorològiques o a la lluminositat en el moment de l’accident…- podria ser una de les vies per millorar-ne la seva modelització i anàlisi.
Per altra banda, les mateixes dades presenten, per sí mateixes, un inconvenient fruït del sistema de recopilació atès que les dades completes dels conductors només es recopilen quan aquests han patit algun tipus de lessió o resulten mortes. Això les torna potencialment incompletes atès que un fet arbitrari, com el fet d’haver sigut ferit o no, és el que condueix a ser també comptabilitzat o no. De la resta de conductors, segons el protocol d’actuació de Guàrdia Urbana de Barcelona, només es recopilen les dades del permís de conduir - quan aquest existeix- però no les seves dades estadístiques ni tampoc es recopilen dades referents a la causa del seu desplaçament o similar.
Aquest fet és el que també explicaria que una de les limitacions observades amb els models d’arbres de decisió implementats és el fet que determinats grups d’observacions fossin molt petits i, per tant, poguessin resultar invisibilitzats per l’algorisme de l’arbre de decisió. Com ja s’ha apuntat, una alternativa podria trobar-se mitjançant la implementació d’algorismes de boosting (v. BRUCE, BRUCE i GEDECK, 2022: 263-265) o bé de sobremostreig de les classes rares o amb la seva ponderació (v. BRUCE, BRUCE i GEDECK, 2022: 226-227). D’altra manera, amb els models implementats fins ara els riscos a l’hora de predir sobre noves entrades de dades s’observen, especialment, a l’hora d’etiquetar correctament aquells conductors que sí s’estarien desplaçant per un motiu relacionat amb el món del treball (v. #14 en la Taula de Resultats), possiblement per la prevalència en el model entrenat de la classe corresponent a motocicletes i ciclomotors per predir la classe positiva de la variable “Es_mon_treball” (v. Fig. 47). En el cas de tenir en compte la resta de classes, com són els turismes i els vehicles que no requereixen de permís de conducció, s’observa com baixa l’especificitat del model entrenat (v. Fig. 63), es a dir, perdent bona part de la seva fiabilitat per poder predir la classe positiva.
4.9 Bibliografia
AUTORITAT DEL TRANSPORT METROPOLITÀ. 2023. Enquesta de mobilitat en dia feiner 2022. (EMEF 2022). Resum executiu, Barcelona: Autoritat del transport Metropolità. URL (darrera visita el 16-VI-2024).
BRUCE, P.; BRUCE, A.; i GEDECK, P. 2022. Estadística práctica para ciencia de datos con R y Python, Barcelona: Marcombo.
NIELD, T. 2022. Essential math for Data science: Take control of your data with fundamental linear algebra, probability, and statistics, Sebastopol, CA: O’Reilly.