From 06523108006c91ff48d57823ac6347fd73da5473 Mon Sep 17 00:00:00 2001 From: Felipe Gonzalez Date: Fri, 19 Jan 2024 12:37:25 -0600 Subject: [PATCH] Agregar tarea 1 --- tareas/tarea-01.qmd | 198 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 198 insertions(+) create mode 100644 tareas/tarea-01.qmd diff --git a/tareas/tarea-01.qmd b/tareas/tarea-01.qmd new file mode 100644 index 0000000..5597e4c --- /dev/null +++ b/tareas/tarea-01.qmd @@ -0,0 +1,198 @@ +--- +title: "Tarea 1" +format: html +editor: visual +--- + +En esta tarea veremos + +- Un ejemplo más de cómo los diagramas causales pueden +guiarnos hacia el análisis correcto, y entender por qué pueden aparacer correlaciones +no causales. +- Un ejercicio para repasar la motivación a estadística bayesiana que +vimos en clase. + + +```{r} +library(tidyverse) +library(DiagrammeR) +``` + + +# Pensamiento causal: Paradoja de Berkson + +Supongamos que en una universidad los alumnos pueden ser aceptados +por habilidad atlética y habilidad académica. Cuando un analista de +datos examina los datos, encuentra que hay una **correlación negativa** +entre habilidad atlética y académica. + +Veremos cómo puede suceder esto sin que en realidad exista una relación +negativa de estas dos habilidades en la población. Para este +ejercicio supondremos que + +- Para que alguien sea aceptado, tiene su score deportivo debe ser mayor +a 120 y/o su score académico debe ser mayor a 120. +- No existe relación causal entre los dos tipos de aptitud (podemos también modificar este supuestos más adelante) + +El diagrama que ilustra esto es el siguiente. + +```{r} +grViz(" +digraph { + graph [ranksep = 0.2] + node [shape=plaintext] + Academica + Deportes + Aceptacion + edge [minlen = 3] +Academica -> Aceptacion +Deportes -> Aceptacion +} +") +``` + +Adicionalmente, sabemos que los scores de los que aplican están estandarizados, +y tienen distribución aproximadamente normal con media 100 y desviación +estándar 10. Podemos construir entonces un modelo generativo como sigue: + +```{r} +simular_alumnos <- function(n = 10){ + academico <- rnorm(n, 100, 10) + deportes <- rnorm(n, 100, 10) + aceptacion <- ifelse(academico > 125 | deportes > 125, 1, 0) + tibble(academico, deportes, aceptacion) +} +``` + + +Confirma los resultados que obtuvo el analista anterior: hay una correlación +negativa entre habilidades para los estudiantes aceptados: + +```{r} +alumnos_sim_tbl <- simular_alumnos(5000) +aceptados_tbl <- alumnos_sim_tbl |> + filter(aceptacion == 1) +aceptados_tbl |> ggplot(aes(academico, deportes)) + + geom_point() + + geom_smooth(method = "lm", formula = y ~ x) +``` + + +**Pregunta 1**: Según nuestros supuestos, discute +por qué una explicación de esta correlación como "cuando alguien es bueno para +los deportes le dedica más tiempo a deportes y descuida aspectos académicos, +y viceversa" no necesariamente es válida. ¿El problema es estádistico (muestra chica) o conceptual? + + +**Pregunta 2**: Verifica que en la población general (tanto alumnos rechazados como aceptados) no existe tal correlación (según nuestros supuestos). Utiliza los mismos datos simulados +de arriba. + +**Pregunta 3**: para entender cómo se relaciona habilidad académica y +en deportes en las personas, ¿cuáles datos son más adecuados? + +- Necesitamos ver los datos de aceptados y no aceptados. +- Podemos ver los datos de aceptados solamente. + +Este tipo de correlaciones distorsionadas al hacer análisis por subgrupos +en un diagrama como el de arriba se llama también **sesgo de selección**. + + +# Modelación y pruebas a priori + +Considera el ejemplo en clase de seropositividad que vimos en clase. +Según nuestro diagrama, propusimos una función de simulación como la +que sigue: + +```{r} +sim_pos_neg <- function(N = 20, sens = 1, esp = 1) { + # supuesto a priori acerca de la prevalencia + theta <- runif(1, 0, 1) + # verdaderos positivos que capturamos en la muestra + Pos_verdadero <- rbinom(N, 1, theta) + Neg_verdadero <- 1 - Pos_verdadero + # positivos observados en la muestra + Pos <- Pos_verdadero + Neg <- 1 - Pos + # Observaciones, también regresamos la theta real + # que se usó para simular: + tibble(Pos = Pos, Neg = Neg, theta = theta) +} +``` + + +Y propusimos un proceso de estimación (ver notas) como sigue (donde utilizaremos +una rejilla más fina): + +```{r} +calcular_posterior <- function(muestra){ + theta <- seq(0, 1, length.out = 51) + # distribución inicial o a prior + priori <- tibble(theta = theta, prob_priori = (1 - theta) * (1 - theta)) |> + mutate(prob_priori = prob_priori / sum(prob_priori)) + # calcular la probabilidad posterior + N <- length(muestra) + Npos <- sum(muestra) + prob_post <- tibble(theta = theta) |> + left_join(priori, by = "theta") |> + mutate(prob_posterior = theta ^ Npos * (1 - theta)^(N - Npos) * prob_priori) |> + mutate(prob_posterior = prob_posterior / sum(prob_posterior)) + prob_post |> select(theta, prob_posterior) +} +``` + +La pregunta que queremos contestar es la siguiente: bajo nuestros +supuestos del modelo generativo, nuestro proceso de estimación +es adecuado? Para esto es necesario hacer pruebas. + +Considera entonces una simulación de datos y la posterior obtenida: + +```{r} +set.seed(1134) +una_muestra <- sim_pos_neg(N = 100) +theta_real <- una_muestra$theta[1] +posterior <- calcular_posterior(una_muestra$Pos) +ggplot(posterior, aes(x = theta, y = prob_posterior)) + + geom_col() + + geom_vline(xintercept = theta_real, col = "red") +``` + +**Pregunta 4**: Nota que la distribución posterior (probabilidad de +cada conjetura de theta dada la muestra) no está concentrada en +verdadero valor de theta. ¿Esto indica un problema necesariamente? +¿Qué dirías acerca de nuestro método de estimación dada esta gráfica? + + +En realidad, es importante ver qué sucede con distintos valores del +parámetro a estimar y distintas muestras posibles. + + +Corre este código al menos unas 20 veces y checa el resultado: + +```{r} +una_muestra <- sim_pos_neg(N = 100) +theta_real <- una_muestra$theta[1] +posterior <- calcular_posterior(una_muestra$Pos) +ggplot(posterior, aes(x = theta, y = prob_posterior)) + + geom_col() + + geom_vline(xintercept = theta_real, col = "red") +``` + +**Pregunta 5**: De acuerdo a este ejercicio de simulación bajo nuestros supuestos, +¿qué dirías acerca de nuestro proceso de estimación? ¿Nos informa correctamente +acerca del valor de theta? + +**Pregunta 6**: Repite los dos ejercicios anteriores con una muestra mucho más +chica, como N=3 por ejemplo. ¿Qué dirías de nuestras estimaciones en este caso? + +**Pregunta 7** (opcional, más dificíl) Si quisiéramos usar una muestra mucho +más grande que N=100, ¿qué problemas encuentras? ¿qué defecto numérico tiene nuestro +proceso de estimación? + + + + + + + + +