Tarea 2
Metodología de la Investigación
IIMAS - Especialidad en Estadística
Pregunta 1
La base de datos sexbias.csv contiene la información coleccionada de un estudio realizado por la Universidad de California de Berkeley, para evaluar si los hombres estaban recibiendo un trato preferencial sobre las mujeres en la admisión a ciertos progrmas de posgrado.
¿Con esta información se puede afirmar a un nivel de significancia \(\alpha=0.05\), que existe evidencia que los hombres estaban recibiendo un trato preferencial en detrimento de las mujeres?
Visualizaciones previas
Leyendo los datos
sexbias_locacion <- "~/Desktop/estadistica-aplicada-unam/materias/metodologia-investigacion/tarea_2/sexbias.csv"
sexbias <- read_csv(file = sexbias_locacion) |> clean_names()
glimpse(sexbias)Rows: 4,526
Columns: 3
$ sex <chr> "male", "male", "male", "male", "male", "male", "male", "ma…
$ department <chr> "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A",…
$ accepted <chr> "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y",…Primero observemos el número de aplicantes por género:
tabla_resumen <- sexbias |>
group_by(sex, department, accepted) |>
summarise(n = n(), .groups = "drop")
tabla_resumen |>
group_by(department, sex) |>
summarise(n_aplicantes = sum(n)) |>
ggplot(aes(x = department, y = n_aplicantes, fill = sex)) +
geom_col(position = position_dodge2(preserve = "single", padding = 0.1, width = 0.5)) +
scale_fill_manual(values = c("#F1B4BB", "#1F4172")) +
labs(x = "Departamento", y = "Número de aplicantes", title = "Número de aplicantes",
subtitle = "Por departamento y sexo") +
scale_y_continuous(breaks = seq(0, 900, by = 100)) +
theme_minimal()
Porcentaje de aceptados únicamente por género:
tabla_porcentajes <- tabla_resumen |>
group_by(accepted, sex) |>
summarise(num_aplicantes = sum(n)) |>
group_by(sex) |>
mutate(porcentaje = (num_aplicantes / sum(num_aplicantes)))
tabla_porcentajes |>
ggplot(aes(x = sex, y = porcentaje, fill = accepted)) +
geom_col() +
geom_text(aes(label = percent(porcentaje)), vjust = 2) +
labs(x = "", y = "Tasa de aceptación") +
scale_fill_manual(values = c("#FF6969", "#219C90")) +
theme_minimal()
A primera vista, parece ser que, en proporción, se tiende a aceptar más a hombres que a mujeres. Veamos ahora, ¿cuántas de las mujeres y hombres aplicantes fueron aceptados por departamento?
# Tasa de aceptación por departamento y género
sexbias |>
group_by(department, sex, accepted) |>
summarise(n = n()) |>
group_by(department, sex) |>
mutate(porcentaje = n / sum(n)) |>
ggplot(aes(x = sex, y = porcentaje, fill = accepted)) +
geom_col() +
facet_wrap(~ department) +
scale_fill_manual(values = c("#FF6969", "#219C90")) +
theme_minimal()
La tasa de aceptación por género entre los departamentos son parecidas, es decir, la altura de las barras de aceptación tienen alturas similares en ambos sexos. Esto parece sugerir que, con la apertura por departamento y bajo los supuestos de calificación justa por parte de los académicos, no se está favoreciento a ningún sexo. Véamos que dicen los modelos logísticos.
Modelación
Modelo por sexo únicamente
Veamos el modelo logístico únicamente por sexo.
\[ log(\frac{p}{1-p})=\beta_0+\beta_1x_{sexo} \]
es decir, modelamos los odds de ser aceptado a un programa de calidad en Berkeley.
sexbias$accepted <- ifelse(sexbias$accepted == "Y", 1, 0)
sexbias$department <- factor(sexbias$department)
sexbias$sex <- factor(sexbias$sex)
modelo_sexo <- glm(accepted ~ sex, family = "binomial", data = sexbias)
summary(modelo_sexo)
Call:
glm(formula = accepted ~ sex, family = "binomial", data = sexbias)
Deviance Residuals:
Min 1Q Median 3Q Max
-1.0855 -1.0855 -0.8506 1.2722 1.5442
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) -0.83049 0.05077 -16.357 <2e-16 ***
sexmale 0.61035 0.06389 9.553 <2e-16 ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 6044.3 on 4525 degrees of freedom
Residual deviance: 5950.9 on 4524 degrees of freedom
AIC: 5954.9
Number of Fisher Scoring iterations: 4Sin lugar a dudas, el modelo únicamente por sexo nos da una \(\beta\) positiva significativa (\(p<0.05\)) para el sexo masculino, es decir que por el hecho de ser hombre hay \(exp(0.61035)=1.84\) veces más probabilidad de ser aceptado en un programa de calidad de Berkeley.
Modelo por sexo controlando por departamento
\[ log(\frac{p}{1-p})=\beta_0+\beta_1x_{sexo} + \beta_{2}x_{departamento} \]
modelo_sexo_departamento <-
glm(accepted ~ sex + department, family = "binomial", data = sexbias)
summary(modelo_sexo_departamento)
Call:
glm(formula = accepted ~ sex + department, family = "binomial",
data = sexbias)
Deviance Residuals:
Min 1Q Median 3Q Max
-1.4773 -0.9306 -0.3741 0.9588 2.3613
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) 0.68192 0.09911 6.880 5.97e-12 ***
sexmale -0.09987 0.08085 -1.235 0.217
departmentB -0.04340 0.10984 -0.395 0.693
departmentC -1.26260 0.10663 -11.841 < 2e-16 ***
departmentD -1.29461 0.10582 -12.234 < 2e-16 ***
departmentE -1.73931 0.12611 -13.792 < 2e-16 ***
departmentF -3.30648 0.16998 -19.452 < 2e-16 ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 6044.3 on 4525 degrees of freedom
Residual deviance: 5187.5 on 4519 degrees of freedom
AIC: 5201.5
Number of Fisher Scoring iterations: 5Al controlar por departamento, se observa que el coeficiente \(\beta\) correspondiente al sexo cambia de signo, sugiriendo que podría haber incluso un sesgo en favor de las mujeres. Sin embargo, el coeficiente deja de ser significativo (\(p=0.217\)) por lo que concluiríamos que no hay evidencia estadística suficiente para afirmar que hay un sesgo por sexo, lo cual estaría en línea con el gráfico que observamos en el apartado de visualización.