Taller de Análisis de Correspondencia
Peter Olejua, olejua.peter@javeriana.edu.co
Pontificia Universidad Javeriana, Bogotá2017 septiembre 05
Problema
Un grupo investigador estudió a un grupo de recién nacidos de un determinado hospital registrando la siguiente información:
- Edad gestacional en semanas (egest)
- Sexo (sexo 1. Femenino 2. Masculino)
- Peso al nacer en gramos (pesonac)
- Edad de la madre en años (edadmadre)
- Presencia de catéter central (catéter 0. No 1. Si)
- Tipo de parto (tiparto 1. Eutócico 2. Vaginal Instrumentado 3. Cesárea programada 4. Cesárea No Programada)
- La madre recibió antibioticos (antibióticos 0. No 1. Si)
- La madre presento fiebre puerperal (fiebre 0. No 1. Si)
- Necesidad de ventilación mecánica (ventilación 0. No 1. Si)
- Días de hospitalización (estadía)
- Presencia de infección nosocomial (infección 0. No 1. Si)
A partir de esta base de datos:
Haga un análisis exploratorio de los datos
Categorice las variables continuas en variables categoricas según su criterio y mencione porque se categoriza así.
Haga un análisis de correspondencias simples entre tipo de parto y edad gestacional (mencione que supuestos se necesitan para realizarlo).
Haga un análisis de correspondencias simples entre estadia y edad gestacional.
Haga un análisis de correspondencias simples entre peso al nacer y ventilación mecánica.
Evalué si tiene sentido hacer un análisis de correspondencias múltiples entre todas las variables de la base de datos y en caso afirmativo, realicelo. De lo contrario, comente como se debería realizar (mencione que supuestos se necesitan para realizarlo).
Interprete todos los resultados obtenidos y de ser posible, de un nombre a los grupos creados.
Análisis exploratorio
library(readr)
datos <- read_csv("correspondencias.csv")
str(datos)
summary(datos)
table(datos$sexo)
datos$sexo <- factor(datos$sexo, levels = 1:2, labels = c('Mujeres', 'Hombres'))
table(unclass(datos$sexo), datos$sexo)
datos$sexo = relevel(datos$sexo, ref=1)
table(datos$tiparto)
datos$tiparto <- factor(datos$tiparto, levels = 1:4,
labels = c('Eutócico', 'Vaginal Instrumentado', 'Cesárea programada', 'Cesárea No Programada'))
table(unclass(datos$tiparto), datos$tiparto)
datos$tiparto = relevel(datos$tiparto, ref=1)
table(datos$antibioticos)
datos$antibioticos <- factor(datos$antibioticos, levels = 0:1, labels = c('No', 'Sí'))
table(unclass(datos$antibioticos), datos$antibioticos)
datos$antibioticos = relevel(datos$antibioticos, ref=1)
table(datos$fiebre)
datos$fiebre <- factor(datos$fiebre, levels = 0:1, labels = c('No', 'Sí'))
table(unclass(datos$fiebre), datos$fiebre)
datos$fiebre = relevel(datos$fiebre, ref=1)
table(datos$infeccion)
datos$infeccion <- factor(datos$infeccion, levels = 0:1, labels = c('No', 'Sí'))
table(unclass(datos$infeccion), datos$infeccion)
datos$infeccion = relevel(datos$infeccion, ref=1)
table(datos$cateter)
datos$cateter <- factor(datos$cateter, levels = 0:1, labels = c('No', 'Sí'))
table(unclass(datos$cateter), datos$cateter)
datos$cateter = relevel(datos$cateter, ref=1)
table(datos$ventilacion)
datos$ventilacion <- factor(datos$ventilacion, levels = 0:1, labels = c('No', 'Sí'))
table(unclass(datos$ventilacion), datos$ventilacion)
datos$ventilacion = relevel(datos$ventilacion, ref=1)summary(datos) id pesonac sexo egest
Min. : 1.0 Min. : 457 Mujeres:472 Min. :23.00
1st Qu.: 588.5 1st Qu.:2180 Hombres:528 1st Qu.:36.00
Median :1207.5 Median :2700 Median :38.00
Mean :1213.9 Mean :2628 Mean :36.86
3rd Qu.:1837.5 3rd Qu.:3140 3rd Qu.:39.00
Max. :2462.0 Max. :5200 Max. :43.00
NA's :8 NA's :13
tiparto emadre antibioticos fiebre
Eutócico :415 Min. :13.00 No :842 No:933
Vaginal Instrumentado: 44 1st Qu.:22.00 Sí :117 Sí: 67
Cesárea programada :214 Median :28.00 NA's: 41
Cesárea No Programada:323 Mean :27.52
NA's : 4 3rd Qu.:32.00
Max. :46.00
NA's :15
infeccion estadia cateter ventilacion
No:898 Min. : 0.000 No:965 No:950
Sí:102 1st Qu.: 2.000 Sí: 35 Sí: 50
Median : 5.000
Mean : 8.929
3rd Qu.:10.000
Max. :94.000
library(GGally)
ggpairs(datos[-1])
El peso al nacer es más bajo cuando hubo presencia de infección nosocomial, necesidad de ventilación mecánica o presencia de cateter central. Además el peso al nacer está altamente correlacionado con la edad gesatcional (0.8). Aquellos partos con infección o que necesitaron cateter tuvieron mayor estadía.
Categorización de las variables continuas
Peso al nacer
Categorizamos peso al nacer según la relación (gráfica) que guarda con las variables infección, ventilación y catéter.
summary(datos$pesonac) Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
457 2180 2700 2628 3140 5200 8 with(na.omit(datos),boxplot(pesonac ~ infeccion + cateter + ventilacion))
par(mfrow=c(1,3))
with(na.omit(datos),boxplot(pesonac ~ infeccion, main='Infección', ylab='Peso al nacer'))
with(na.omit(datos),boxplot(pesonac ~ cateter, main='Cateter'))
with(na.omit(datos),boxplot(pesonac ~ ventilacion, main='Ventilación'))
par(mfrow=c(1,1))Las diferencias más claras se observan en la variable cateter. Entonces selecionamos los rangos [0,2000), [2000, 3500) y [3500,+). Además por interés clínico desagregamos la categoría de menores a 2000 en menores y mayores a 1500
datos$peso_cut <- cut(datos$pesonac, ordered_result = T,
breaks = c(0,1500,2000,3500,Inf),
labels = c("[0,1500)", "[1500, 2000)", "[2000, 3500)", "[3500,+)"),
right = F)
summary(datos$peso_cut) [0,1500) [1500, 2000) [2000, 3500) [3500,+) NA's
81 105 683 123 8 Edad gestacional
La edad gestacional está correlacionada con el peso al nacer. Los rangos son seleccionados por las categorías del peso al nacer cortado.
by(INDICES = datos$peso_cut,datos$egest,summary)datos$peso_cut: [0,1500)
Min. 1st Qu. Median Mean 3rd Qu. Max.
23.0 27.0 29.0 29.6 32.0 36.0
--------------------------------------------------------
datos$peso_cut: [1500, 2000)
Min. 1st Qu. Median Mean 3rd Qu. Max.
30.00 32.00 34.00 33.84 35.00 41.00
--------------------------------------------------------
datos$peso_cut: [2000, 3500)
Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
31.00 37.00 38.00 37.74 39.00 43.00 11
--------------------------------------------------------
datos$peso_cut: [3500,+)
Min. 1st Qu. Median Mean 3rd Qu. Max.
36.00 39.00 40.00 39.37 40.00 42.00 with(na.omit(datos),boxplot(egest ~ peso_cut, ylab='Edad gestacional', main='Peso al nacer'))
Al examinar la gráfica y los cuartiles seleccionamos los rangos [0,32), [32,37), [34,39) y [39,+)
datos$egest_cut <- cut(datos$egest, ordered_result = T,
breaks = c(0,32,37,39,Inf),
labels = c("[0,32)", "[32,37)", "[37,39)", "[39,+)"),
right = F)
summary(datos$egest_cut) [0,32) [32,37) [37,39) [39,+) NA's
68 269 299 351 13 Edad de la madre
Al comparar la edad de la madre con el peso al nacer no se observa alguna relación. Sin embargo podemos comparar por tipo de parto.
by(INDICES = datos$tiparto,datos$emadre,summary)datos$tiparto: Eutócico
Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
13.00 21.00 25.00 25.98 30.00 44.00 5
--------------------------------------------------------
datos$tiparto: Vaginal Instrumentado
Min. 1st Qu. Median Mean 3rd Qu. Max.
15.00 22.00 31.50 28.32 33.00 42.00
--------------------------------------------------------
datos$tiparto: Cesárea programada
Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
15.00 24.50 30.00 29.24 34.00 46.00 3
--------------------------------------------------------
datos$tiparto: Cesárea No Programada
Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
15.00 23.00 28.00 28.25 33.00 46.00 4 with(na.omit(datos),boxplot(emadre ~ tiparto, ylab='Edad de la madre', main='Tipo de parto', las=1))
Esperabamos que en mujeres jovenes el parto fuese principalmente eutócico. No encontramos evidencia gráfica fuerte de esto por ende primeramente escogemos tres grupos. Nos basamos en la mediana de la edad para partos eutócicos (25) y la cota clásica de 35 años. Los rangos son [0,25), [25,35) [35,+). Además por interés clínico diferenciamos también las menores de edad.
datos$emadre_cut <- cut(datos$emadre, ordered_result = T,
breaks = c(0,18,25,35,Inf),
labels = c("[0,18)", "[18,25)", "[25,35)", "[35,+)"),
right = F)
summary(datos$emadre_cut) [0,18) [18,25) [25,35) [35,+) NA's
67 293 460 165 15 Estadía
La estadía está más diferenciada ante la presencia o no de infección nosocomial.
by(INDICES = datos$infeccion,datos$estadia,summary)datos$infeccion: No
Min. 1st Qu. Median Mean 3rd Qu. Max.
0.000 2.000 4.000 6.444 8.000 94.000
--------------------------------------------------------
datos$infeccion: Sí
Min. 1st Qu. Median Mean 3rd Qu. Max.
5.00 17.00 26.00 30.80 38.75 84.00 with(na.omit(datos),boxplot(estadia ~ infeccion, main='Infección', ylab='Estadía'))
Escogemos como cortes los cuartiles 1 y 3 de la estadía en aquellos partos con infección. Los rangos son [0,17), [17,38) y [38,+). Además por interés clínico diferenciamos también los menores a 10 días.
datos$estadia_cut <- cut(datos$estadia, ordered_result = T,
breaks = c(0,10, 17,38,Inf),
labels = c("[0,10)", "[10,17)", "[17,38)", "[38,+)"),
right = F)
summary(datos$estadia_cut) [0,10) [10,17) [17,38) [38,+)
730 117 120 33 CA simple: Tipo de parto vs edad gestacional
En análisis de correpondencia no tiene ningún supuesto distribucional y solo es necesario que las variables estén categorizadas. Aunque algunos escritos proponen supuestos de más de 20 observaciones y más de 3 observaciones por casillas lo único necesario es poder descomponer la matriz de residuales en valores singulares. Como ya categorizamos la edad gesatacional ya podemos realizar el CA.
Ajuste del CA
df <- datos[c("tiparto", "egest_cut")]
library(descr)
CrossTable(table(df),expected = F,prop.t = F, prop.chisq = T,chisq = T) Cell Contents
|-------------------------|
| N |
| Chi-square contribution |
| N / Row Total |
| N / Col Total |
|-------------------------|
==========================================================
egest_cut
tiparto [0,34) [34,39) [39,+) Total
----------------------------------------------------------
Eutócico 34 198 176 408
5.696 0.884 6.501
0.083 0.485 0.431 0.415
0.276 0.388 0.503
----------------------------------------------------------
Vaginal Instrumentado 2 22 20 44
2.232 0.030 1.199
0.045 0.500 0.455 0.045
0.016 0.043 0.057
----------------------------------------------------------
Cesárea programada 24 131 56 211
0.218 4.234 4.870
0.114 0.621 0.265 0.215
0.195 0.257 0.160
----------------------------------------------------------
Cesárea No Programada 63 159 98 320
13.165 0.297 2.229
0.197 0.497 0.306 0.326
0.512 0.312 0.280
----------------------------------------------------------
Total 123 510 350 983
0.125 0.519 0.356
==========================================================
Statistics for All Table Factors
Pearson's Chi-squared test
------------------------------------------------------------
Chi^2 = 41.55436 d.f. = 6 p = 2.25e-07 library(ca)
res.ca <- ca(table(df))
res.ca
Principal inertias (eigenvalues):
1 2
Value 0.031626 0.010647
Percentage 74.81% 25.19%
Rows:
Eutócico Vaginal Instrumentado Cesárea programada
Mass 0.415056 0.044761 0.214649
ChiDist 0.179051 0.280461 0.210193
Inertia 0.013306 0.003521 0.009483
Dim. 1 -0.990613 -1.573222 0.507283
Dim. 2 0.310097 -0.189437 -1.839929
Cesárea No Programada
Mass 0.325534
ChiDist 0.221438
Inertia 0.015962
Dim. 1 1.144860
Dim. 2 0.843877
Columns:
[0,34) [34,39) [39,+)
Mass 0.125127 0.518820 0.356053
ChiDist 0.416245 0.103326 0.205624
Inertia 0.021680 0.005539 0.015054
Dim. 1 2.170316 0.195535 -1.047633
Dim. 2 1.510497 -0.942983 0.843229summary(res.ca)
Principal inertias (eigenvalues):
dim value % cum% scree plot
1 0.031626 74.8 74.8 *******************
2 0.010647 25.2 100.0 ******
-------- -----
Total: 0.042273 100.0
Rows:
name mass qlt inr k=1 cor ctr k=2 cor ctr
1 | Etcc | 415 1000 315 | -176 968 407 | 32 32 40 |
2 | VgnI | 45 1000 83 | -280 995 111 | -20 5 2 |
3 | Csrp | 215 1000 224 | 90 184 55 | -190 816 727 |
4 | CsNP | 326 1000 378 | 204 845 427 | 87 155 232 |
Columns:
name mass qlt inr k=1 cor ctr k=2 cor ctr
1 | 034 | 125 1000 513 | 386 860 589 | 156 140 285 |
2 | 3439 | 519 1000 131 | 35 113 20 | -97 887 461 |
3 | 39 | 356 1000 356 | -186 821 391 | 87 179 253 |Gráfico del CA
# number of categories per variable
cats = apply(df, 2, function(x) nlevels(as.factor(x)))
cats tiparto egest_cut
4 3 names(cats)[1] "tiparto" "egest_cut"library(ggplot2)
# data frame with variable coordinates
coordinates <- rbind(res.ca$rowcoord, res.ca$colcoord)
mca1_vars_df = data.frame(coordinates, Variable = rep(names(cats), cats))
# plot of variable categories
ggplot(data=mca1_vars_df,
aes(x = Dim1, y = Dim2, label = abbreviate(rownames(mca1_vars_df),7))) +
geom_hline(yintercept = 0, colour = "gray70") +
geom_vline(xintercept = 0, colour = "gray70") +
geom_text(aes(colour=Variable)) +
ggtitle("MCA biplot")
Contribución Chi-cuadrado
chisq <- chisq.test(table(df))
chisq
Pearson's Chi-squared test
data: table(df)
X-squared = 41.554, df = 6, p-value = 2.252e-07library(corrplot)
corrplot(chisq$residuals, is.cor = FALSE, main='Residuales')
Interpretación
Los partos de 39 o más semanas de gestación son mayormente Eutócitos o Vaginal Instrumentado. La cesárea no programada se dá en partos de menos de 37 semanas de gestación. La cesárea programada se dá entre 37 y 39 semanas principalmente. La representación en dos dimensiones fue buena todas las categorías obtuvieron una calidad de 1000.
CA simple: Estadía vs edad gestacional
Ajuste del CA
df <- datos[c("estadia_cut", "egest_cut")]
library(descr)
CrossTable(table(df),expected = F,prop.t = F, prop.chisq = T,chisq = T) Cell Contents
|-------------------------|
| N |
| Chi-square contribution |
| N / Row Total |
| N / Col Total |
|-------------------------|
=================================================
egest_cut
estadia_cut [0,34) [34,39) [39,+) Total
-------------------------------------------------
[0,17) 55 448 334 837
23.308 0.386 4.437
0.066 0.535 0.399 0.848
0.447 0.873 0.952
-------------------------------------------------
[17,38) 43 59 15 117
55.393 0.054 17.016
0.368 0.504 0.128 0.119
0.350 0.115 0.043
-------------------------------------------------
[38,+) 25 6 2 33
106.090 7.251 8.076
0.758 0.182 0.061 0.033
0.203 0.012 0.006
-------------------------------------------------
Total 123 513 351 987
0.125 0.520 0.356
=================================================
Statistics for All Table Factors
Pearson's Chi-squared test
------------------------------------------------------------
Chi^2 = 222.0114 d.f. = 4 p <2e-16 library(ca)
res.ca <- ca(table(df))
res.ca
Principal inertias (eigenvalues):
1 2
Value 0.220119 0.004816
Percentage 97.86% 2.14%
Rows:
[0,17) [17,38) [38,+)
Mass 0.848024 0.118541 0.033435
ChiDist 0.183331 0.786982 1.918149
Inertia 0.028502 0.073417 0.123016
Dim. 1 -0.389997 1.646287 4.054904
Dim. 2 0.164663 -2.173853 3.530842
Columns:
[0,34) [34,39) [39,+)
Mass 0.124620 0.519757 0.355623
ChiDist 1.225710 0.122444 0.290051
Inertia 0.187225 0.007792 0.029918
Dim. 1 2.611662 -0.221279 -0.591790
Dim. 2 0.451234 -0.935421 1.209029summary(res.ca)
Principal inertias (eigenvalues):
dim value % cum% scree plot
1 0.220119 97.9 97.9 ************************
2 0.004816 2.1 100.0 *
-------- -----
Total: 0.224936 100.0
Rows:
name mass qlt inr k=1 cor ctr k=2 cor ctr
1 | 017 | 848 1000 127 | -183 996 129 | 11 4 23 |
2 | 1738 | 119 1000 326 | 772 963 321 | -151 37 560 |
3 | 38 | 33 1000 547 | 1902 984 550 | 245 16 417 |
Columns:
name mass qlt inr k=1 cor ctr k=2 cor ctr
1 | 034 | 125 1000 832 | 1225 999 850 | 31 1 25 |
2 | 3439 | 520 1000 35 | -104 719 25 | -65 281 455 |
3 | 39 | 356 1000 133 | -278 916 125 | 84 84 520 |Gráfico del CA
# number of categories per variable
cats = apply(df, 2, function(x) nlevels(as.factor(x)))
catsestadia_cut egest_cut
3 3 names(cats)[1] "estadia_cut" "egest_cut" library(ggplot2)
# data frame with variable coordinates
coordinates <- rbind(res.ca$rowcoord, res.ca$colcoord)
mca1_vars_df = data.frame(coordinates, Variable = rep(names(cats), cats))
# plot of variable categories
ggplot(data=mca1_vars_df,
aes(x = Dim1, y = Dim2, label = abbreviate(rownames(mca1_vars_df),7))) +
geom_hline(yintercept = 0, colour = "gray70") +
geom_vline(xintercept = 0, colour = "gray70") +
geom_text(aes(colour=Variable)) +
ggtitle("MCA biplot")
Contribución Chi-cuadrado
chisq <- chisq.test(table(df))
chisq
Pearson's Chi-squared test
data: table(df)
X-squared = 222.01, df = 4, p-value < 2.2e-16library(corrplot)
corrplot(chisq$residuals, is.cor = FALSE, main='Residuales')
Interpretación
Los partos de con menos de 34 semanas necesitaron una mayor estadía de más de 17 días.
CA simple: Peso al nacer vs Ventilación mecánica
Ajuste del CA
df <- datos[c("peso_cut", "ventilacion")]
library(descr)
CrossTable(table(df),expected = F,prop.t = F, prop.chisq = T,chisq = T) Cell Contents
|-------------------------|
| N |
| Chi-square contribution |
| N / Row Total |
| N / Col Total |
|-------------------------|
======================================
ventilacion
peso_cut No Sí Total
--------------------------------------
[0,2000) 157 29 186
2.181 41.082
0.844 0.156 0.188
0.167 0.580
--------------------------------------
[2000, 3500) 663 20 683
0.321 6.045
0.971 0.029 0.689
0.704 0.400
--------------------------------------
[3500,+) 122 1 123
0.231 4.361
0.992 0.008 0.124
0.130 0.020
--------------------------------------
Total 942 50 992
0.95 0.05
======================================
Statistics for All Table Factors
Pearson's Chi-squared test
------------------------------------------------------------
Chi^2 = 54.22017 d.f. = 2 p = 1.68e-12 library(ca)
res.ca <- ca(table(df), nd=3)
res.ca
Principal inertias (eigenvalues):
1
Value 0.054657
Percentage 100%
Rows:
[0,2000) [2000, 3500) [3500,+)
Mass 0.187500 0.688508 0.123992
ChiDist 0.482279 0.096540 0.193226
Inertia 0.043611 0.006417 0.004629
Dim. 1 -2.062877 0.412937 0.826497
Columns:
No Sí
Mass 0.949597 0.050403
ChiDist 0.053862 1.014764
Inertia 0.002755 0.051903
Dim. 1 0.230388 -4.340507Gráfico del CA
# number of categories per variable
cats = apply(df, 2, function(x) nlevels(as.factor(x)))
cats peso_cut ventilacion
3 2 names(cats)[1] "peso_cut" "ventilacion"library(ggplot2)
# data frame with variable coordinates
coordinates <- rbind(res.ca$rowcoord, res.ca$colcoord)
mca1_vars_df = data.frame(coordinates, Variable = rep(names(cats), cats))
# plot of variable categories
ggplot(data=mca1_vars_df,
aes(x = Dim1, y=c(0), label = abbreviate(rownames(mca1_vars_df),11))) +
ylab("")+
geom_hline(yintercept = 0, colour = "gray70") +
geom_vline(xintercept = 0, colour = "gray70") +
geom_text(aes(colour=Variable),angle = 45) +
ggtitle("MCA biplot")
Contribución Chi-cuadrado
chisq <- chisq.test(table(df))
chisq
Pearson's Chi-squared test
data: table(df)
X-squared = 54.22, df = 2, p-value = 1.684e-12library(corrplot)
corrplot(chisq$residuals, is.cor = FALSE, main='Residuales')
Interpretación
La ventilación es necesitadas principalmente por niños con bajo peso (<2000)
Correpondencias Múltiple (MCA)
Podemos aplicar un MCA, no sobre toda la base de datos sino, sobre aquellas variables categóricas. Nuevamente no existe ningún supuesto distribucional ni de cantidad de datos.
Inercias ajustadas
class_df <- as.data.frame(sapply(datos, class))
var_categoricas <- unlist(class_df[1,]) %in% c("ordered","factor")
library(ca)
res.mca <- mjca(datos[,var_categoricas], lambda="adjusted")
summary(res.mca, scree = TRUE)
Principal inertias (eigenvalues):
dim value % cum% scree plot
1 0.043516 67.0 67.0 **********************
2 0.004385 6.8 73.8 **
3 0.001078 1.7 75.4 *
4 0.000820 1.3 76.7
5 0.000342 0.5 77.2
6 0.000288 0.4 77.6
7 0.000118 0.2 77.8
8 1.2e-050 0.0 77.8
-------- -----
Total: 0.064947
Columns:
name mass qlt inr k=1 cor ctr k=2
1 | sexo:Mujeres | 43 5 20 | 4 3 0 | 3
2 | sexo:Hombres | 48 6 18 | -3 3 0 | -3
3 | tiparto:Eutócico | 38 571 23 | -88 510 7 | 30
4 | tiparto:Vaginal Instrumentado | 4 499 35 | -143 459 2 | 42
5 | tiparto:Cesárea programada | 20 63 29 | -28 47 0 | -16
6 | tiparto:Cesárea No Programada | 30 921 27 | 153 875 16 | -35
7 | antibioticos:No | 77 686 5 | -30 677 2 | 4
8 | antibioticos:Sí | 11 818 34 | 210 813 11 | -17
9 | fiebre:No | 85 353 3 | -9 352 0 | 0
10 | fiebre:Sí | 6 351 35 | 130 351 2 | 1
11 | infeccion:No | 82 810 7 | -98 805 18 | -7
12 | infeccion:Sí | 9 808 66 | 865 803 161 | 62
13 | cateter:No | 88 892 2 | -45 880 4 | -5
14 | cateter:Sí | 3 889 57 | 1244 877 114 | 145
15 | ventilacion:No | 87 697 2 | -23 603 1 | 9
16 | ventilacion:Sí | 5 702 39 | 427 606 19 | -170
17 | peso_cut:[0,1500) | 7 794 70 | 993 778 169 | 144
18 | peso_cut:[1500, 2000) | 10 706 42 | 278 284 17 | -340
19 | peso_cut:[2000, 3500) | 63 761 17 | -135 760 26 | 5
20 | peso_cut:[3500,+) | 11 392 37 | -142 165 5 | 167
21 | egest_cut:[0,32) | 6 800 69 | 1069 782 165 | 162
22 | egest_cut:[32,37) | 25 702 34 | 118 177 8 | -203
23 | egest_cut:[37,39) | 27 573 30 | -156 539 15 | 39
24 | egest_cut:[39,+) | 32 608 31 | -167 469 21 | 91
25 | emadre_cut:[0,18) | 6 225 34 | 36 43 0 | -74
26 | emadre_cut:[18,25) | 27 150 27 | -46 149 1 | -2
27 | emadre_cut:[25,35) | 42 120 19 | 11 55 0 | 12
28 | emadre_cut:[35,+) | 15 99 31 | 41 99 1 | 0
29 | estadia_cut:[0,10) | 67 804 17 | -149 760 34 | 36
30 | estadia_cut:[10,17) | 11 487 34 | 47 46 1 | -145
31 | estadia_cut:[17,38) | 11 792 48 | 513 721 66 | -161
32 | estadia_cut:[38,+) | 3 847 58 | 1264 801 112 | 304
cor ctr
1 2 0 |
2 2 0 |
3 61 8 |
4 41 2 |
5 16 1 |
6 45 8 |
7 9 0 |
8 5 1 |
9 0 0 |
10 0 0 |
11 4 1 |
12 4 8 |
13 12 1 |
14 12 15 |
15 94 2 |
16 96 31 |
17 16 36 |
18 422 257 |
19 1 0 |
20 228 73 |
21 18 38 |
22 525 235 |
23 34 10 |
24 139 61 |
25 182 8 |
26 0 0 |
27 66 1 |
28 0 0 |
29 44 20 |
30 441 52 |
31 71 65 |
32 46 65 |# Inertia percentage
library(factoextra)
fviz_screeplot(res.mca)
# Biplots
plot(res.mca, map='symbiplot', contrib='relative', main='Correspondencias múltiple (inercias ajustadas)')
# number of categories per variable
cats = apply(datos[,var_categoricas], 2, function(x) nlevels(as.factor(x)))
library(ggplot2)
# data frame with variable coordinates
mca1_vars_df = data.frame(res.mca$colcoord, Variable = rep(names(cats), cats))
rownames(mca1_vars_df) = res.mca$levelnames
# plot of variable categories
ggplot(data=mca1_vars_df,
aes(x = X1, y=X2, label = abbreviate(rownames(mca1_vars_df),20))) +
geom_hline(yintercept = 0, colour = "gray70") +
geom_vline(xintercept = 0, colour = "gray70") +
geom_text(aes(colour=Variable)) +
ggtitle("MCA biplot")
Con el método de inercias ajustadas, las dos primeras dimensiones explican aproimadamente el 73.8% de la inercia total. Sin embargo, las 7 dimensiones encontradas solo eplican el 78% de la inercia. Algunas categorías tienen una pobre calidad de representación en las dos primeras dimensiones.
Se observa en la esquina inferior izquierda del biplot un primer cluster de partos que necesitaron una estadía de más de 38 días de estadía, que tuvieron necesidad de cateter y que tuvieron infección nosocomial. En la esquina superior izquierda encontramos un segundo cluster compuesto por nacimientos de bajo peso que necesitaron ventilación y una estadía entre 17 y 38 semanas. En la esquina inferior derecha se separan aquellos bebes con buen peso (>3500gr).
Análisis conjunto (JCA)
library(ca)
res.mca <- mjca(datos[,var_categoricas], lambda="JCA")
summary(res.mca, scree = TRUE)
Principal inertias (eigenvalues):
dim value
1 0.055691
2 0.008574
3 0.002592
4 0.000939
5 0.000455
6 0.000306
7 0.000194
8 5.2e-050
--------
Total: 0.071234
Diagonal inertia discounted from eigenvalues: 0.0145312
Percentage explained by JCA in 2 dimensions: 87.7%
(Eigenvalues are not nested)
[Iterations in JCA: 50 , epsilon = 0.000723]
Columns:
name mass inr k=1 k=2 cor ctr
1 | sexo:Mujeres | 43 20 | -5 -4 | 12 0 |
2 | sexo:Hombres | 48 18 | 4 4 | 11 0 |
3 | tiparto:Eutócico | 38 23 | 82 30 | 544 6 |
4 | tiparto:Vaginal Instrumentado | 4 35 | 138 50 | 520 2 |
5 | tiparto:Cesárea programada | 20 29 | 25 -20 | 70 0 |
6 | tiparto:Cesárea No Programada | 30 27 | -144 -33 | 883 13 |
7 | antibioticos:No | 77 5 | 29 3 | 660 1 |
8 | antibioticos:Sí | 11 34 | -192 -7 | 739 8 |
9 | fiebre:No | 85 3 | 8 -1 | 314 0 |
10 | fiebre:Sí | 6 35 | -115 16 | 309 2 |
11 | infeccion:No | 82 7 | 108 -17 | 903 16 |
12 | infeccion:Sí | 9 66 | -957 147 | 899 142 |
13 | cateter:No | 88 2 | 46 -9 | 934 3 |
14 | cateter:Sí | 3 57 | -1271 245 | 928 95 |
15 | ventilacion:No | 87 2 | 22 9 | 698 1 |
16 | ventilacion:Sí | 5 39 | -408 -176 | 704 18 |
17 | peso_cut:[0,1500) | 7 70 | -1166 177 | 927 160 |
18 | peso_cut:[1500, 2000) | 10 42 | -375 -536 | 963 46 |
19 | peso_cut:[2000, 3500) | 63 17 | 161 6 | 893 25 |
20 | peso_cut:[3500,+) | 11 37 | 194 297 | 625 16 |
21 | egest_cut:[0,32) | 6 69 | -1233 190 | 918 153 |
22 | egest_cut:[32,37) | 25 34 | -158 -288 | 979 35 |
23 | egest_cut:[37,39) | 27 30 | 185 47 | 667 15 |
24 | egest_cut:[39,+) | 32 31 | 205 143 | 809 28 |
25 | emadre_cut:[0,18) | 6 34 | -34 -52 | 143 0 |
26 | emadre_cut:[18,25) | 27 27 | 40 -8 | 130 1 |
27 | emadre_cut:[25,35) | 42 19 | -10 13 | 123 0 |
28 | emadre_cut:[35,+) | 15 31 | -38 2 | 92 0 |
29 | estadia_cut:[0,10) | 67 17 | 174 32 | 919 33 |
30 | estadia_cut:[10,17) | 11 34 | -55 -142 | 473 4 |
31 | estadia_cut:[17,38) | 11 48 | -602 -152 | 909 66 |
32 | estadia_cut:[38,+) | 3 58 | -1467 343 | 976 108 |# Biplots
plot(res.mca, map='symbiplot', contrib='relative', main='Correspondencias múltiple Conjunto')
# number of categories per variable
cats = apply(datos[,var_categoricas], 2, function(x) nlevels(as.factor(x)))
library(ggplot2)
# data frame with variable coordinates
mca1_vars_df = data.frame(res.mca$colcoord, Variable = rep(names(cats), cats))
rownames(mca1_vars_df) = res.mca$levelnames
# plot of variable categories
ggplot(data=mca1_vars_df,
aes(x = X1, y=X2, label = abbreviate(rownames(mca1_vars_df),20))) +
geom_hline(yintercept = 0, colour = "gray70") +
geom_vline(xintercept = 0, colour = "gray70") +
geom_text(aes(colour=Variable)) +
ggtitle("MCA biplot")
Con la solución por análisis conjunto el porcentaje de inercia estimada por la dosprimeras dimensiones es del 87.7% (inercias no anidadas). La calidad de varias categorías mejora considerablemente, siendo en algunos casos superior a 900. La interpretación es similar al análisis por inercias ajustadas.
Interpretación de resultados
Grupo 1
Niños con el más bajo peso (<1500gr) y prematuros (<32sem) a los cuales se les colocó cateter y resultaron infectados. Ellos necesitaron una estadía larga (>38días)
Grupo 2
Niños con bajo peso (0-1500gr) con edad gestacional (32-37sem) que necesitaron ventilación. Tuvieron una estadía entre 10-38-sem
Grupo 3
El restos de los embarazos normales.