diff --git a/.nojekyll b/.nojekyll index 48d2b3f..8c09a44 100644 --- a/.nojekyll +++ b/.nojekyll @@ -1 +1 @@ -b76faea8 \ No newline at end of file +833ea6b6 \ No newline at end of file diff --git a/01-introduccion.html b/01-introduccion.html index d942309..1aa92ab 100644 --- a/01-introduccion.html +++ b/01-introduccion.html @@ -361,21 +361,21 @@

Ejemp B -chicos -mejora +grandes +sin_mejora A -chicos +grandes mejora B -grandes +chicos mejora -A +B grandes sin_mejora @@ -385,19 +385,19 @@

Ejemp mejora -A +B grandes mejora A grandes -mejora +sin_mejora -B +A grandes -sin_mejora +mejora A @@ -405,9 +405,9 @@

Ejemp mejora -A +B grandes -sin_mejora +mejora @@ -660,8 +660,8 @@

Ejemp ", width = 200, height = 50)
-
- +
+

Es decir, el tamaño de los cálculos es una causa común de tratamiento (T) y resultado (M). Veremos más adelante que la decisión de condicionar a el tipo de cálculos proviene de un análisis relativamente simple de este diagrama causal, independientemente de los métodos que usemos para estimar las proporciones de interés (en este ejemplo, examinar las tablas cruzadas es equivalente a hacer estimaciones de máxima verosimlitud).

@@ -782,8 +782,8 @@

Eje ", width = 200, height = 50)
-
- +
+

Nótese que el análisis más apropiado no está en los datos: en ambos casos la tabla de datos es exactamente la misma. Los supuestos acerca del proceso que genera los datos sin embargo nos lleva a respuestas opuestas.

diff --git a/02-flujo-basico-2.html b/02-flujo-basico-2.html index 55b350c..8041e50 100644 --- a/02-flujo-basico-2.html +++ b/02-flujo-basico-2.html @@ -320,8 +320,8 @@

")#, width = 200, height = 50)
-
- +
+

Donde vemos ahora que el estado real de cada persona de la prueba es desconocido, aunque el resultado de la prueba depende de ese estado, y la cantidad de positivos que observamos es ahora \(N_{obs}\), que depende también de la sensibilidad y especificidad de la prueba.

@@ -563,8 +563,8 @@

")#, width = 200, height = 50)
-
- +
+

Usando argumentos como los del modelo original, las distribuciones de esp y sens son beta y podemos incorporarlas en la simulación de la posterior. Nuestra nueva función para simular el proceso generativo es:

diff --git a/02-flujo-basico.html b/02-flujo-basico.html index 47e4b73..e1f9b4a 100644 --- a/02-flujo-basico.html +++ b/02-flujo-basico.html @@ -339,8 +339,8 @@

", width = 300, height = 100)
-
- +
+

Que también podríamos simplificar (suponiendo la \(N\) fija y conocida, pues \(N_+\) y \(M\) dan \(N_{-}\)) como:

@@ -373,8 +373,8 @@

", width = 300, height = 100)
-
- +
+

Y ahora construimos el modelo generativo. Supondremos que la muestra de \(N\) personas se toma de manera aleatoria de la población (una población grande, así que podemos ignorar el efecto de muestreo). Supondremos provisionalmente, además, que la prueba es perfecta, es decir, no hay falsos positivos o negativos.

diff --git a/03-modelos-genericos.html b/03-modelos-genericos.html index e655cbf..d322d15 100644 --- a/03-modelos-genericos.html +++ b/03-modelos-genericos.html @@ -345,8 +345,8 @@

")#, width = 200, height = 50)
-
- +
+

Nótese que no consideramos \(W\to H\), porque podemos pensar en varias intervenciones que podrían cambiar el peso por no cambian la estatura. Por otro lado, es difícil pensar en alguna intervención que cambie la estatura pero no cambie el peso de una persona. Adicionalmente, hay otros factores desconocidos no observados \(U\) que afectan el peso de cada persona adicionalmente a su estatura.

@@ -940,8 +940,8 @@

", width = 200, height = 50)
-
- +
+

Omitiendo del diagrama las variables no observadas que también son causas únicamente de \(S\) y \(W, H\):

@@ -966,8 +966,8 @@

", width = 200, height = 50)
-
- +
+

Si queremos saber cómo influye el sexo en el peso, este diagrama indica que hay dos tipos de preguntas que podemos hacer:

@@ -1258,7 +1258,7 @@

@@ -1457,8 +1457,8 @@

")#, width = 200, height = 50)
-
- +
+

En este caso, el modelo causal es como sigue: conocemos la distancia \(D\) al hoyo en cada tiro. El éxito (\(Y=1\)) o fracaso (\(Y=0\)) depende de la distancia, junto con la velocidad a la que sale la pelota (muy alto o muy bajo puede dar un tiro fallido), y el ángulo \(\theta\) de salida. Adicionalmente, hay otros factors \(U\) que pueden afectar la probabilidad de éxito. Nótese que no escribiríamos, por ejemplo \(Y \leftarrow D\), porque la distancia no cambia causalmente con el resultado del tiro, aunque es cierto que si intervenimos en la distancia, esperaríamos obtener tasas de éxito diferentes. Igualmente, es necesario poner una flecha de \(V\) a \(D\) y \(V\) a \(Y\).

@@ -2225,8 +2225,8 @@ 

Warning: 236 of 4000 (6.0%) transitions hit the maximum treedepth limit of 10.
diff --git a/05-dags.html b/05-dags.html
index 0a50a73..f0a3769 100644
--- a/05-dags.html
+++ b/05-dags.html
@@ -355,8 +355,8 @@ 
", width = 150, height = 40)
-
- +
+

Nótese que no describimos exactamente cómo son las funciones que relacionan las variables, sino más bien qué variables son causas directas de qué otras. Por ejemplo, aunque en nuestro ejemplo de arriba \(Y\) puede estar correlacionado con \(Z\), no hay una causa directa a \(Y\), porque cambios en \(Z\) afectan a \(X\), y es el cambio en \(X\) que es causa directa de \(Y\).

@@ -413,8 +413,8 @@

")
-
- +
+

En este ejemplos no podemos saber \(U1\) y \(U2\), y no nos interesa modelar la física de monedas, manera de lanzarlas, etc. En este ejemplo también no consideraremos qué hace que un día sea soleado o lluvioso (no nos interesa modelar el clima). En este momento, en teoría tenemos ecuaciones determinísticas para todas las variables, y si conocemos todas las variables exógenas \(U1,U2,U3,U4\) podríamos determinar exactamente lo que va a suceder con la ganancia, por ejemplo, o cualquier otra variable del sistema.

@@ -445,8 +445,8 @@

")
-
- +
+
@@ -521,13 +521,13 @@

Ejemplo

simular_juego(5)
# A tibble: 5 × 5
-      x d           s1    s2     g
-  <dbl> <chr>    <int> <int> <int>
-1 0.924 soleado      5     5     5
-2 0.787 soleado      4     4     4
-3 0.848 lluvioso     5     3     8
-4 0.454 lluvioso     2     3     5
-5 0.369 soleado      2     1     2
+ x d s1 s2 g + <dbl> <chr> <int> <int> <int> +1 0.751 soleado 5 2 5 +2 0.653 lluvioso 3 3 6 +3 0.0645 lluvioso 0 0 0 +4 0.0933 soleado 1 2 1 +5 0.258 soleado 2 1 2
@@ -589,8 +589,8 @@

", width = 200, height = 50)
-
- +
+

En este caso,

@@ -639,8 +639,8 @@

Ejemplo (si 
cor(sims_confusor |> select(x,y)) |> round(3)
       x      y
-x  1.000 -0.428
-y -0.428  1.000
+x 1.000 -0.426 +y -0.426 1.000

Sin embargo, si condicionamos a \(Z\), que puede tomar los valores 0 o 1, vemos que \(X\) y \(Y\) son independientes, o dicho de otra manera, la condicional de \(Y\) dada \(Z\) y \(X\) sólo depende de \(Z\):

@@ -665,15 +665,15 @@

Ejemplo (si 
cor(sims_confusor |> filter(z == 1) |> select(x,y)) |> round(3)
-
      x     y
-x 1.000 0.002
-y 0.002 1.000
+
       x      y
+x  1.000 -0.018
+y -0.018  1.000
cor(sims_confusor |> filter(z == 0) |> select(x,y)) |> round(3)
-
      x     y
-x  1.00 -0.01
-y -0.01  1.00
+
       x      y
+x  1.000 -0.009
+y -0.009  1.000

Un ejemplo con variables continuas podría ser como sigue:

@@ -773,8 +773,8 @@

E ", width = 200, height = 50)
-
- +
+

Por la discusión de arriba, es claro que es necesario considerar la edad al casarse si queremos estimar el efecto de tasa de matrimonio en la tasa de divorcio. Es posible que la correlación entre estas dos tasas puede ser explicada solamente por la edad al casarse, y que en realidad al flecha \(M\to D\) sea muy débil o inexistente.

@@ -925,8 +925,8 @@

", width = 200, height = 50)
-
- +
+

Es decir, borramos todas las flechas que caen en \(M\) (pues la estamos interveniendo al valor que queramos), y luego simulando \(D\).

@@ -942,7 +942,7 @@

@@ -994,8 +994,8 @@

", width = 150, height = 20)
-
- +
+

En este caso,

@@ -1062,15 +1062,15 @@ 

cor(sims_mediador |> filter(z == 1) |> select(x,y)) |> round(3)
-
      x     y
-x  1.00 -0.01
-y -0.01  1.00
+
       x      y
+x  1.000 -0.001
+y -0.001  1.000
cor(sims_mediador |> filter(z == 0) |> select(x,y)) |> round(3)
-
       x      y
-x  1.000 -0.006
-y -0.006  1.000
+
      x     y
+x 1.000 0.003
+y 0.003 1.000

Podemos también hacer un ejemplo continuo:

@@ -1163,8 +1163,8 @@

Ejemplo: Burks")
-
- +
+

Como el NSE es del hogar (una medida general de estatus social), se consideró en principio como una variable pre-tratamiento a la inteligencia de los niños por la que tradicionalmente se controlaba. Burks notó que hacer esto tenía no era apropiado, pues tiene como consecuencia cortar parte del efecto total de la inteligencia sobre el la inteligencia de los hijos. En otras palabras: la inteligencia de los padres hace más probable mejor NSE, y mejor NSE presenta mejores condiciones de desarrollo para sus hijos. Estatificar por esta variable bloquea este efecto.

@@ -1191,8 +1191,8 @@

", width = 200, height = 50)
-
- +
+
    @@ -1232,9 +1232,9 @@ 

    cor(sims_colisionador |> select(x,y))
    -
               x          y
-x 1.00000000 0.00744376
-y 0.00744376 1.00000000
    +
                 x            y
+x  1.000000000 -0.003586331
+y -0.003586331  1.000000000

    Sin embargo, si condicionamos a \(Z\), que puede tomar los valores 0 o 1:

    @@ -1265,8 +1265,8 @@ 

    cor(sims_colisionador |> filter(z == 0) |> select(x,y)) |> round(3)
           x      y
-x  1.000 -0.277
-y -0.277  1.000
    +x 1.000 -0.283 +y -0.283 1.000 
    print("Dado Z = 1")
    @@ -1275,8 +1275,8 @@ 

    cor(sims_colisionador |> filter(z == 1) |> select(x,y)) |> round(3)

          x     y
-x 1.000 0.376
-y 0.376 1.000
    +x 1.000 0.354 +y 0.354 1.000

    Otro ejemplo con variables continuas:

    @@ -1355,8 +1355,8 @@

    ", width = 200, height = 50)
    -
    - +
    +

    En este caso,

    @@ -1382,8 +1382,8 @@

    } ", width = 200, height = 50)
    -
    - +
    +
    @@ -1400,7 +1400,7 @@

    Ejemplo

    # No hay correlación cor(sims_colisionador$x, sims_colisionador$y)
    -
    [1] -0.006745788
    +
    [1] 0.008227776

    Sin embargo,

    @@ -1408,16 +1408,16 @@

    Ejemplo

    cor(sims_colisionador |> filter(a ==0) |> select(x,y))
               x          y
-x  1.0000000 -0.2801888
-y -0.2801888  1.0000000
    +x 1.0000000 -0.2670541 +y -0.2670541 1.0000000 
    cor(sims_colisionador |> filter(a ==1) |> select(x,y))
              x         y
-x 1.0000000 0.1012908
-y 0.1012908 1.0000000
    +x 1.0000000 0.1148013 +y 0.1148013 1.0000000
    @@ -1658,8 +1658,8 @@

    Ejemplo

    ")
    -
    - +
    +

    Consideremos la relación entre Z y Y. Primero vemos que hay dos caminos entre \(Z\) y \(Y\), que son \(p_1:X\gets V \to S\) y \(p_2: Z\to W \gets X \to Y\)

    @@ -1699,8 +1699,8 @@

    Ejercicio

    ")
    -
    - +
    +
    @@ -1737,8 +1737,8 @@

    E ")
    -
    - +
    +
      @@ -1796,8 +1796,8 @@

      ")#, width = 200, height = 50)
      -
      - +
      +

      Vimos que para calcular el efecto directo de \(F\) sobre \(W\), por ejemplo, es necesario bloquear el camino que pasa por \(G\) (estratificar por este nodo). Para el efecto total no es necesario condicionar a ningún otro nodo.

      @@ -1828,8 +1828,8 @@

      ")#, width = 200, height = 50)
      -
      - +
      +

      En este caso:

      diff --git a/05-dags_files/figure-html/unnamed-chunk-10-1.png b/05-dags_files/figure-html/unnamed-chunk-10-1.png index c9ca69c..b3f113f 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-10-1.png and b/05-dags_files/figure-html/unnamed-chunk-10-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-13-1.png b/05-dags_files/figure-html/unnamed-chunk-13-1.png index bde82f7..2147657 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-13-1.png and b/05-dags_files/figure-html/unnamed-chunk-13-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-14-1.png b/05-dags_files/figure-html/unnamed-chunk-14-1.png index 5872f2a..c120334 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-14-1.png and b/05-dags_files/figure-html/unnamed-chunk-14-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-22-1.png b/05-dags_files/figure-html/unnamed-chunk-22-1.png index be0d4a0..2aa4759 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-22-1.png and b/05-dags_files/figure-html/unnamed-chunk-22-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-25-1.png b/05-dags_files/figure-html/unnamed-chunk-25-1.png index fb4648a..1bdee84 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-25-1.png and b/05-dags_files/figure-html/unnamed-chunk-25-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-28-1.png b/05-dags_files/figure-html/unnamed-chunk-28-1.png index 12325e5..98921e5 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-28-1.png and b/05-dags_files/figure-html/unnamed-chunk-28-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-29-1.png b/05-dags_files/figure-html/unnamed-chunk-29-1.png index 932dedb..090772e 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-29-1.png and b/05-dags_files/figure-html/unnamed-chunk-29-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-32-1.png b/05-dags_files/figure-html/unnamed-chunk-32-1.png index 57969df..a65440f 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-32-1.png and b/05-dags_files/figure-html/unnamed-chunk-32-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-33-1.png b/05-dags_files/figure-html/unnamed-chunk-33-1.png index 8c544af..c1ff4ec 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-33-1.png and b/05-dags_files/figure-html/unnamed-chunk-33-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-37-1.png b/05-dags_files/figure-html/unnamed-chunk-37-1.png index d41d009..451c944 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-37-1.png and b/05-dags_files/figure-html/unnamed-chunk-37-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-38-1.png b/05-dags_files/figure-html/unnamed-chunk-38-1.png index 68d6eee..64f227a 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-38-1.png and b/05-dags_files/figure-html/unnamed-chunk-38-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-41-1.png b/05-dags_files/figure-html/unnamed-chunk-41-1.png index 1c88b06..579909c 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-41-1.png and b/05-dags_files/figure-html/unnamed-chunk-41-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-42-1.png b/05-dags_files/figure-html/unnamed-chunk-42-1.png index 71cee5c..9382651 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-42-1.png and b/05-dags_files/figure-html/unnamed-chunk-42-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-50-1.png b/05-dags_files/figure-html/unnamed-chunk-50-1.png index 46e11fb..5a84d56 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-50-1.png and b/05-dags_files/figure-html/unnamed-chunk-50-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-52-1.png b/05-dags_files/figure-html/unnamed-chunk-52-1.png index c773e7e..6d72973 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-52-1.png and b/05-dags_files/figure-html/unnamed-chunk-52-1.png differ diff --git a/05-dags_files/figure-html/unnamed-chunk-8-1.png b/05-dags_files/figure-html/unnamed-chunk-8-1.png index e4ee81a..3eae64c 100644 Binary files a/05-dags_files/figure-html/unnamed-chunk-8-1.png and b/05-dags_files/figure-html/unnamed-chunk-8-1.png differ diff --git a/06-calculo-do.html b/06-calculo-do.html index 1f502c3..589119e 100644 --- a/06-calculo-do.html +++ b/06-calculo-do.html @@ -338,8 +338,8 @@

      } ", width = 200, height = 50)
      -
      - +
      +

      Nos interesa estimar el efecto causal de \(X\) sobre \(Y\). Sucede que en muchas ocasiones existen variables como \(U\) que son causas comunes de \(X\) y \(Y\). Como vimos, esto implica que no podemos simplemente ver la correlación entre \(X\) y \(Y\) para entender el efecto de \(X\) sobre \(Y\), pues una causa común de variación conjunta entre estas dos variables. Esta variable \(U\) puede ser observada o no.

      @@ -362,8 +362,8 @@

      } ")
      -
      - +
      +

      Nótese que:

      @@ -421,8 +421,8 @@

      Ejemplo

      ", width = 100, height = 50)
      -
      - +
      +

      Gráfica de datos observacionales

      @@ -516,8 +516,8 @@

      Ejemplo

      ", width = 100, height = 50)
      -
      - +
      +

      Gráfica con intervención en A

      @@ -572,8 +572,8 @@

      Ejemplo

      ")
      -
      - +
      +
      @@ -623,8 +623,8 @@

      Ejemplo

      ")
      -
      - +
      +

      Ahora queremos calcular \(p(a|do(d)) = p_m(a|d)\) en función de los datos. Siguiendo el mismo argumento que en el ejemplo anterior, sabemos que tenemos que estratificar o condicionar a \(T\) para poder usar nuestro proceso generador de observaciones, y obtenemos:

      @@ -834,8 +834,8 @@

      Ejemplo (Pearl)")
      -
      - +
      +

      Observamos que no podemos directamente usar la fórmula de ajuste pues NSE no es una variable observada.

      @@ -864,8 +864,8 @@

      Ejemplo (Pearl)")
      -
      - +
      +

      En este caso, todavía no podemos aplicar la fórmula original de ajuste pues no conocemos \(NSE\). Sin embargo, podemos bloquear los caminos no causales estratificando por Peso, y entonces podemos usar el criterio de puerta trasera para identificar el efecto del tratamiento, aún cuando no tengamos NSE.

      @@ -1065,7 +1065,7 @@

      Ejemplo

      All 4 chains finished successfully. Mean chain execution time: 1.9 seconds. -Total execution time: 8.2 seconds. +Total execution time: 8.1 seconds. 
      sims <- ajuste$draws( format = "df")
 resumen <- ajuste$summary(c( "dif_trata"))
      @@ -1199,7 +1199,7 @@

      Ejemplo

      All 4 chains finished successfully. Mean chain execution time: 10.9 seconds. -Total execution time: 44.0 seconds. +Total execution time: 43.9 seconds. 
      sims <- ajuste$draws(c("dif_trata"), format = "df")
      @@ -1289,8 +1289,8 @@

      ")
      -
      - +
      +

      En este caso, el efecto de fumar (\(F\)) sobre cáncer (\(C\)) no es identificable pues no podemos condicionar a la variable de Genotipo (\(U\)). Supongamos que tenemos una medida adicional, que es la cantidad de depósitos de alquitrán den los pulmones de los pacientes. Este es es afectado por \(F\), y a su vez, el alquitrán incrementa la probabilidad de cáncer:

      @@ -1316,8 +1316,8 @@

      ")
      -
      - +
      +

      La idea es primero estimar el efecto de \(F\) sobre \(A\), y después estimar el efecto de \(A\) sobre \(C\). La “composición” de estos dos efectos, dado el diagrama, debe darnos el estimador correcto. Primero consideramos el efecto de \(F\) sobre \(A\), y tenemos que (regla 2)

      @@ -1531,26 +1531,26 @@

      diff --git a/07-buenos-malos-controles.html b/07-buenos-malos-controles.html index 846245e..f1adc3c 100644 --- a/07-buenos-malos-controles.html +++ b/07-buenos-malos-controles.html @@ -342,8 +342,8 @@

      ', width = 250, height = 60)
      -
      - +
      +
      @@ -377,8 +377,8 @@

      ")
      -
      - +
      +

      No hay ninguna variable confusora, y una estrategia de estimación es comparar \(PF\) entre los grupos.

      @@ -505,8 +505,8 @@

      ', width = 250, height = 120)
      -
      - +
      +
      @@ -555,8 +555,8 @@

      ', width = 250, height = 120)

      -
      - +
      +

      Hemos añadido un nodo implícito (otros factores que afectan \(Y\) y no tienen relación con otras variables del sistema) para explicar qué es lo que pasa cuando condicionamos a \(Z\): como \(Z\) es un descendiente del colisionador en \(Y\), se activa una ruta no causal entre \(U_y\) y \(T\), y estas dos cantidades aparecen como correlacionadas (es una correlación no causal). Esto en consecuencia modifica la correlación entre \(T\) y \(Y\).

      @@ -635,8 +635,8 @@

      ', width = 250, height = 140)
      -
      - +
      +
      @@ -666,8 +666,8 @@

      }")
      -
      - +
      +

      En la gráfica de arriba, \(T\) indica si la madre es fumadora o no, y \(Y\) la mortalidad. \(Z\) si el bebé nació con bajo peso o no.

      @@ -694,8 +694,8 @@

      }', width = 100, height = 50)
      -
      - +
      +

      En este caso, condicionar a \(Z\) no sesga nuestras estimaciones, pues no activamos ninguna ruta no causal. La dificultad es que típicamente disminuye la precisión de la estimación (usamos un modelo más grande donde no es necesario):

      @@ -741,8 +741,8 @@

      }', width = 100, height = 50)
      -
      - +
      +

      En este caso, tenemos una variable confusora \(U\) que no nos permite estimar sin sesgo el efecto de \(T\) sobre \(Y\). Sin embargo, si condicionamos a \(Z\), la situación puede emperorar (amplificación de sesgo), pues dentro de cada nivel de \(Z\) hay menos variación de \(X\), y eso implica que la covarianza entre \(X\) y \(Y\), en cada nivel de \(Z\), se debe más a la variable confusora.

      diff --git a/08-mcmc.html b/08-mcmc.html index 11bebcb..b9f4b6e 100644 --- a/08-mcmc.html +++ b/08-mcmc.html @@ -973,7 +973,7 @@ 

         user  system elapsed 
-  0.065   0.000   0.065
      + 0.064 0.000 0.064 
      system.time(metropolis_1 <- metropolis_mc(1000, c(1,2), log_p, 0.2, 0.2))
      @@ -989,7 +989,7 @@ 

         user  system elapsed 
-  0.018   0.000   0.018
      + 0.017 0.000 0.018

      @@ -1211,14 +1211,14 @@

      -
      Chain 3 Exception: normal_lpdf: Scale parameter is 0, but must be positive! (in '/tmp/RtmpoyEmkk/model-27505774c436.stan', line 25, column 2 to column 33)
      +
      Chain 3 Exception: normal_lpdf: Scale parameter is 0, but must be positive! (in '/tmp/RtmpSzeTvI/model-28032f01014c.stan', line 25, column 2 to column 33)

      Chain 3 If this warning occurs sporadically, such as for highly constrained variable types like covariance matrices, then the sampler is fine,
      @@ -2812,19 +2812,19 @@

      +Total execution time: 1.1 seconds.

      Y con este truco de reparametrización el muestreador funciona correctamente (observa que la media de \(y\) está estimada correctamente, y no hay divergencias).

      diff --git a/09-modelos-jerarquicos.html b/09-modelos-jerarquicos.html index d2c0749..b917c9a 100644 --- a/09-modelos-jerarquicos.html +++ b/09-modelos-jerarquicos.html @@ -378,7 +378,7 @@

      1  Introducción" ] @@ -244,7 +244,7 @@ "href": "03-modelos-genericos.html#efecto-directo-de-sexo", "title": "4  Componentes de modelación 1", "section": "4.6 Efecto directo de sexo", - "text": "4.6 Efecto directo de sexo\nAhora pensemos cómo podemos calcular el efecto directo de sexo sobre peso, sin tomar en cuente su influencia en la estatura. En nuestro diagrama, nos interesa sólo considerar la influencia que va directamente de sexo a peso, y no la que pasa por el camino que va a través de la estatura. Este tipo de análisis se llama a veces análisis de mediación.\nLa idea es bloquear el camino que va de sexo a estatura, y esto podemos hacer condicionando o estratificando por los valores de \\(H\\). Es decir, para cada valor de \\(H\\), queremos calcular cuál es la diferencia entre una población de hombres y de mujeres (con la misma estatura \\(H\\)). Las diferencias que encontremos no puede deberse a estatura, pues esta valor es fijo. Al estratificar por \\(H\\), decimos que el camino \\(S\\to H\\to W\\) está bloqueado, y refinaremos esta idea más adelante.\nEn términos de cantidad a estimar, quisiéramos, para cada estatura \\(H\\), calcular la diferencia de una población de hombres vs una de mujeres. La diferencia es el efecto directo a la estatura \\(H\\).\nEl modelo estadístico que proponemos para estimar el efecto directo es entonces:\n\\[\n\\begin{align}\nW_i &\\sim N(\\mu_i, \\sigma)\\\\\n\\mu_i &= \\alpha_{S_i} + \\beta_{S_i} (H_i - \\bar{H})\\\\\n\\alpha_1,\\alpha_2 &\\sim N(60, 10) \\\\\n\\beta_1,\\beta_2 &\\sim N^+(0, 1) \\\\\n\\sigma &\\sim N^+(0, 20) \\\\\n\\end{align}\n\\]\nEl contraste que queremos calcular lo podemos identificar con parámetros en el modelo. Por ejemplo, si \\(\\beta_1 = \\beta_2\\), el efecto directo, para cualquier estatura, debería ser \\(\\alpha_2 - \\alpha_1\\). Sin embargo, seguimos con nuestro camino de hacer simulación para mantener más flexibilidad y simplicidad.\nEjercicio: Haz verificaciones a priori: genera datos sintéticos, examínalos, y verifica que el modelo es capaz de recuperar el contraste de interés.\n\n4.6.1 Ajuste a datos reales y resumen\n\nmod_peso_2 <- cmdstan_model(\"./src/peso-estatura-3.stan\")\nprint(mod_peso_2)\n\ndata {\n int<lower=0> N;\n vector[N] w;\n vector[N] h;\n array[N] int s;\n}\n\ntransformed data {\n real h_media;\n h_media = mean(h);\n}\n\nparameters {\n array[2] real alpha;\n array[2] real<lower=0> beta;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n array[N] real mu;\n for (i in 1:N) {\n mu[i] = alpha[s[i]] + beta[s[i]] * (h[i] - h_media);\n }\n}\n\nmodel {\n // modelo para peso\n w ~ normal(mu, sigma);\n // también se puede escribir:\n //for (i in 1:N) {\n // w[i] ~ normal(mu[i], sigma);\n //}\n alpha ~ normal(60, 10);\n beta ~ normal(0, 1);\n sigma ~ normal(0, 20);\n}\n\ngenerated quantities {\n\n}\n\n\n\nmod_3_fit <- mod_peso_2$sample(\n data = list(N = nrow(datos_tbl), \n s = datos_tbl$male + 1, \n h = datos_tbl$height,\n w = datos_tbl$weight),\n init = 0.01, step_size = 0.01, refresh = 0, seed = 221\n)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 finished in 0.3 seconds.\nChain 2 finished in 0.3 seconds.\nChain 3 finished in 0.3 seconds.\nChain 4 finished in 0.3 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.3 seconds.\nTotal execution time: 1.3 seconds.\n\n\n\nmod_3_fit$summary(c(\"alpha\", \"beta\", \"sigma\")) |> \n knitr::kable(digits = 2)\n\n\n\n\n\nvariable\nmean\nmedian\nsd\nmad\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nalpha[1]\n45.17\n45.17\n0.45\n0.45\n44.45\n45.91\n1\n2270.19\n2455.26\n\n\nalpha[2]\n45.09\n45.10\n0.47\n0.45\n44.31\n45.83\n1\n2822.98\n2524.93\n\n\nbeta[1]\n0.66\n0.66\n0.06\n0.06\n0.55\n0.76\n1\n2109.75\n2083.05\n\n\nbeta[2]\n0.61\n0.61\n0.06\n0.06\n0.52\n0.70\n1\n2737.57\n2646.95\n\n\nsigma\n4.27\n4.26\n0.16\n0.16\n4.02\n4.55\n1\n4090.86\n2699.93\n\n\n\n\n\n\n\n\nLa diferencia entre las dos rectas parece ser chica. Eso implicaría que el efecto directo de sexo en peso es débil. Sin embargo, es mejor calcular y resumir el contraste como hemos hecho en otros ejemplos.\nRepetimos exactamente el proceso que probamos arriba. Haremos los cálculos manualmente otra vez (aunque conviene más hacerlos dentro de stan):\n\nsims_post_tbl <- mod_3_fit$draws() |> as_draws_df() |> \n as_tibble()\nh_media <- mean(datos_tbl$height)\n# función para simular pesos\nsim_peso_mod_sh <- function(S, H, alpha, beta, sigma, h_media){\n n <- length(S)\n W <- rnorm(n, alpha[S] + beta[S] * (H - h_media), sigma)\n tibble(W = W)\n}\nsimular_diferencia_post_2 <- function(sims_post_tbl, h){\n pars <- sample_n(sims_post_tbl, 1) |> \n select(starts_with(c(\"alpha\", \"beta\")), sigma)\n alpha <- c(pars$`alpha[1]`, pars$`alpha[2]`)\n beta <- c(pars$`beta[1]`, pars$`beta[2]`)\n diferencia <- numeric(length(h))\n # para cada nivel de estatura especificado\n for(i in seq_along(h)){\n # Simulamos poblaciones\n sims_hombres <- sim_peso_mod_sh(rep(2, 1000), h[i],\n alpha = alpha, beta = beta, pars$sigma, h_media = h_media)\n sims_mujeres <- sim_peso_mod_sh(rep(1, 1000), h[i],\n alpha = alpha, beta = beta, pars$sigma, h_media = h_media)\n diferencia[i] <- mean(sims_hombres$W - sims_mujeres$W)\n }\n tibble(diferencia = diferencia, h = h) |> bind_cols(pars)\n}\n\nPor ejemplo:\n\nsimular_diferencia_post_2(sims_post_tbl, h = c(150, 170))\n\n# A tibble: 2 × 7\n diferencia h `alpha[1]` `alpha[2]` `beta[1]` `beta[2]` sigma\n <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 1.38 150 45.2 45.9 0.610 0.502 4.25\n2 -0.836 170 45.2 45.9 0.610 0.502 4.25\n\n\n\nh <- seq(130, 190, by = 5)\ndif_tbl <- map_df(1:1000, \n ~ simular_diferencia_post_2(sims_post_tbl, h) |> \n mutate(rep = .x))\n\n\ndif_tbl |> \nggplot(aes(x = h, y = diferencia, group = rep)) +\n geom_line(alpha = 0.1) +\n labs(x = \"Contraste de peso hombres vs mujeres (kg)\") +\n geom_hline(yintercept = 0, colour = \"red\") \n\n\n\n\n\n\n\n\nEsto muestra que el efecto directo de sexo en peso es relativamente chico: la mayor parte del efecto es a través de la estatura. Existe una ligera tendencia a que los hombre de menos estatura sean más pesados, y las mujeres de más estatura sean relativamente menos pesadas, pero realmente no podemos afirmar con confianza ningún efecto claro.\n\n\n\n\n\n\nTip\n\n\n\nCuando agregamos una variable como estatura en el modelo de regresión, decimos que estamos estratificando por estatura. En este caso, bloqueamos el efecto causal que tiene sexo en peso a través de la estatura. El efecto causal entre los la variable sexo, que se hace dentro de cada estrato, y se expresa en los coeficientes de sexo, tiene una interpretación totalmente diferente en comparación al modelo que no incluye estatura.", + "text": "4.6 Efecto directo de sexo\nAhora pensemos cómo podemos calcular el efecto directo de sexo sobre peso, sin tomar en cuente su influencia en la estatura. En nuestro diagrama, nos interesa sólo considerar la influencia que va directamente de sexo a peso, y no la que pasa por el camino que va a través de la estatura. Este tipo de análisis se llama a veces análisis de mediación.\nLa idea es bloquear el camino que va de sexo a estatura, y esto podemos hacer condicionando o estratificando por los valores de \\(H\\). Es decir, para cada valor de \\(H\\), queremos calcular cuál es la diferencia entre una población de hombres y de mujeres (con la misma estatura \\(H\\)). Las diferencias que encontremos no puede deberse a estatura, pues esta valor es fijo. Al estratificar por \\(H\\), decimos que el camino \\(S\\to H\\to W\\) está bloqueado, y refinaremos esta idea más adelante.\nEn términos de cantidad a estimar, quisiéramos, para cada estatura \\(H\\), calcular la diferencia de una población de hombres vs una de mujeres. La diferencia es el efecto directo a la estatura \\(H\\).\nEl modelo estadístico que proponemos para estimar el efecto directo es entonces:\n\\[\n\\begin{align}\nW_i &\\sim N(\\mu_i, \\sigma)\\\\\n\\mu_i &= \\alpha_{S_i} + \\beta_{S_i} (H_i - \\bar{H})\\\\\n\\alpha_1,\\alpha_2 &\\sim N(60, 10) \\\\\n\\beta_1,\\beta_2 &\\sim N^+(0, 1) \\\\\n\\sigma &\\sim N^+(0, 20) \\\\\n\\end{align}\n\\]\nEl contraste que queremos calcular lo podemos identificar con parámetros en el modelo. Por ejemplo, si \\(\\beta_1 = \\beta_2\\), el efecto directo, para cualquier estatura, debería ser \\(\\alpha_2 - \\alpha_1\\). Sin embargo, seguimos con nuestro camino de hacer simulación para mantener más flexibilidad y simplicidad.\nEjercicio: Haz verificaciones a priori: genera datos sintéticos, examínalos, y verifica que el modelo es capaz de recuperar el contraste de interés.\n\n4.6.1 Ajuste a datos reales y resumen\n\nmod_peso_2 <- cmdstan_model(\"./src/peso-estatura-3.stan\")\nprint(mod_peso_2)\n\ndata {\n int<lower=0> N;\n vector[N] w;\n vector[N] h;\n array[N] int s;\n}\n\ntransformed data {\n real h_media;\n h_media = mean(h);\n}\n\nparameters {\n array[2] real alpha;\n array[2] real<lower=0> beta;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n array[N] real mu;\n for (i in 1:N) {\n mu[i] = alpha[s[i]] + beta[s[i]] * (h[i] - h_media);\n }\n}\n\nmodel {\n // modelo para peso\n w ~ normal(mu, sigma);\n // también se puede escribir:\n //for (i in 1:N) {\n // w[i] ~ normal(mu[i], sigma);\n //}\n alpha ~ normal(60, 10);\n beta ~ normal(0, 1);\n sigma ~ normal(0, 20);\n}\n\ngenerated quantities {\n\n}\n\n\n\nmod_3_fit <- mod_peso_2$sample(\n data = list(N = nrow(datos_tbl), \n s = datos_tbl$male + 1, \n h = datos_tbl$height,\n w = datos_tbl$weight),\n init = 0.01, step_size = 0.01, refresh = 0, seed = 221\n)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 finished in 0.3 seconds.\nChain 2 finished in 0.3 seconds.\nChain 3 finished in 0.3 seconds.\nChain 4 finished in 0.3 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.3 seconds.\nTotal execution time: 1.4 seconds.\n\n\n\nmod_3_fit$summary(c(\"alpha\", \"beta\", \"sigma\")) |> \n knitr::kable(digits = 2)\n\n\n\n\n\nvariable\nmean\nmedian\nsd\nmad\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nalpha[1]\n45.17\n45.17\n0.45\n0.45\n44.45\n45.91\n1\n2270.19\n2455.26\n\n\nalpha[2]\n45.09\n45.10\n0.47\n0.45\n44.31\n45.83\n1\n2822.98\n2524.93\n\n\nbeta[1]\n0.66\n0.66\n0.06\n0.06\n0.55\n0.76\n1\n2109.75\n2083.05\n\n\nbeta[2]\n0.61\n0.61\n0.06\n0.06\n0.52\n0.70\n1\n2737.57\n2646.95\n\n\nsigma\n4.27\n4.26\n0.16\n0.16\n4.02\n4.55\n1\n4090.86\n2699.93\n\n\n\n\n\n\n\n\nLa diferencia entre las dos rectas parece ser chica. Eso implicaría que el efecto directo de sexo en peso es débil. Sin embargo, es mejor calcular y resumir el contraste como hemos hecho en otros ejemplos.\nRepetimos exactamente el proceso que probamos arriba. Haremos los cálculos manualmente otra vez (aunque conviene más hacerlos dentro de stan):\n\nsims_post_tbl <- mod_3_fit$draws() |> as_draws_df() |> \n as_tibble()\nh_media <- mean(datos_tbl$height)\n# función para simular pesos\nsim_peso_mod_sh <- function(S, H, alpha, beta, sigma, h_media){\n n <- length(S)\n W <- rnorm(n, alpha[S] + beta[S] * (H - h_media), sigma)\n tibble(W = W)\n}\nsimular_diferencia_post_2 <- function(sims_post_tbl, h){\n pars <- sample_n(sims_post_tbl, 1) |> \n select(starts_with(c(\"alpha\", \"beta\")), sigma)\n alpha <- c(pars$`alpha[1]`, pars$`alpha[2]`)\n beta <- c(pars$`beta[1]`, pars$`beta[2]`)\n diferencia <- numeric(length(h))\n # para cada nivel de estatura especificado\n for(i in seq_along(h)){\n # Simulamos poblaciones\n sims_hombres <- sim_peso_mod_sh(rep(2, 1000), h[i],\n alpha = alpha, beta = beta, pars$sigma, h_media = h_media)\n sims_mujeres <- sim_peso_mod_sh(rep(1, 1000), h[i],\n alpha = alpha, beta = beta, pars$sigma, h_media = h_media)\n diferencia[i] <- mean(sims_hombres$W - sims_mujeres$W)\n }\n tibble(diferencia = diferencia, h = h) |> bind_cols(pars)\n}\n\nPor ejemplo:\n\nsimular_diferencia_post_2(sims_post_tbl, h = c(150, 170))\n\n# A tibble: 2 × 7\n diferencia h `alpha[1]` `alpha[2]` `beta[1]` `beta[2]` sigma\n <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 1.38 150 45.2 45.9 0.610 0.502 4.25\n2 -0.836 170 45.2 45.9 0.610 0.502 4.25\n\n\n\nh <- seq(130, 190, by = 5)\ndif_tbl <- map_df(1:1000, \n ~ simular_diferencia_post_2(sims_post_tbl, h) |> \n mutate(rep = .x))\n\n\ndif_tbl |> \nggplot(aes(x = h, y = diferencia, group = rep)) +\n geom_line(alpha = 0.1) +\n labs(x = \"Contraste de peso hombres vs mujeres (kg)\") +\n geom_hline(yintercept = 0, colour = \"red\") \n\n\n\n\n\n\n\n\nEsto muestra que el efecto directo de sexo en peso es relativamente chico: la mayor parte del efecto es a través de la estatura. Existe una ligera tendencia a que los hombre de menos estatura sean más pesados, y las mujeres de más estatura sean relativamente menos pesadas, pero realmente no podemos afirmar con confianza ningún efecto claro.\n\n\n\n\n\n\nTip\n\n\n\nCuando agregamos una variable como estatura en el modelo de regresión, decimos que estamos estratificando por estatura. En este caso, bloqueamos el efecto causal que tiene sexo en peso a través de la estatura. El efecto causal entre los la variable sexo, que se hace dentro de cada estrato, y se expresa en los coeficientes de sexo, tiene una interpretación totalmente diferente en comparación al modelo que no incluye estatura.", "crumbs": [ "4  Componentes de modelación 1" ] @@ -274,7 +274,7 @@ "href": "03-modelos-genericos.html#modelos-genéricos-para-ajustar-curvas", "title": "4  Componentes de modelación 1", "section": "4.9 Modelos genéricos para ajustar curvas", - "text": "4.9 Modelos genéricos para ajustar curvas\nOtra posibilidad es utilizar un modelo más flexible creando variables derivadas de la distancia. En este caso, quizá podemos ajustar una curva que sea aceptable desde el punto de vista predictivo, pero no podremos aprender mucho acerca de cómo funciona la probabilidad de éxitos de los tiros de putts\n\n\n\n\n\n\nSplines y ajuste de curvas\n\n\n\nLos splines nos dan una manera estándar de ajustar curvas más flexibles, de tipo polinomial por tramos. Usualmente son numéricamente más conveniente que polinomios.\n\n\nAunque hay muchos tipos de splines (los más comunes son B-splines), para este problema consideraremos una base de splines cuadráticos que resultan en curvas monótonas (I-splines). Puedes ver más detalles de splines en McElreath (2020)\nEn este caso, haremos expansión de entradas de las siguiente manera. Supongamos que tenemos la variable de distancia \\(d\\) que va de 0 a 750 cm, por ejemplo. Construimos entradas derivadas de la siguiente manera:\n\nlibrary(splines2)\nnudos <- c(25, 50, 100, 200, 400)\ndistancias <- seq(0, 750, 1)\nsplines_tbl <- iSpline(distancias, knots = nudos, \n Boundary.knots = c(0, 750), degree = 2, intercept = FALSE) |> \n as_tibble() |> \n mutate(d = distancias) |> \n pivot_longer(-d, names_to = \"spline\", values_to = \"valor\")\nggplot(splines_tbl) +\n geom_line(aes(x = d, y = valor, color = spline)) +\n geom_vline(xintercept = nudos, color = \"red\", linetype = 2) \n\n\n\n\n\n\n\n\nEsta gráfica muestra cómo para cada distancia \\(x\\) generamos valores \\(x_1,\\ldots, x_p\\) que son variables derivadas de \\(x\\). Podemos entonces obtener más flexibilidad hacer regresión en estas nuevas \\(p\\) variables en lugar de usar solamente \\(x\\). Por la elección de la base, obsérvese que siempre que \\(\\beta_1, \\ldots, \\beta_p\\) sean no negativos, entonces la función \\[\\alpha + \\beta_1 x_1 + \\cdots + \\beta_p x_p\\] será monótona no decreciente, que es lo que necesitamos para este problema.\nNuestra función generadora para este modelo puede ser:\n\nsimular_putts <- function(distancias, nudos) {\n # Simular intercepto\n alpha <- rnorm(1, 4, 2)\n # Simular coeficientes de splines\n beta <- - abs(rnorm(7, 0, 1.5))\n # Calcular splines para distancias dadas\n mat_splines <- splines2::iSpline(distancias, \n Boundary.knots = c(0, 750), knots = nudos, degree = 2, intercept = FALSE) \n # Calcular probabilidad de éxito con regresión logística\n p <- 1 / (1 + exp(- alpha - mat_splines %*% beta))\n tibble(y = rbinom(length(distancias), 1, p), p = p, d = distancias) |> \n select(d, p, y) |> \n mutate(alpha = alpha, beta = list(beta))\n}\n\n\nset.seed(8123)\ndistancias <- seq(1, 600, 5) |> rep(each = 5)\nsimular_putts(distancias, nudos) |> \n ggplot(aes(x = d, y = y)) +\n geom_jitter(height = 0.1) +\n labs(x = \"Distancia (cm)\", y = \"Éxito\") +\n geom_smooth(span = 1, se = FALSE)\n\n`geom_smooth()` using method = 'loess' and formula = 'y ~ x'\n\n\n\n\n\n\n\n\n\nY podemos hacer simulaciones a priori para entender nuestros supuestos:\n\nmap_df(1:100, \\(x) simular_putts(distancias, nudos) |> mutate(id = x)) |> \n ggplot(aes(x = d, y = p, group = id)) +\n geom_line(alpha = 0.2) +\n labs(x = \"Distancia (cm)\", y = \"Probabilidad de Éxito\")\n\n\n\n\n\n\n\n\nAhora construimos nuestro nuevo modelo en Stan, donde \\(x\\) será la matriz de splines (entradas derivadas como se explicó arriba):\n\n#! message: false\nlibrary(cmdstanr)\nmod_logistica_splines <- cmdstan_model(\"./src/golf-logistico-splines.stan\")\nprint(mod_logistica_splines)\n\ndata {\n int<lower=0> N;\n int<lower=0> p;\n array[N] int n;\n vector[N] d;\n matrix[N, p] x;\n array[N] int y;\n}\nparameters {\n real alpha;\n array[p] real<upper=0> beta;\n}\nmodel {\n for(i in 1:N){\n y[i] ~ binomial_logit(n[i], alpha + dot_product(x[i,], to_vector(beta)));\n }\n alpha ~ normal(4, 2);\n beta ~ normal(0, 1.5);\n}\n\n\n\nset.seed(1225)\nmat_splines <- splines2::iSpline(30.48 * datos_golf$x, \n Boundary.knots = c(0, 750), knots = nudos, degree = 2, intercept = FALSE) \najuste <- mod_logistica_splines$sample(\n data = list(N = nrow(datos_golf), p = ncol(mat_splines),\n d = 30.48 * datos_golf$x, \n x = mat_splines,\n y = datos_golf$y, n = datos_golf$n), \n refresh = 1000, init = 0.1, \n step_size = 0.1, adapt_delta = 0.99)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 2.9 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 3.2 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 3.2 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 4.2 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 3.3 seconds.\nTotal execution time: 13.7 seconds.\n\n\nWarning: 236 of 4000 (6.0%) transitions hit the maximum treedepth limit of 10.\nSee https://mc-stan.org/misc/warnings for details.\n\nsims <- ajuste$draws(c(\"alpha\", \"beta\"), format = \"df\")\n\nresumen <- ajuste$summary()\n\n\nresumen\n\n# A tibble: 9 × 10\n variable mean median sd mad q5 q95 rhat ess_bulk\n <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 lp__ -2911. -2911. 2.22 2.13 -2916. -2908. 1.00 1193.\n2 alpha 4.88 4.80 0.939 0.934 3.49 6.57 1.00 1575.\n3 beta[1] -0.974 -0.803 0.748 0.743 -2.39 -0.0803 1.00 1876.\n4 beta[2] -1.24 -1.12 0.796 0.839 -2.70 -0.156 1.00 1665.\n5 beta[3] -1.91 -1.92 0.269 0.268 -2.35 -1.46 1.00 1548.\n6 beta[4] -1.03 -1.03 0.226 0.229 -1.40 -0.669 1.00 1501.\n7 beta[5] -1.23 -1.24 0.265 0.264 -1.63 -0.758 1.00 1650.\n8 beta[6] -0.403 -0.350 0.289 0.292 -0.949 -0.0319 1.00 1718.\n9 beta[7] -0.645 -0.529 0.521 0.485 -1.69 -0.0490 1.00 2091.\n# ℹ 1 more variable: ess_tail <dbl>\n\n\nAhora simulamos la posterior y la contrastamos con los datos:\n\nd <- 30.48 * seq(0, 20, 0.5)\nmat_splines_pred <- splines2::iSpline(30.48 * seq(0, 20, 0.5), \n Boundary.knots = c(0, 750), knots = nudos, degree = 2,\n intercept = FALSE) \nsims_2 <- sims |> group_by(.draw, .chain, .iteration) |> nest() \ngrafs <- purrr::map(sims_2$data, function(pars){\n pars <- as.numeric(pars)\n alpha <- pars[1]\n beta <- pars[2:8]\n p <- 1/(1 + exp(- alpha - mat_splines_pred %*% beta))\n tibble(p = as.numeric(p), d = d)\n})\nsims_graf_tbl <- sims_2 |> add_column(graf = grafs) |> select(-data) |> \n ungroup() |> \n slice_sample(n = 100) |> \n select(.draw, graf) |> \n unnest(graf) \n\n\nsims_graf_tbl |> \n ggplot(aes(x = d, y = p)) +\n geom_line(aes(group = .draw), alpha = 0.1) +\n labs(x = \"Distancia (cm)\", y = \"Probabilidad de Éxito\") +\n geom_point(data = resumen_golf, color = \"red\") +\n geom_linerange(data = resumen_golf, \n aes(ymin = p - 2 * sqrt(p * (1 - p) / n), \n ymax = p + 2 * sqrt(p * (1 - p) / n)),\n color = \"red\")\n\n\n\n\n\n\n\n\nEste modelo ajusta mejor, y puede ser usado para hacer comparaciones de probabilidad de éxito a diferentes distancias. Su defecto es que no es interpetable como nuestro modelo anterior (aprendemos poco sobre cómo funcionan los putts), y es considerablemente más difícil de ajustar.\nPuedes ver más de splines en McElreath (2020), y en Hastie, Tibshirani, y Friedman (2017). Puedes revisar también este caso de Stan que explica cómo utilizar splines de forma más general en Stan.\n\n\n\n\nGelman, Andrew, y Deborah Nolan. 2002. «A Probability Model for Golf Putting». Teaching Statistics 24 (septiembre): 93-95. https://doi.org/10.1111/1467-9639.00097.\n\n\nHastie, Trevor, Robert Tibshirani, y Jerome Friedman. 2017. The Elements of Statistical Learning. Springer Series en Statistics. Springer New York Inc. http://web.stanford.edu/~hastie/ElemStatLearn/.\n\n\nHolmes, Brian W. 1991. «Putting: How a golf ball and hole interact». American Journal of Physics 59 (2): 129-36. https://doi.org/10.1119/1.16592.\n\n\nMcElreath, R. 2020. Statistical Rethinking: A Bayesian Course with Examples in R and Stan. A Chapman & Hall libro. CRC Press. https://books.google.com.mx/books?id=Ie2vxQEACAAJ.\n\n\nPenner, Albert. 2002. «The physics of putting». Canadian Journal of Physics 80 (febrero): 83-96. https://doi.org/10.1139/p01-137.", + "text": "4.9 Modelos genéricos para ajustar curvas\nOtra posibilidad es utilizar un modelo más flexible creando variables derivadas de la distancia. En este caso, quizá podemos ajustar una curva que sea aceptable desde el punto de vista predictivo, pero no podremos aprender mucho acerca de cómo funciona la probabilidad de éxitos de los tiros de putts\n\n\n\n\n\n\nSplines y ajuste de curvas\n\n\n\nLos splines nos dan una manera estándar de ajustar curvas más flexibles, de tipo polinomial por tramos. Usualmente son numéricamente más conveniente que polinomios.\n\n\nAunque hay muchos tipos de splines (los más comunes son B-splines), para este problema consideraremos una base de splines cuadráticos que resultan en curvas monótonas (I-splines). Puedes ver más detalles de splines en McElreath (2020)\nEn este caso, haremos expansión de entradas de las siguiente manera. Supongamos que tenemos la variable de distancia \\(d\\) que va de 0 a 750 cm, por ejemplo. Construimos entradas derivadas de la siguiente manera:\n\nlibrary(splines2)\nnudos <- c(25, 50, 100, 200, 400)\ndistancias <- seq(0, 750, 1)\nsplines_tbl <- iSpline(distancias, knots = nudos, \n Boundary.knots = c(0, 750), degree = 2, intercept = FALSE) |> \n as_tibble() |> \n mutate(d = distancias) |> \n pivot_longer(-d, names_to = \"spline\", values_to = \"valor\")\nggplot(splines_tbl) +\n geom_line(aes(x = d, y = valor, color = spline)) +\n geom_vline(xintercept = nudos, color = \"red\", linetype = 2) \n\n\n\n\n\n\n\n\nEsta gráfica muestra cómo para cada distancia \\(x\\) generamos valores \\(x_1,\\ldots, x_p\\) que son variables derivadas de \\(x\\). Podemos entonces obtener más flexibilidad hacer regresión en estas nuevas \\(p\\) variables en lugar de usar solamente \\(x\\). Por la elección de la base, obsérvese que siempre que \\(\\beta_1, \\ldots, \\beta_p\\) sean no negativos, entonces la función \\[\\alpha + \\beta_1 x_1 + \\cdots + \\beta_p x_p\\] será monótona no decreciente, que es lo que necesitamos para este problema.\nNuestra función generadora para este modelo puede ser:\n\nsimular_putts <- function(distancias, nudos) {\n # Simular intercepto\n alpha <- rnorm(1, 4, 2)\n # Simular coeficientes de splines\n beta <- - abs(rnorm(7, 0, 1.5))\n # Calcular splines para distancias dadas\n mat_splines <- splines2::iSpline(distancias, \n Boundary.knots = c(0, 750), knots = nudos, degree = 2, intercept = FALSE) \n # Calcular probabilidad de éxito con regresión logística\n p <- 1 / (1 + exp(- alpha - mat_splines %*% beta))\n tibble(y = rbinom(length(distancias), 1, p), p = p, d = distancias) |> \n select(d, p, y) |> \n mutate(alpha = alpha, beta = list(beta))\n}\n\n\nset.seed(8123)\ndistancias <- seq(1, 600, 5) |> rep(each = 5)\nsimular_putts(distancias, nudos) |> \n ggplot(aes(x = d, y = y)) +\n geom_jitter(height = 0.1) +\n labs(x = \"Distancia (cm)\", y = \"Éxito\") +\n geom_smooth(span = 1, se = FALSE)\n\n`geom_smooth()` using method = 'loess' and formula = 'y ~ x'\n\n\n\n\n\n\n\n\n\nY podemos hacer simulaciones a priori para entender nuestros supuestos:\n\nmap_df(1:100, \\(x) simular_putts(distancias, nudos) |> mutate(id = x)) |> \n ggplot(aes(x = d, y = p, group = id)) +\n geom_line(alpha = 0.2) +\n labs(x = \"Distancia (cm)\", y = \"Probabilidad de Éxito\")\n\n\n\n\n\n\n\n\nAhora construimos nuestro nuevo modelo en Stan, donde \\(x\\) será la matriz de splines (entradas derivadas como se explicó arriba):\n\n#! message: false\nlibrary(cmdstanr)\nmod_logistica_splines <- cmdstan_model(\"./src/golf-logistico-splines.stan\")\nprint(mod_logistica_splines)\n\ndata {\n int<lower=0> N;\n int<lower=0> p;\n array[N] int n;\n vector[N] d;\n matrix[N, p] x;\n array[N] int y;\n}\nparameters {\n real alpha;\n array[p] real<upper=0> beta;\n}\nmodel {\n for(i in 1:N){\n y[i] ~ binomial_logit(n[i], alpha + dot_product(x[i,], to_vector(beta)));\n }\n alpha ~ normal(4, 2);\n beta ~ normal(0, 1.5);\n}\n\n\n\nset.seed(1225)\nmat_splines <- splines2::iSpline(30.48 * datos_golf$x, \n Boundary.knots = c(0, 750), knots = nudos, degree = 2, intercept = FALSE) \najuste <- mod_logistica_splines$sample(\n data = list(N = nrow(datos_golf), p = ncol(mat_splines),\n d = 30.48 * datos_golf$x, \n x = mat_splines,\n y = datos_golf$y, n = datos_golf$n), \n refresh = 1000, init = 0.1, \n step_size = 0.1, adapt_delta = 0.99)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 2.9 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 3.2 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 3.2 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 4.2 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 3.4 seconds.\nTotal execution time: 13.8 seconds.\n\n\nWarning: 236 of 4000 (6.0%) transitions hit the maximum treedepth limit of 10.\nSee https://mc-stan.org/misc/warnings for details.\n\nsims <- ajuste$draws(c(\"alpha\", \"beta\"), format = \"df\")\n\nresumen <- ajuste$summary()\n\n\nresumen\n\n# A tibble: 9 × 10\n variable mean median sd mad q5 q95 rhat ess_bulk\n <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 lp__ -2911. -2911. 2.22 2.13 -2916. -2908. 1.00 1193.\n2 alpha 4.88 4.80 0.939 0.934 3.49 6.57 1.00 1575.\n3 beta[1] -0.974 -0.803 0.748 0.743 -2.39 -0.0803 1.00 1876.\n4 beta[2] -1.24 -1.12 0.796 0.839 -2.70 -0.156 1.00 1665.\n5 beta[3] -1.91 -1.92 0.269 0.268 -2.35 -1.46 1.00 1548.\n6 beta[4] -1.03 -1.03 0.226 0.229 -1.40 -0.669 1.00 1501.\n7 beta[5] -1.23 -1.24 0.265 0.264 -1.63 -0.758 1.00 1650.\n8 beta[6] -0.403 -0.350 0.289 0.292 -0.949 -0.0319 1.00 1718.\n9 beta[7] -0.645 -0.529 0.521 0.485 -1.69 -0.0490 1.00 2091.\n# ℹ 1 more variable: ess_tail <dbl>\n\n\nAhora simulamos la posterior y la contrastamos con los datos:\n\nd <- 30.48 * seq(0, 20, 0.5)\nmat_splines_pred <- splines2::iSpline(30.48 * seq(0, 20, 0.5), \n Boundary.knots = c(0, 750), knots = nudos, degree = 2,\n intercept = FALSE) \nsims_2 <- sims |> group_by(.draw, .chain, .iteration) |> nest() \ngrafs <- purrr::map(sims_2$data, function(pars){\n pars <- as.numeric(pars)\n alpha <- pars[1]\n beta <- pars[2:8]\n p <- 1/(1 + exp(- alpha - mat_splines_pred %*% beta))\n tibble(p = as.numeric(p), d = d)\n})\nsims_graf_tbl <- sims_2 |> add_column(graf = grafs) |> select(-data) |> \n ungroup() |> \n slice_sample(n = 100) |> \n select(.draw, graf) |> \n unnest(graf) \n\n\nsims_graf_tbl |> \n ggplot(aes(x = d, y = p)) +\n geom_line(aes(group = .draw), alpha = 0.1) +\n labs(x = \"Distancia (cm)\", y = \"Probabilidad de Éxito\") +\n geom_point(data = resumen_golf, color = \"red\") +\n geom_linerange(data = resumen_golf, \n aes(ymin = p - 2 * sqrt(p * (1 - p) / n), \n ymax = p + 2 * sqrt(p * (1 - p) / n)),\n color = \"red\")\n\n\n\n\n\n\n\n\nEste modelo ajusta mejor, y puede ser usado para hacer comparaciones de probabilidad de éxito a diferentes distancias. Su defecto es que no es interpetable como nuestro modelo anterior (aprendemos poco sobre cómo funcionan los putts), y es considerablemente más difícil de ajustar.\nPuedes ver más de splines en McElreath (2020), y en Hastie, Tibshirani, y Friedman (2017). Puedes revisar también este caso de Stan que explica cómo utilizar splines de forma más general en Stan.\n\n\n\n\nGelman, Andrew, y Deborah Nolan. 2002. «A Probability Model for Golf Putting». Teaching Statistics 24 (septiembre): 93-95. https://doi.org/10.1111/1467-9639.00097.\n\n\nHastie, Trevor, Robert Tibshirani, y Jerome Friedman. 2017. The Elements of Statistical Learning. Springer Series en Statistics. Springer New York Inc. http://web.stanford.edu/~hastie/ElemStatLearn/.\n\n\nHolmes, Brian W. 1991. «Putting: How a golf ball and hole interact». American Journal of Physics 59 (2): 129-36. https://doi.org/10.1119/1.16592.\n\n\nMcElreath, R. 2020. Statistical Rethinking: A Bayesian Course with Examples in R and Stan. A Chapman & Hall libro. CRC Press. https://books.google.com.mx/books?id=Ie2vxQEACAAJ.\n\n\nPenner, Albert. 2002. «The physics of putting». Canadian Journal of Physics 80 (febrero): 83-96. https://doi.org/10.1139/p01-137.", "crumbs": [ "4  Componentes de modelación 1" ] @@ -314,7 +314,7 @@ "href": "05-dags.html#regla-del-producto-y-simulación", "title": "5  Modelos gráficos y causalidad", "section": "5.3 Regla del producto y simulación", - "text": "5.3 Regla del producto y simulación\nEl orden del modelo gráfico también nos indica cómo simular las variables de la gráfica. Como cada modelo gráfico nos da una factorización de la conjunta, podemos utlizar esta para simular datos una vez que conocemos o estimamos las relaciones de dependencia directa. Empezamos con las variables exógenas (que no tienen padres) y vamos simulando hacia adelante.\n\nEjemplo\nEn nuestro ejemplo simulamos primero \\(X\\) y \\(D\\). A partir de \\(X\\) podemos simular \\(X_1\\) y \\(S_2\\), y a partir de \\(D\\), junto con \\(S_1\\) y \\(S_2\\), podemos simular \\(G\\). En nuestro ejemplo tendríamos\n\nsimular_juego <- function(N){\n x <- runif(N)\n d <- sample(c(\"lluvioso\",\"soleado\"), N, replace = TRUE, prob = c(0.3,0.7))\n s1 <- rbinom(N, 5, x)\n s2 <- rbinom(N, 5, x)\n g <- ifelse(d==\"lluvioso\", s1+s2, s1)\n tibble(x, d, s1, s2, g)\n}\nsimular_juego(5)\n\n# A tibble: 5 × 5\n x d s1 s2 g\n <dbl> <chr> <int> <int> <int>\n1 0.924 soleado 5 5 5\n2 0.787 soleado 4 4 4\n3 0.848 lluvioso 5 3 8\n4 0.454 lluvioso 2 3 5\n5 0.369 soleado 2 1 2", + "text": "5.3 Regla del producto y simulación\nEl orden del modelo gráfico también nos indica cómo simular las variables de la gráfica. Como cada modelo gráfico nos da una factorización de la conjunta, podemos utlizar esta para simular datos una vez que conocemos o estimamos las relaciones de dependencia directa. Empezamos con las variables exógenas (que no tienen padres) y vamos simulando hacia adelante.\n\nEjemplo\nEn nuestro ejemplo simulamos primero \\(X\\) y \\(D\\). A partir de \\(X\\) podemos simular \\(X_1\\) y \\(S_2\\), y a partir de \\(D\\), junto con \\(S_1\\) y \\(S_2\\), podemos simular \\(G\\). En nuestro ejemplo tendríamos\n\nsimular_juego <- function(N){\n x <- runif(N)\n d <- sample(c(\"lluvioso\",\"soleado\"), N, replace = TRUE, prob = c(0.3,0.7))\n s1 <- rbinom(N, 5, x)\n s2 <- rbinom(N, 5, x)\n g <- ifelse(d==\"lluvioso\", s1+s2, s1)\n tibble(x, d, s1, s2, g)\n}\nsimular_juego(5)\n\n# A tibble: 5 × 5\n x d s1 s2 g\n <dbl> <chr> <int> <int> <int>\n1 0.751 soleado 5 2 5\n2 0.653 lluvioso 3 3 6\n3 0.0645 lluvioso 0 0 0\n4 0.0933 soleado 1 2 1\n5 0.258 soleado 2 1 2", "crumbs": [ "5  Modelos gráficos y causalidad" ] @@ -334,7 +334,7 @@ "href": "05-dags.html#bifurcaciones-o-causa-común", "title": "5  Modelos gráficos y causalidad", "section": "5.5 Bifurcaciones o causa común", - "text": "5.5 Bifurcaciones o causa común\nEn el siguiente ejemplo, llamamos a \\(Z\\) una causa que es común a \\(X\\) y \\(Y\\).\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X\n Y\n Z\n edge [minlen = 3]\n Z -> X\n Z -> Y\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEn este caso,\n\n\\(X\\) y \\(Y\\) tienen asociación\nSi condicionamos (o estratificamos) con \\(Z\\), entonces \\(X\\) y \\(Y\\) son condicionalmente independientes.\n\nEste tipo de estructura también se llama bifurcación, o decimos más tradicionalmente que \\(Z\\) es un confusor en esta gráfica. Variación en \\(Z\\) produce variación conjunta de \\(X\\) y \\(Y\\).\nPor ejemplo, podríamos encontrar que el uso de aspirina \\(X\\) está asociado a una mortalidad más alta \\(Y\\). Una causa común es enfermedad grave que produce dolor (\\(Z\\)). Sin embargo, si condicionamos a personas sanas, veríamos que no hay relación entre uso de aspirina y mortalidad, igualmente veríamos que entre las personas enfermas el uso de aspirina no les ayuda a vivir más tiempo.\nEn este caso, tenemos:\n\\[p(x, y, z) = p(z)p(x|z)p(y|z)\\] Y como el lado izquierdo es igual (en general) a \\(p(x,y|z)p(z)\\), obtenemos la independiencia condicional de \\(X\\) y \\(Y\\) dado \\(Z\\).\n\nEjemplo (simulación)\n\nrbern <- function(n, prob){\n rbinom(n, 1, prob = prob)\n} \nsimular_confusor <- function(n = 10){\n z <- rbern(n, p = 0.5) |> as.numeric()\n x <- rbern(n, p = z * 0.3 + (1 - z) * 0.8)\n y <- rbinom(n, 4, z * 0.9 + (1 - z) * 0.3)\n tibble(x, z, y)\n}\nsims_confusor <- simular_confusor(50000)\n\n\\(X\\) y \\(Y\\) están asociadas\n\nsims_confusor |> select(x, y) |> \n count(x, y) |> \n group_by(x) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") +\n labs(subtitle = \"Condicional de Y dada X\")\n\n\n\n\n\n\n\n\nLo cual lo vemos también si calculamos la correlación:\n\ncor(sims_confusor |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.428\ny -0.428 1.000\n\n\nSin embargo, si condicionamos a \\(Z\\), que puede tomar los valores 0 o 1, vemos que \\(X\\) y \\(Y\\) son independientes, o dicho de otra manera, la condicional de \\(Y\\) dada \\(Z\\) y \\(X\\) sólo depende de \\(Z\\):\n\nsims_confusor |> \n count(x, y, z) |> \n group_by(x, z) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, z, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") + facet_wrap(~ z) +\n labs(subtitle = \"Condicional de Y dada X y Z\")\n\n\n\n\n\n\n\n\nUna consecuencia es por ejemplo que la correlación debe ser cero:\n\ncor(sims_confusor |> filter(z == 1) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 0.002\ny 0.002 1.000\n\ncor(sims_confusor |> filter(z == 0) |> select(x,y)) |> round(3)\n\n x y\nx 1.00 -0.01\ny -0.01 1.00\n\n\nUn ejemplo con variables continuas podría ser como sigue:\n\nsimular_bifurcacion <- function(n = 10){\n z <- rbern(n, p = 0.5)\n x <- rnorm(n, 100 + 20 * z, 15)\n y <- rnorm(n, 100 + 30 * z, 20)\n tibble(x, z, y)\n}\nsims_bifurcacion <- simular_bifurcacion(5000)\n\n\\(X\\) y \\(Y\\) son dependientes (por ejemplo si vemos la media condicional de \\(Y\\) dado \\(X\\):\n\nggplot(sims_bifurcacion, aes(x = x, y = y, colour = z)) + \n geom_point(alpha = 0.2) +\n geom_smooth(span = 1, se = FALSE)\n\n\n\n\n\n\n\n\nSi condicionamos a \\(Z\\), no hay dependencia entre \\(X\\) y \\(Y\\)\n\nggplot(sims_bifurcacion, aes(x = x, y = y, colour = z, group = z)) + \n geom_point(alpha = 0.2) +\n geom_smooth(span = 2)\n\n\n\n\n\n\n\n\n\n\nEjemplo: matrimonio y divorcio\nEn este ejemplo de McElreath (2020), se muestra que regiones de Estados Unidos con tasas más altas de matrimonio también tienen tasas más altas de divorcio.\n\ndata(WaffleDivorce)\nWaffleDivorce |> \n ggplot(aes(x = Marriage, y = Divorce)) +\n geom_point() +\n geom_smooth(method = \"lm\")\n\n`geom_smooth()` using formula = 'y ~ x'\n\n\n\n\n\n\n\n\n\nAunque esta es una correlación clara, lo que nos interesa en este caso el efecto causal \\(M\\to D\\). Es importante notar que hay considerable variabilidad de la edad promedio al casarse a lo largo de los estados:\n\nWaffleDivorce |> \n ggplot(aes(sample = MedianAgeMarriage)) +\n geom_qq() +\n geom_qq_line()\n\n\n\n\n\n\n\n\nPara el modelo causal, tenemos que considerar las siguientes afirmaciones que no son muy difíciles de justificar:\n\nLa edad promedio al casarse de cada estado es un factor que influye en la tasa de divorcio (menor edad a casarse implica mayores tasas de divorcio, pues las parejas tienen más tiempo para divorciarse, porque la gente cambia más cuando es joven).\nAdicionalmente, si la gente tiende a casarse más joven, en cualquier momento hay más gente con probabilidad de casarse, por lo que esperaríamos que la edad al casarse también influye en la tasa de matrimonio.\n\nEsto implica que tenemos que considerar una causa común de la edad al casarse en nuestro diagrama causal:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n M\n D\n Edad\n edge [minlen = 3]\n Edad -> M\n Edad -> D\n M -> D\n{rank=same; M; D;}\n\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nPor la discusión de arriba, es claro que es necesario considerar la edad al casarse si queremos estimar el efecto de tasa de matrimonio en la tasa de divorcio. Es posible que la correlación entre estas dos tasas puede ser explicada solamente por la edad al casarse, y que en realidad al flecha \\(M\\to D\\) sea muy débil o inexistente.\nYa que tenemos este modelo causal básico, tendríamos que proponer un proceso generador, proponer un modelo estadístico, y probar nuestra estimación. Este paso nos lo saltaremos (ver sección anterior), aunque sigue siendo necesario.\nPor el momento recordemos que si condicionamos (se dice también estratificar) por edad al casarse, y no vemos relación condicional entre las dos tasas, la relación que vimos en los datos es factible que haya aparecido por la causa común que induce correlación. Una manera en que estratificamos o condicionamos a una variable continua en un modelo lineal, como sigue:\n\\[D_i\\sim N(\\mu_i, \\sigma)\\] donde \\[\\mu_i = \\alpha + \\beta_M M_i + \\beta_E Edad_i\\] ¿De qué manera estamos estratificando por edad en este ejemplo? Obsérvese que para cada Edad que fijemos, la relación entre \\(M\\) y \\(D\\) es:\n\\[\\mu_i = (\\alpha + \\beta_E Edad) + \\beta_M M_i \\] Cada valor de \\(E\\) produce una relación diferente entre \\(M\\) y \\(D\\) (en este caso particular, una recta diferente con distinta altura).\nAhora tenemos que poner iniciales para terminar nuestro modelo estadístico. En este punto poner iniciales informadas para estos coeficientes puede ser complicado (depende de cuánta demografía sabemos). Podemos usar un enfoque más simple, considerando las variables estandarizadas. De esta forma podemos poner iniciales más estándar. Utilizaremos\n\nescalar <- function(x){\n (x - mean(x))/sd(x)\n}\nWaffleDivorce <- WaffleDivorce |> \n mutate(Marriage_est = escalar(Marriage), \n Divorce_est = escalar(Divorce), \n MedianAgeMarriage_est = escalar(MedianAgeMarriage))\ndatos_lista <- list(\n N = nrow(WaffleDivorce),\n d_est = WaffleDivorce$Divorce_est, \n m_est = WaffleDivorce$Marriage_est, \n edad_est = WaffleDivorce$MedianAgeMarriage_est)\n\n\nmod_mat_div <- cmdstan_model(\"./src/matrimonio-divorcio-1.stan\")\nprint(mod_mat_div)\n\ndata {\n int<lower=0> N;\n vector[N] d_est;\n vector[N] m_est;\n vector[N] edad_est;\n}\n\nparameters {\n real alpha;\n real beta_M;\n real beta_E;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] w_media;\n // determinístico dado parámetros\n w_media = alpha + beta_M * m_est + beta_E * edad_est;\n}\n\nmodel {\n // partes no determinísticas\n d_est ~ normal(w_media, sigma);\n alpha ~ normal(0, 1);\n beta_M ~ normal(0, 0.5);\n beta_E ~ normal(0, 0.5);\n sigma ~ normal(0, 1);\n}\n\ngenerated quantities {\n real dif;\n {\n //simulamos 50 estados\n int M = 50;\n array[M] real dif_sim;\n for(i in 1:M){\n real edad_sim_est = normal_rng(0, 1);\n // fijamos el valor de M en 0 y 1 para el modelo con do(M)\n real M_sim_0 = normal_rng(alpha * beta_M * 0 + beta_E * edad_sim_est, sigma);\n real M_sim_1 = normal_rng(alpha * beta_M * 1 + beta_E * edad_sim_est, sigma);\n dif_sim[i] = M_sim_1 - M_sim_0;\n }\n dif = mean(dif_sim);\n }\n\n}\n\n\n\nsims_mod <- mod_mat_div$sample(data = datos_lista, \n chains = 4, \n init = 0.1, step_size = 0.1,\n iter_warmup = 1000, \n iter_sampling = 1000,\n refresh = 0)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 finished in 0.1 seconds.\nChain 2 finished in 0.1 seconds.\nChain 3 finished in 0.1 seconds.\nChain 4 finished in 0.1 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.1 seconds.\nTotal execution time: 0.6 seconds.\n\n\n\nresumen <- sims_mod$summary(c(\"alpha\", \"beta_M\", \"beta_E\", \"sigma\"))\n\n\nresumen |> \n ggplot(aes(x = variable, y = mean, ymin = q5, ymax = q95)) +\n geom_hline(yintercept = 0, color = \"red\") +\n geom_point() +\n geom_linerange() +\n coord_flip()\n\n\n\n\n\n\n\n\nY el resultado que obtenemos es que no observamos un efecto considerable de las tasas de matrimonio en las tasas de divorcio, una vez que estratificamos por la causa común de edad de matrimonio. Este ejemplo es simple y podemos ver el efecto causal directo en un sólo coeficiente \\(\\beta_M\\), pero de todas formas haremos contrastes como hicimos en la parte anterior.\n\n\n5.5.1 Simulando intervenciones\nLa manera más directa de definir efecto causal, bajo nuestros supuestos causales, es a través de intervenciones (imaginarias o reales).\n\n\n\n\n\n\nNota\n\n\n\nEntendemos saber una causa como poder predecir correctamente las consecuencias de una intervención en el sistema generador de datos.\n\n\nEn nuestro caso, el diagrama de arriba muestra nuestro modelo causal. Si nosotros alteramos este proceso causal, interviniendo en la tasa de matrimonio, la distribución de matrimonio ya no depende de la Edad (pues está bajo nuestro control). Esto quiere decir que ahora consideramos el siguiente diagrama, en donde la nueva dependendencia del divorcio del matrimonio la escribiremos como \\(p(D|do(M))\\):\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n M\n D\n Edad\n edge [minlen = 3]\n Edad -> D\n M -> D\n{rank=same; M; D;}\n\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEs decir, borramos todas las flechas que caen en \\(M\\) (pues la estamos interveniendo al valor que queramos), y luego simulando \\(D\\).\nEn nuestro ejemplo (ve el código de Stan de arriba, la parte de generated quantities) simularemos los 50 estados bajo dos intervenciones: todos tienen la tasa promedio de matrimonio vs. los 50 estados con tasa de matrimonio un error estándar por encima de la tasa promedio. Repetimos esta comparación sobre todas las simulaciones de la posterior:\n\nsims_tbl <- sims_mod$draws(format = \"df\") |> \n select(dif) \nsims_tbl |> summarize(\n q5 = quantile(dif, 0.05),\n q95 = quantile(dif, 0.95)\n)\n\n# A tibble: 1 × 2\n q5 q95\n <dbl> <dbl>\n1 -0.282 0.277\n\n\n\nggplot(sims_tbl, aes(x = dif)) +\n geom_histogram(bins = 50) +\n geom_vline(xintercept = 0, color = \"red\")\n\n\n\n\n\n\n\n\nEn este caso, vemos que el resultado de la intervención no tienen una tendencia clara hacia incrementar o disminuir la tasa de divorcio, aunque existe variabilidad por la incertidumbre que tenemos acerca de las relaciones modeladas.\n\n\n\n\n\n\nTip\n\n\n\nLa relación que vimos entre matrimonio y divorcio en nuestro ejemplo es probablemente producida por la causa común Edad, y no necesariamente es causal.\n\n\nFinalmente, antes de terminar sería apropiado hacer chequeos predictivos posteriores, pero por el momento los omitiremos para avanzar en los otros tipos de estructuras básicas en los DAGs.", + "text": "5.5 Bifurcaciones o causa común\nEn el siguiente ejemplo, llamamos a \\(Z\\) una causa que es común a \\(X\\) y \\(Y\\).\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X\n Y\n Z\n edge [minlen = 3]\n Z -> X\n Z -> Y\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEn este caso,\n\n\\(X\\) y \\(Y\\) tienen asociación\nSi condicionamos (o estratificamos) con \\(Z\\), entonces \\(X\\) y \\(Y\\) son condicionalmente independientes.\n\nEste tipo de estructura también se llama bifurcación, o decimos más tradicionalmente que \\(Z\\) es un confusor en esta gráfica. Variación en \\(Z\\) produce variación conjunta de \\(X\\) y \\(Y\\).\nPor ejemplo, podríamos encontrar que el uso de aspirina \\(X\\) está asociado a una mortalidad más alta \\(Y\\). Una causa común es enfermedad grave que produce dolor (\\(Z\\)). Sin embargo, si condicionamos a personas sanas, veríamos que no hay relación entre uso de aspirina y mortalidad, igualmente veríamos que entre las personas enfermas el uso de aspirina no les ayuda a vivir más tiempo.\nEn este caso, tenemos:\n\\[p(x, y, z) = p(z)p(x|z)p(y|z)\\] Y como el lado izquierdo es igual (en general) a \\(p(x,y|z)p(z)\\), obtenemos la independiencia condicional de \\(X\\) y \\(Y\\) dado \\(Z\\).\n\nEjemplo (simulación)\n\nrbern <- function(n, prob){\n rbinom(n, 1, prob = prob)\n} \nsimular_confusor <- function(n = 10){\n z <- rbern(n, p = 0.5) |> as.numeric()\n x <- rbern(n, p = z * 0.3 + (1 - z) * 0.8)\n y <- rbinom(n, 4, z * 0.9 + (1 - z) * 0.3)\n tibble(x, z, y)\n}\nsims_confusor <- simular_confusor(50000)\n\n\\(X\\) y \\(Y\\) están asociadas\n\nsims_confusor |> select(x, y) |> \n count(x, y) |> \n group_by(x) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") +\n labs(subtitle = \"Condicional de Y dada X\")\n\n\n\n\n\n\n\n\nLo cual lo vemos también si calculamos la correlación:\n\ncor(sims_confusor |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.426\ny -0.426 1.000\n\n\nSin embargo, si condicionamos a \\(Z\\), que puede tomar los valores 0 o 1, vemos que \\(X\\) y \\(Y\\) son independientes, o dicho de otra manera, la condicional de \\(Y\\) dada \\(Z\\) y \\(X\\) sólo depende de \\(Z\\):\n\nsims_confusor |> \n count(x, y, z) |> \n group_by(x, z) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, z, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") + facet_wrap(~ z) +\n labs(subtitle = \"Condicional de Y dada X y Z\")\n\n\n\n\n\n\n\n\nUna consecuencia es por ejemplo que la correlación debe ser cero:\n\ncor(sims_confusor |> filter(z == 1) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.018\ny -0.018 1.000\n\ncor(sims_confusor |> filter(z == 0) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.009\ny -0.009 1.000\n\n\nUn ejemplo con variables continuas podría ser como sigue:\n\nsimular_bifurcacion <- function(n = 10){\n z <- rbern(n, p = 0.5)\n x <- rnorm(n, 100 + 20 * z, 15)\n y <- rnorm(n, 100 + 30 * z, 20)\n tibble(x, z, y)\n}\nsims_bifurcacion <- simular_bifurcacion(5000)\n\n\\(X\\) y \\(Y\\) son dependientes (por ejemplo si vemos la media condicional de \\(Y\\) dado \\(X\\):\n\nggplot(sims_bifurcacion, aes(x = x, y = y, colour = z)) + \n geom_point(alpha = 0.2) +\n geom_smooth(span = 1, se = FALSE)\n\n\n\n\n\n\n\n\nSi condicionamos a \\(Z\\), no hay dependencia entre \\(X\\) y \\(Y\\)\n\nggplot(sims_bifurcacion, aes(x = x, y = y, colour = z, group = z)) + \n geom_point(alpha = 0.2) +\n geom_smooth(span = 2)\n\n\n\n\n\n\n\n\n\n\nEjemplo: matrimonio y divorcio\nEn este ejemplo de McElreath (2020), se muestra que regiones de Estados Unidos con tasas más altas de matrimonio también tienen tasas más altas de divorcio.\n\ndata(WaffleDivorce)\nWaffleDivorce |> \n ggplot(aes(x = Marriage, y = Divorce)) +\n geom_point() +\n geom_smooth(method = \"lm\")\n\n`geom_smooth()` using formula = 'y ~ x'\n\n\n\n\n\n\n\n\n\nAunque esta es una correlación clara, lo que nos interesa en este caso el efecto causal \\(M\\to D\\). Es importante notar que hay considerable variabilidad de la edad promedio al casarse a lo largo de los estados:\n\nWaffleDivorce |> \n ggplot(aes(sample = MedianAgeMarriage)) +\n geom_qq() +\n geom_qq_line()\n\n\n\n\n\n\n\n\nPara el modelo causal, tenemos que considerar las siguientes afirmaciones que no son muy difíciles de justificar:\n\nLa edad promedio al casarse de cada estado es un factor que influye en la tasa de divorcio (menor edad a casarse implica mayores tasas de divorcio, pues las parejas tienen más tiempo para divorciarse, porque la gente cambia más cuando es joven).\nAdicionalmente, si la gente tiende a casarse más joven, en cualquier momento hay más gente con probabilidad de casarse, por lo que esperaríamos que la edad al casarse también influye en la tasa de matrimonio.\n\nEsto implica que tenemos que considerar una causa común de la edad al casarse en nuestro diagrama causal:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n M\n D\n Edad\n edge [minlen = 3]\n Edad -> M\n Edad -> D\n M -> D\n{rank=same; M; D;}\n\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nPor la discusión de arriba, es claro que es necesario considerar la edad al casarse si queremos estimar el efecto de tasa de matrimonio en la tasa de divorcio. Es posible que la correlación entre estas dos tasas puede ser explicada solamente por la edad al casarse, y que en realidad al flecha \\(M\\to D\\) sea muy débil o inexistente.\nYa que tenemos este modelo causal básico, tendríamos que proponer un proceso generador, proponer un modelo estadístico, y probar nuestra estimación. Este paso nos lo saltaremos (ver sección anterior), aunque sigue siendo necesario.\nPor el momento recordemos que si condicionamos (se dice también estratificar) por edad al casarse, y no vemos relación condicional entre las dos tasas, la relación que vimos en los datos es factible que haya aparecido por la causa común que induce correlación. Una manera en que estratificamos o condicionamos a una variable continua en un modelo lineal, como sigue:\n\\[D_i\\sim N(\\mu_i, \\sigma)\\] donde \\[\\mu_i = \\alpha + \\beta_M M_i + \\beta_E Edad_i\\] ¿De qué manera estamos estratificando por edad en este ejemplo? Obsérvese que para cada Edad que fijemos, la relación entre \\(M\\) y \\(D\\) es:\n\\[\\mu_i = (\\alpha + \\beta_E Edad) + \\beta_M M_i \\] Cada valor de \\(E\\) produce una relación diferente entre \\(M\\) y \\(D\\) (en este caso particular, una recta diferente con distinta altura).\nAhora tenemos que poner iniciales para terminar nuestro modelo estadístico. En este punto poner iniciales informadas para estos coeficientes puede ser complicado (depende de cuánta demografía sabemos). Podemos usar un enfoque más simple, considerando las variables estandarizadas. De esta forma podemos poner iniciales más estándar. Utilizaremos\n\nescalar <- function(x){\n (x - mean(x))/sd(x)\n}\nWaffleDivorce <- WaffleDivorce |> \n mutate(Marriage_est = escalar(Marriage), \n Divorce_est = escalar(Divorce), \n MedianAgeMarriage_est = escalar(MedianAgeMarriage))\ndatos_lista <- list(\n N = nrow(WaffleDivorce),\n d_est = WaffleDivorce$Divorce_est, \n m_est = WaffleDivorce$Marriage_est, \n edad_est = WaffleDivorce$MedianAgeMarriage_est)\n\n\nmod_mat_div <- cmdstan_model(\"./src/matrimonio-divorcio-1.stan\")\nprint(mod_mat_div)\n\ndata {\n int<lower=0> N;\n vector[N] d_est;\n vector[N] m_est;\n vector[N] edad_est;\n}\n\nparameters {\n real alpha;\n real beta_M;\n real beta_E;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] w_media;\n // determinístico dado parámetros\n w_media = alpha + beta_M * m_est + beta_E * edad_est;\n}\n\nmodel {\n // partes no determinísticas\n d_est ~ normal(w_media, sigma);\n alpha ~ normal(0, 1);\n beta_M ~ normal(0, 0.5);\n beta_E ~ normal(0, 0.5);\n sigma ~ normal(0, 1);\n}\n\ngenerated quantities {\n real dif;\n {\n //simulamos 50 estados\n int M = 50;\n array[M] real dif_sim;\n for(i in 1:M){\n real edad_sim_est = normal_rng(0, 1);\n // fijamos el valor de M en 0 y 1 para el modelo con do(M)\n real M_sim_0 = normal_rng(alpha * beta_M * 0 + beta_E * edad_sim_est, sigma);\n real M_sim_1 = normal_rng(alpha * beta_M * 1 + beta_E * edad_sim_est, sigma);\n dif_sim[i] = M_sim_1 - M_sim_0;\n }\n dif = mean(dif_sim);\n }\n\n}\n\n\n\nsims_mod <- mod_mat_div$sample(data = datos_lista, \n chains = 4, \n init = 0.1, step_size = 0.1,\n iter_warmup = 1000, \n iter_sampling = 1000,\n refresh = 0)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 finished in 0.1 seconds.\nChain 2 finished in 0.1 seconds.\nChain 3 finished in 0.1 seconds.\nChain 4 finished in 0.1 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.1 seconds.\nTotal execution time: 0.6 seconds.\n\n\n\nresumen <- sims_mod$summary(c(\"alpha\", \"beta_M\", \"beta_E\", \"sigma\"))\n\n\nresumen |> \n ggplot(aes(x = variable, y = mean, ymin = q5, ymax = q95)) +\n geom_hline(yintercept = 0, color = \"red\") +\n geom_point() +\n geom_linerange() +\n coord_flip()\n\n\n\n\n\n\n\n\nY el resultado que obtenemos es que no observamos un efecto considerable de las tasas de matrimonio en las tasas de divorcio, una vez que estratificamos por la causa común de edad de matrimonio. Este ejemplo es simple y podemos ver el efecto causal directo en un sólo coeficiente \\(\\beta_M\\), pero de todas formas haremos contrastes como hicimos en la parte anterior.\n\n\n5.5.1 Simulando intervenciones\nLa manera más directa de definir efecto causal, bajo nuestros supuestos causales, es a través de intervenciones (imaginarias o reales).\n\n\n\n\n\n\nNota\n\n\n\nEntendemos saber una causa como poder predecir correctamente las consecuencias de una intervención en el sistema generador de datos.\n\n\nEn nuestro caso, el diagrama de arriba muestra nuestro modelo causal. Si nosotros alteramos este proceso causal, interviniendo en la tasa de matrimonio, la distribución de matrimonio ya no depende de la Edad (pues está bajo nuestro control). Esto quiere decir que ahora consideramos el siguiente diagrama, en donde la nueva dependendencia del divorcio del matrimonio la escribiremos como \\(p(D|do(M))\\):\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n M\n D\n Edad\n edge [minlen = 3]\n Edad -> D\n M -> D\n{rank=same; M; D;}\n\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEs decir, borramos todas las flechas que caen en \\(M\\) (pues la estamos interveniendo al valor que queramos), y luego simulando \\(D\\).\nEn nuestro ejemplo (ve el código de Stan de arriba, la parte de generated quantities) simularemos los 50 estados bajo dos intervenciones: todos tienen la tasa promedio de matrimonio vs. los 50 estados con tasa de matrimonio un error estándar por encima de la tasa promedio. Repetimos esta comparación sobre todas las simulaciones de la posterior:\n\nsims_tbl <- sims_mod$draws(format = \"df\") |> \n select(dif) \nsims_tbl |> summarize(\n q5 = quantile(dif, 0.05),\n q95 = quantile(dif, 0.95)\n)\n\n# A tibble: 1 × 2\n q5 q95\n <dbl> <dbl>\n1 -0.280 0.269\n\n\n\nggplot(sims_tbl, aes(x = dif)) +\n geom_histogram(bins = 50) +\n geom_vline(xintercept = 0, color = \"red\")\n\n\n\n\n\n\n\n\nEn este caso, vemos que el resultado de la intervención no tienen una tendencia clara hacia incrementar o disminuir la tasa de divorcio, aunque existe variabilidad por la incertidumbre que tenemos acerca de las relaciones modeladas.\n\n\n\n\n\n\nTip\n\n\n\nLa relación que vimos entre matrimonio y divorcio en nuestro ejemplo es probablemente producida por la causa común Edad, y no necesariamente es causal.\n\n\nFinalmente, antes de terminar sería apropiado hacer chequeos predictivos posteriores, pero por el momento los omitiremos para avanzar en los otros tipos de estructuras básicas en los DAGs.", "crumbs": [ "5  Modelos gráficos y causalidad" ] @@ -344,7 +344,7 @@ "href": "05-dags.html#cadenas-o-mediación", "title": "5  Modelos gráficos y causalidad", "section": "5.6 Cadenas o mediación", - "text": "5.6 Cadenas o mediación\nEn este caso tenemos:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir=LR]\n node [shape=plaintext]\n X\n Y\n Z\n edge [minlen = 3]\n X -> Z\n Z -> Y\n}\n\", width = 150, height = 20)\n\n\n\n\n\n\nEn este caso,\n\nExiste asociación entre \\(X\\) y \\(Y\\), pero no existe relación directa entre ellas. Decimos que \\(Z\\) es un mediador del efecto de \\(X\\) sobre \\(Y\\).\nSi condicionamos a un valor de \\(Z\\), \\(X\\) y \\(Y\\) son condicionalmente independientes.\n\nPodemos pensar en \\(Z\\) como un mediador del efecto de \\(X\\) sobre \\(Y\\). Si no permitimos que \\(Z\\) varíe, entonces la información de \\(X\\) no fluye a \\(Y\\).\nPor ejemplo, si \\(X\\) tomar o no una medicina para el dolor de cabeza, \\(Z\\) es dolor de cabeza y \\(Y\\) es bienestar general, \\(X\\) y \\(Y\\) están relacionadas. Sin embargo, si condicionamos a un valor fijo de dolor de cabeza, no hay relación entre tomar la medicina y bienestar general.\nEn términos de factorización, podemos checar la independencia condicional: como \\(p(x,y,z) = p(x)p(z|x)p(y|z)\\), entonces\n\\[p(x, y | z) = p(x,y,z) / p(z) = (p(x)(z|x)) (p(y|z) / p(z))\\] y vemos que el lado izquierdo se factoriza en una parte que sólo involucra a \\(x\\) y \\(z\\) y otro factor que sólo tiene a \\(y\\) y \\(z\\): no hay términos que incluyan conjuntamente a \\(x\\), \\(y\\) y \\(z\\). Podemos de cualquier forma continuar notando\n\\[p(x)p(z|x)/p(z) = p(x,z)/p(z) = p(x | z)\\] de modo que\n\\[p(x, y | z) = p(x|z) p(y|z) \\]\nY mostramos un ejemplo simulado:\n\nrbern <- function(n, prob){\n rbinom(n, 1, prob = prob)\n} \nsimular_mediador <- function(n = 10){\n x <- rbern(n, p = 0.5) |> as.numeric()\n z <- rbern(n, p = x * 0.8 + (1 - x) * 0.3)\n y <- rbinom(n, 2, z * 0.7 + (1 - z) * 0.5)\n tibble(x, z, y)\n}\nsims_mediador <- simular_mediador(50000)\n\n\\(X\\) y \\(Y\\) son dependientes:\n\nsims_mediador |> select(x, y) |> \n count(x, y) |> \n group_by(x) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") +\n labs(subtitle = \"Condicional de Y dada X\")\n\n\n\n\n\n\n\n\nSin embargo, si condicionamos a \\(Z\\), que puede tomar los valores 0 o 1:\n\nsims_mediador |> \n count(x, y, z) |> \n group_by(x, z) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, z, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") + facet_wrap(~ z) +\n labs(subtitle = \"Condicional de Y dada X y Z\")\n\n\n\n\n\n\n\n\nY vemos que la condicional de \\(Y\\) dada \\(Z\\) y \\(X\\) sólo depende de \\(Z\\). Una consecuencia es por ejemplo que la correlación debe ser cero:\n\ncor(sims_mediador |> filter(z == 1) |> select(x,y)) |> round(3)\n\n x y\nx 1.00 -0.01\ny -0.01 1.00\n\ncor(sims_mediador |> filter(z == 0) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.006\ny -0.006 1.000\n\n\nPodemos también hacer un ejemplo continuo:\n\nsimular_mediador <- function(n = 10){\n x <- rnorm(n, 100, 10)\n prob <- 1 / (1 + exp(-(x - 100)/5))\n z <- rbern(n, p = prob)\n y <- rnorm(n, 100 + 30 * z, 15)\n tibble(x, z, y)\n}\nsims_mediador <- simular_mediador(2000)\n\n\\(X\\) y \\(Y\\) son dependientes (por ejemplo si vemos la media condicional de \\(Y\\) dado \\(X\\):\n\nggplot(sims_mediador, aes(x = x, y = y, colour = z)) + geom_point() +\n geom_smooth(span = 1, se = FALSE)\n\n`geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = \"cs\")'\n\n\nWarning: The following aesthetics were dropped during statistical transformation: colour\nℹ This can happen when ggplot fails to infer the correct grouping structure in\n the data.\nℹ Did you forget to specify a `group` aesthetic or to convert a numerical\n variable into a factor?\n\n\n\n\n\n\n\n\n\nSi condicionamos a \\(Z\\), no hay dependencia entre \\(X\\) y \\(Y\\)\n\nggplot(sims_mediador, aes(x = x, y = y, colour = z, group = z)) + \n geom_point() +\n geom_smooth(span = 2)\n\n`geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = \"cs\")'\n\n\n\n\n\n\n\n\n\nNótese que en este ejemplo sí hay un efecto causal de \\(X\\) sobre \\(Y\\), pero está mediado por otra variable \\(Z\\). Si condicionamos a \\(Z\\), no hay relación entre \\(X\\) y \\(Y\\). El análisis condicionado podría llevarnos a una conclusión errónea de que \\(X\\) no influye sobre \\(Y\\).\n\n\n\n\n\n\nTip\n\n\n\nNota que no existe una diferencia estadística entre una bifurcación y una cadena: en ambos casos, las variables \\(X\\) y \\(Y\\) están correlacionadas, y son independientes una vez que condicionamos o estratificamos por \\(Z\\). Sin embargo, su tratamiento en inferencia causal es muy diferente.\n\n\n\nSesgo post-tratamiento\nEn McElreath (2020) se discute que en algunos estudios experimentales, se estratifica por variables que son consecuencia del tratamiento. Esto induce sesgo post-tratamiento, lo cual puede llevar a equivocaciones en donde parece que el tratamiento no tiene efecto cuando sí lo tiene. Incluso bajo condiciones de experimento (donde el tratamiento es asignado al azar) estratificar por mediadores es una mala idea. Ver más en McElreath (2020), donde por ejemplo cita una fuente que en estudios experimentales de Ciencia Política, casi la mitad de ellos sufre de este tipo de sesgo por estratificación por mediadores.\n\n\nEjemplo: Burks\nEste ejemplo es de Pearl y Mackenzie (2018). En 1926 Burks recolectó datos sobre qué tanto podría esperarse que la inteligencia de padres se hereda a los hijos (medido según una prueba de IQ). Construyó un diagrama parecido al de abajo:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape = circle]\n U\n node [shape=plaintext]\n edge [minlen = 3]\n IntPadres -> NSE\n NSE -> IntHijos\n U -> NSE\n U -> IntHijos\n IntPadres -> IntHijos\n{rank = same; U}\n}\n\")\n\n\n\n\n\n\nComo el NSE es del hogar (una medida general de estatus social), se consideró en principio como una variable pre-tratamiento a la inteligencia de los niños por la que tradicionalmente se controlaba. Burks notó que hacer esto tenía no era apropiado, pues tiene como consecuencia cortar parte del efecto total de la inteligencia sobre el la inteligencia de los hijos. En otras palabras: la inteligencia de los padres hace más probable mejor NSE, y mejor NSE presenta mejores condiciones de desarrollo para sus hijos. Estatificar por esta variable bloquea este efecto.\nAdicionalmente, como veremos, condicionar a NSE abre un camino no causal entre Inteligencia de Padres e Hijos.", + "text": "5.6 Cadenas o mediación\nEn este caso tenemos:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir=LR]\n node [shape=plaintext]\n X\n Y\n Z\n edge [minlen = 3]\n X -> Z\n Z -> Y\n}\n\", width = 150, height = 20)\n\n\n\n\n\n\nEn este caso,\n\nExiste asociación entre \\(X\\) y \\(Y\\), pero no existe relación directa entre ellas. Decimos que \\(Z\\) es un mediador del efecto de \\(X\\) sobre \\(Y\\).\nSi condicionamos a un valor de \\(Z\\), \\(X\\) y \\(Y\\) son condicionalmente independientes.\n\nPodemos pensar en \\(Z\\) como un mediador del efecto de \\(X\\) sobre \\(Y\\). Si no permitimos que \\(Z\\) varíe, entonces la información de \\(X\\) no fluye a \\(Y\\).\nPor ejemplo, si \\(X\\) tomar o no una medicina para el dolor de cabeza, \\(Z\\) es dolor de cabeza y \\(Y\\) es bienestar general, \\(X\\) y \\(Y\\) están relacionadas. Sin embargo, si condicionamos a un valor fijo de dolor de cabeza, no hay relación entre tomar la medicina y bienestar general.\nEn términos de factorización, podemos checar la independencia condicional: como \\(p(x,y,z) = p(x)p(z|x)p(y|z)\\), entonces\n\\[p(x, y | z) = p(x,y,z) / p(z) = (p(x)(z|x)) (p(y|z) / p(z))\\] y vemos que el lado izquierdo se factoriza en una parte que sólo involucra a \\(x\\) y \\(z\\) y otro factor que sólo tiene a \\(y\\) y \\(z\\): no hay términos que incluyan conjuntamente a \\(x\\), \\(y\\) y \\(z\\). Podemos de cualquier forma continuar notando\n\\[p(x)p(z|x)/p(z) = p(x,z)/p(z) = p(x | z)\\] de modo que\n\\[p(x, y | z) = p(x|z) p(y|z) \\]\nY mostramos un ejemplo simulado:\n\nrbern <- function(n, prob){\n rbinom(n, 1, prob = prob)\n} \nsimular_mediador <- function(n = 10){\n x <- rbern(n, p = 0.5) |> as.numeric()\n z <- rbern(n, p = x * 0.8 + (1 - x) * 0.3)\n y <- rbinom(n, 2, z * 0.7 + (1 - z) * 0.5)\n tibble(x, z, y)\n}\nsims_mediador <- simular_mediador(50000)\n\n\\(X\\) y \\(Y\\) son dependientes:\n\nsims_mediador |> select(x, y) |> \n count(x, y) |> \n group_by(x) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") +\n labs(subtitle = \"Condicional de Y dada X\")\n\n\n\n\n\n\n\n\nSin embargo, si condicionamos a \\(Z\\), que puede tomar los valores 0 o 1:\n\nsims_mediador |> \n count(x, y, z) |> \n group_by(x, z) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, z, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") + facet_wrap(~ z) +\n labs(subtitle = \"Condicional de Y dada X y Z\")\n\n\n\n\n\n\n\n\nY vemos que la condicional de \\(Y\\) dada \\(Z\\) y \\(X\\) sólo depende de \\(Z\\). Una consecuencia es por ejemplo que la correlación debe ser cero:\n\ncor(sims_mediador |> filter(z == 1) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.001\ny -0.001 1.000\n\ncor(sims_mediador |> filter(z == 0) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 0.003\ny 0.003 1.000\n\n\nPodemos también hacer un ejemplo continuo:\n\nsimular_mediador <- function(n = 10){\n x <- rnorm(n, 100, 10)\n prob <- 1 / (1 + exp(-(x - 100)/5))\n z <- rbern(n, p = prob)\n y <- rnorm(n, 100 + 30 * z, 15)\n tibble(x, z, y)\n}\nsims_mediador <- simular_mediador(2000)\n\n\\(X\\) y \\(Y\\) son dependientes (por ejemplo si vemos la media condicional de \\(Y\\) dado \\(X\\):\n\nggplot(sims_mediador, aes(x = x, y = y, colour = z)) + geom_point() +\n geom_smooth(span = 1, se = FALSE)\n\n`geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = \"cs\")'\n\n\nWarning: The following aesthetics were dropped during statistical transformation: colour\nℹ This can happen when ggplot fails to infer the correct grouping structure in\n the data.\nℹ Did you forget to specify a `group` aesthetic or to convert a numerical\n variable into a factor?\n\n\n\n\n\n\n\n\n\nSi condicionamos a \\(Z\\), no hay dependencia entre \\(X\\) y \\(Y\\)\n\nggplot(sims_mediador, aes(x = x, y = y, colour = z, group = z)) + \n geom_point() +\n geom_smooth(span = 2)\n\n`geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = \"cs\")'\n\n\n\n\n\n\n\n\n\nNótese que en este ejemplo sí hay un efecto causal de \\(X\\) sobre \\(Y\\), pero está mediado por otra variable \\(Z\\). Si condicionamos a \\(Z\\), no hay relación entre \\(X\\) y \\(Y\\). El análisis condicionado podría llevarnos a una conclusión errónea de que \\(X\\) no influye sobre \\(Y\\).\n\n\n\n\n\n\nTip\n\n\n\nNota que no existe una diferencia estadística entre una bifurcación y una cadena: en ambos casos, las variables \\(X\\) y \\(Y\\) están correlacionadas, y son independientes una vez que condicionamos o estratificamos por \\(Z\\). Sin embargo, su tratamiento en inferencia causal es muy diferente.\n\n\n\nSesgo post-tratamiento\nEn McElreath (2020) se discute que en algunos estudios experimentales, se estratifica por variables que son consecuencia del tratamiento. Esto induce sesgo post-tratamiento, lo cual puede llevar a equivocaciones en donde parece que el tratamiento no tiene efecto cuando sí lo tiene. Incluso bajo condiciones de experimento (donde el tratamiento es asignado al azar) estratificar por mediadores es una mala idea. Ver más en McElreath (2020), donde por ejemplo cita una fuente que en estudios experimentales de Ciencia Política, casi la mitad de ellos sufre de este tipo de sesgo por estratificación por mediadores.\n\n\nEjemplo: Burks\nEste ejemplo es de Pearl y Mackenzie (2018). En 1926 Burks recolectó datos sobre qué tanto podría esperarse que la inteligencia de padres se hereda a los hijos (medido según una prueba de IQ). Construyó un diagrama parecido al de abajo:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape = circle]\n U\n node [shape=plaintext]\n edge [minlen = 3]\n IntPadres -> NSE\n NSE -> IntHijos\n U -> NSE\n U -> IntHijos\n IntPadres -> IntHijos\n{rank = same; U}\n}\n\")\n\n\n\n\n\n\nComo el NSE es del hogar (una medida general de estatus social), se consideró en principio como una variable pre-tratamiento a la inteligencia de los niños por la que tradicionalmente se controlaba. Burks notó que hacer esto tenía no era apropiado, pues tiene como consecuencia cortar parte del efecto total de la inteligencia sobre el la inteligencia de los hijos. En otras palabras: la inteligencia de los padres hace más probable mejor NSE, y mejor NSE presenta mejores condiciones de desarrollo para sus hijos. Estatificar por esta variable bloquea este efecto.\nAdicionalmente, como veremos, condicionar a NSE abre un camino no causal entre Inteligencia de Padres e Hijos.", "crumbs": [ "5  Modelos gráficos y causalidad" ] @@ -354,7 +354,7 @@ "href": "05-dags.html#colisionador-o-causas-alternativas", "title": "5  Modelos gráficos y causalidad", "section": "5.7 Colisionador o causas alternativas", - "text": "5.7 Colisionador o causas alternativas\nEn este caso, a \\(Z\\) también le llamamos un colisionador. Este es el caso que puede ser más difícil de entender en un principio. Consiste de la siguiente estructura:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X\n Y\n Z\n edge [minlen = 3]\n X -> Z\n Y -> Z\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\n\nEn este caso \\(X\\) y \\(Y\\) son independientes. Tanto \\(X\\) como \\(Y\\) influyen en \\(Z\\).\nSin embargo, si condicionamos a \\(Z\\) entonces \\(X\\) y \\(Y\\) están asociados.\n\nPor ejemplo, si observamos que el pasto está mojado, entonces saber que no llovió implica que probablemente se encendieron los aspersores.\nComo la conjunta se factoriza como:\n\\[p(x,y,z) = p(x)p(y)p(z|x,y)\\] Entonces integrando sobre \\(Z\\):\n\\[p(x,y) = \\int p(x,y,z)dz = p(x)p(y)\\int p(z|x,y)\\, dz\\] pero \\(p(z|x,y)\\) integra uno porque es una densidad, de forma que \\(x\\) y \\(y\\) son independientes.\nMostramos un ejemplo simulado:\n\nsimular_colisionador <- function(n = 10){\n x <- rbern(n, 0.5) \n y <- rbinom(n, 2, 0.7)\n z <- rbern(n, p = 0.1 + 0.7 * x * (y > 1)) \n tibble(x, z, y)\n}\nsims_colisionador <- simular_colisionador(50000)\n\n\\(X\\) y \\(Y\\) son independientes:\n\nsims_colisionador|> select(x, y) |> \n count(x, y) |> \n group_by(x) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") +\n labs(subtitle = \"Condicional de Y dada X\")\n\n\n\n\n\n\n\ncor(sims_colisionador |> select(x,y))\n\n x y\nx 1.00000000 0.00744376\ny 0.00744376 1.00000000\n\n\nSin embargo, si condicionamos a \\(Z\\), que puede tomar los valores 0 o 1:\n\nsims_colisionador |> \n count(x, y, z) |> \n group_by(x, z) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, z, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") + facet_wrap(~ z) +\n labs(subtitle = \"Condicional de Y dada X y Z\")\n\n\n\n\n\n\n\n\nY vemos que la condicional de \\(Y\\) dada \\(Z\\) y \\(X\\) depende de \\(X\\) y de \\(Z\\).\nLas correlaciones condicionales, por ejemplo, no son cero:\n\nprint(\"Dado Z = 0\")\n\n[1] \"Dado Z = 0\"\n\ncor(sims_colisionador |> filter(z == 0) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.277\ny -0.277 1.000\n\nprint(\"Dado Z = 1\")\n\n[1] \"Dado Z = 1\"\n\ncor(sims_colisionador |> filter(z == 1) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 0.376\ny 0.376 1.000\n\n\nOtro ejemplo con variables continuas:\n\nsimular_colisionador_2 <- function(n = 10){\n x <- rnorm(n, 100, 20) \n y <- rnorm(n, 100, 20)\n z <- rbern(n, p = 0.92 * ((x + y) > 220) + 0.05) \n tibble(x, z, y)\n}\nsims_colisionador <- simular_colisionador_2(1000)\n\n\\(X\\) y \\(Y\\) son independientes:\n\nggplot(sims_colisionador, aes(x = x, y = y)) + geom_point()\n\n\n\n\n\n\n\n\nSin embargo, si condicionamos a un valor de \\(Z\\), \\(X\\) y \\(Y\\) ya no son independientes:\n\nggplot(sims_colisionador, aes(x = x, y = y, group = z, colour = factor(z))) + \n geom_point() + geom_smooth(method = \"lm\", se = FALSE) \n\n`geom_smooth()` using formula = 'y ~ x'\n\n\n\n\n\n\n\n\n\nY vemos que condicional a \\(Z\\), \\(X\\) y \\(Y\\) están correlacionadas, aunque no hay relación causal entre \\(X\\) y \\(Y\\).\n\n5.7.1 Ejemplos de colisionadores\nExisten muchos ejemplos de colisionadores en análisis de datos. Algunos ejemplos se deben a sesgo de selección (puedes dibujar diagramas para cada uno de estos):\n\nPodemos observar correlaciones entre habilidades que en realidad son independientes si observamos muestras de estudiantes seleccionados por un examen de admisión (por ejemplo, para entrar es necesario tener alta habilidad atlética y/o alta habilidad académica).\nEntre los artículos científicos publicados (ver McElreath (2020)), aquellos que son más tomados por las noticias son los menos confiables. Esta correlación puede aparecer aunque no exista relación en proyectos científicos entre confiabilidad e interés de los medios, pues lo que se fondea o publica puede tener dos razones: ser trabajo muy confiable, o ser trabajo que “está de moda” o atrae la atención de los medios.\n\nPero también puede ser consecuencia de condicionar a variables endógenos (que resultan ser colisionadores), y ocurren como parte del procesamiento o construcción de modelos. Un ejemplo interesante de McElreath (2020) es el siguiente:\n\nNos interesa saber si la edad influye en la felicidad o bienestar de las personas.\nAlgún investigador puede pensar que es necesario controlar por sí las personas están casadas o no, por ejemplo, para “quitar” ese efecto o algo así.\nEsto puede ser mala idea si consideramos que un diagrama apropiado puede ser \\(F \\rightarrow Matrim \\leftarrow Edad\\), que se basa en las observaciones de que personas más felices generalmente tienen mayor posibilidad de casarse, y también conforme pasa el tiempo, hay más oportunidades para casarse.\nEsto induce una correlación no causal entre edad y felicidad dentro de los grupos de casados y no casados, y puede llevar a conclusiones incorrectas.", + "text": "5.7 Colisionador o causas alternativas\nEn este caso, a \\(Z\\) también le llamamos un colisionador. Este es el caso que puede ser más difícil de entender en un principio. Consiste de la siguiente estructura:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X\n Y\n Z\n edge [minlen = 3]\n X -> Z\n Y -> Z\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\n\nEn este caso \\(X\\) y \\(Y\\) son independientes. Tanto \\(X\\) como \\(Y\\) influyen en \\(Z\\).\nSin embargo, si condicionamos a \\(Z\\) entonces \\(X\\) y \\(Y\\) están asociados.\n\nPor ejemplo, si observamos que el pasto está mojado, entonces saber que no llovió implica que probablemente se encendieron los aspersores.\nComo la conjunta se factoriza como:\n\\[p(x,y,z) = p(x)p(y)p(z|x,y)\\] Entonces integrando sobre \\(Z\\):\n\\[p(x,y) = \\int p(x,y,z)dz = p(x)p(y)\\int p(z|x,y)\\, dz\\] pero \\(p(z|x,y)\\) integra uno porque es una densidad, de forma que \\(x\\) y \\(y\\) son independientes.\nMostramos un ejemplo simulado:\n\nsimular_colisionador <- function(n = 10){\n x <- rbern(n, 0.5) \n y <- rbinom(n, 2, 0.7)\n z <- rbern(n, p = 0.1 + 0.7 * x * (y > 1)) \n tibble(x, z, y)\n}\nsims_colisionador <- simular_colisionador(50000)\n\n\\(X\\) y \\(Y\\) son independientes:\n\nsims_colisionador|> select(x, y) |> \n count(x, y) |> \n group_by(x) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") +\n labs(subtitle = \"Condicional de Y dada X\")\n\n\n\n\n\n\n\ncor(sims_colisionador |> select(x,y))\n\n x y\nx 1.000000000 -0.003586331\ny -0.003586331 1.000000000\n\n\nSin embargo, si condicionamos a \\(Z\\), que puede tomar los valores 0 o 1:\n\nsims_colisionador |> \n count(x, y, z) |> \n group_by(x, z) |> \n mutate(p_cond = n / sum(n)) |>\n select(x, y, z, p_cond) |> \nggplot(aes(x = y, y = p_cond, fill = factor(x))) +\n geom_col(position = \"dodge\") + facet_wrap(~ z) +\n labs(subtitle = \"Condicional de Y dada X y Z\")\n\n\n\n\n\n\n\n\nY vemos que la condicional de \\(Y\\) dada \\(Z\\) y \\(X\\) depende de \\(X\\) y de \\(Z\\).\nLas correlaciones condicionales, por ejemplo, no son cero:\n\nprint(\"Dado Z = 0\")\n\n[1] \"Dado Z = 0\"\n\ncor(sims_colisionador |> filter(z == 0) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 -0.283\ny -0.283 1.000\n\nprint(\"Dado Z = 1\")\n\n[1] \"Dado Z = 1\"\n\ncor(sims_colisionador |> filter(z == 1) |> select(x,y)) |> round(3)\n\n x y\nx 1.000 0.354\ny 0.354 1.000\n\n\nOtro ejemplo con variables continuas:\n\nsimular_colisionador_2 <- function(n = 10){\n x <- rnorm(n, 100, 20) \n y <- rnorm(n, 100, 20)\n z <- rbern(n, p = 0.92 * ((x + y) > 220) + 0.05) \n tibble(x, z, y)\n}\nsims_colisionador <- simular_colisionador_2(1000)\n\n\\(X\\) y \\(Y\\) son independientes:\n\nggplot(sims_colisionador, aes(x = x, y = y)) + geom_point()\n\n\n\n\n\n\n\n\nSin embargo, si condicionamos a un valor de \\(Z\\), \\(X\\) y \\(Y\\) ya no son independientes:\n\nggplot(sims_colisionador, aes(x = x, y = y, group = z, colour = factor(z))) + \n geom_point() + geom_smooth(method = \"lm\", se = FALSE) \n\n`geom_smooth()` using formula = 'y ~ x'\n\n\n\n\n\n\n\n\n\nY vemos que condicional a \\(Z\\), \\(X\\) y \\(Y\\) están correlacionadas, aunque no hay relación causal entre \\(X\\) y \\(Y\\).\n\n5.7.1 Ejemplos de colisionadores\nExisten muchos ejemplos de colisionadores en análisis de datos. Algunos ejemplos se deben a sesgo de selección (puedes dibujar diagramas para cada uno de estos):\n\nPodemos observar correlaciones entre habilidades que en realidad son independientes si observamos muestras de estudiantes seleccionados por un examen de admisión (por ejemplo, para entrar es necesario tener alta habilidad atlética y/o alta habilidad académica).\nEntre los artículos científicos publicados (ver McElreath (2020)), aquellos que son más tomados por las noticias son los menos confiables. Esta correlación puede aparecer aunque no exista relación en proyectos científicos entre confiabilidad e interés de los medios, pues lo que se fondea o publica puede tener dos razones: ser trabajo muy confiable, o ser trabajo que “está de moda” o atrae la atención de los medios.\n\nPero también puede ser consecuencia de condicionar a variables endógenos (que resultan ser colisionadores), y ocurren como parte del procesamiento o construcción de modelos. Un ejemplo interesante de McElreath (2020) es el siguiente:\n\nNos interesa saber si la edad influye en la felicidad o bienestar de las personas.\nAlgún investigador puede pensar que es necesario controlar por sí las personas están casadas o no, por ejemplo, para “quitar” ese efecto o algo así.\nEsto puede ser mala idea si consideramos que un diagrama apropiado puede ser \\(F \\rightarrow Matrim \\leftarrow Edad\\), que se basa en las observaciones de que personas más felices generalmente tienen mayor posibilidad de casarse, y también conforme pasa el tiempo, hay más oportunidades para casarse.\nEsto induce una correlación no causal entre edad y felicidad dentro de los grupos de casados y no casados, y puede llevar a conclusiones incorrectas.", "crumbs": [ "5  Modelos gráficos y causalidad" ] @@ -364,7 +364,7 @@ "href": "05-dags.html#razonamiento-de-descendientes", "title": "5  Modelos gráficos y causalidad", "section": "5.8 Razonamiento de descendientes", - "text": "5.8 Razonamiento de descendientes\nCondicionar a un descendiente puede entenderse como “condicionar parcialmente” o “débilmente” a los padres de ese descendiente.\nPor ejemplo, condicionar a un colisionador también produce dependencias condicionales:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X\n Y\n Z\n A\n edge [minlen = 3]\n X -> Z\n Y -> Z\n Z -> A\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEn este caso,\n\n\\(X\\) y \\(Y\\) son independientes\n\\(X\\) y \\(Y\\) son dependientes si condicionamos a \\(A\\).\n\nDependiendo de la naturaleza de la asociación entre el colisionador \\(Z\\) y su descendiente \\(A\\), esta dependencia puede ser más fuerte o más débil.\nPor ejemplo, en nuestro ejemplo donde el pasto mojado es un colisionador entre cuánta agua dieron los aspersores y cuánta lluvia cayó, un descendiente del pasto mojado es el estado de las plantas del jardín. Aunque los aspersores trabajan independientemente de la lluvia, si observamos que las plantas se secaron entonces lluvia y aspersores están correlacionados: por ejemplo, si noto que los aspersores están descompuestos, entonces concluimos que no hubo lluvia.\n\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X [label = lluvia]\n Y [label = aspersores]\n Z [label = humedad]\n A [label = plantas]\n edge [minlen = 3]\n X -> Z\n Y -> Z\n Z -> A\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEjemplo\n\nsimular_desc <- function(n = 10){\n x <- rbern(n, 0.5) \n y <- rbinom(n, 2, 0.7)\n z <- rbern(n, p = 0.1 + 0.7 * x * (y > 1)) \n a <- rbern(n, p = 0.5 + 0.5 * z)\n tibble(x, z, y, a)\n}\nsims_colisionador <- simular_desc(50000)\n# No hay correlación\ncor(sims_colisionador$x, sims_colisionador$y)\n\n[1] -0.006745788\n\n\nSin embargo,\n\ncor(sims_colisionador |> filter(a ==0) |> select(x,y))\n\n x y\nx 1.0000000 -0.2801888\ny -0.2801888 1.0000000\n\n\n\ncor(sims_colisionador |> filter(a ==1) |> select(x,y))\n\n x y\nx 1.0000000 0.1012908\ny 0.1012908 1.0000000\n\n\n\n\n5.8.1 Ejemplo: dependencias de colisionador\nVerificamos que en nuestro modelo de Santa Clara, efectivamente nuestro modelo no implica ninguna dependencia no condicional entre sensibilidad de la prueba y prevalencia. Eso debería ser claro de la simulación, pero de todas formas lo checamos\n\nlibrary(cmdstanr)\nmod_sc <- cmdstan_model(\"./src/sclara.stan\")\nprint(mod_sc)\n\ndata {\n int<lower=0> N;\n int<lower=0> n;\n int<lower=0> kit_pos;\n int<lower=0> n_kit_pos;\n int<lower=0> kit_neg;\n int<lower=0> n_kit_neg;\n}\n\nparameters {\n real<lower=0, upper=1> theta; //seroprevalencia\n real<lower=0, upper=1> sens; //sensibilidad\n real<lower=0, upper=1> esp; //especificidad\n}\n\ntransformed parameters {\n real<lower=0, upper=1> prob_pos;\n\n prob_pos = theta * sens + (1 - theta) * (1 - esp);\n\n}\nmodel {\n // modelo de número de positivos\n n ~ binomial(N, prob_pos);\n // modelos para resultados del kit\n kit_pos ~ binomial(n_kit_pos, sens);\n kit_neg ~ binomial(n_kit_neg, esp);\n // iniciales para cantidades no medidas\n theta ~ beta(1.0, 10.0);\n sens ~ beta(2.0, 1.0);\n esp ~ beta(2.0, 1.0);\n}\n\n\nEn este caso, no pondremos información acerca de positivos en la prueba:\n\ndatos_lista <- list(N = 0, n = 0,\n kit_pos = 103, n_kit_pos = 122,\n kit_neg = 399, n_kit_neg = 401)\najuste <- mod_sc$sample(data = datos_lista, refresh = 1000, iter_sampling = 400)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 1 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 1 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 1 finished in 0.0 seconds.\nChain 2 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 2 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 2 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 2 finished in 0.0 seconds.\nChain 3 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 3 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 3 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 3 finished in 0.0 seconds.\nChain 4 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 4 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 4 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 4 finished in 0.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.0 seconds.\nTotal execution time: 0.5 seconds.\n\nsims <- ajuste$draws(c(\"theta\", \"sens\", \"esp\"), format = \"df\")\nresumen <- ajuste$summary(c(\"theta\"))\n\n\nggplot(sims, aes(x = theta, y = sens)) + geom_point() +\n scale_x_sqrt()\n\n\n\n\n\n\n\n\nNo vemos ninguna asocación entre estas dos variables.\nSin embargo, al condicionar al valor de Positivos, creamos una relación que no podemos interpretar como casual. En este caso particular supondremos prácticamente fija la sensibilidad para ver solamente lo que sucede en el colisionador de especificidad y número de positivos (la especificidad en este ejemplo es más crítica):\n\ndatos_lista <- list(N = 3300, n = 50,\n kit_pos = 1030000, n_kit_pos = 1220000, # números grandes para que esté practicamente\n# fija la sensibilidad\n kit_neg = 399, n_kit_neg = 401)\najuste <- mod_sc$sample(data = datos_lista, refresh = 1000, iter_sampling = 400)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 1 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 1 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 1 finished in 0.0 seconds.\nChain 2 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 2 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 2 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 2 finished in 0.0 seconds.\nChain 3 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 3 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 3 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 3 finished in 0.0 seconds.\nChain 4 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 4 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 4 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 4 finished in 0.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.0 seconds.\nTotal execution time: 0.5 seconds.\n\nsims <- ajuste$draws(c(\"theta\", \"sens\", \"esp\"), format = \"df\")\nresumen <- ajuste$summary(c(\"theta\"))\n\n\nggplot(sims, aes(x = theta, y = esp)) + geom_point() \n\n\n\n\n\n\n\n\nY vemos que condiconando al colisionador, obtenemos una relación fuerte entre prevalencia y especificidad de la prueba: necesitaríamos más datos de especificidad para obtener una estimación útil.\n\nLa razón de que la especificidad es más importante en este ejemplo es que la prevalencia es muy baja al momento del estudio, y los falsos positivos pueden introducir más error en la estimación\nTambién repetimos nótese que el análisis correcto de estos datos no se puede hacer con intervalos separados para cada cantidad, sino que debe examinarse la conjunta de estos parámetros.\n\n\nCon estas tres estructuras elementales podemos entender de manera abstracta la existencia o no de asociaciones entre nodos de cualquier gráfica dirigida.", + "text": "5.8 Razonamiento de descendientes\nCondicionar a un descendiente puede entenderse como “condicionar parcialmente” o “débilmente” a los padres de ese descendiente.\nPor ejemplo, condicionar a un colisionador también produce dependencias condicionales:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X\n Y\n Z\n A\n edge [minlen = 3]\n X -> Z\n Y -> Z\n Z -> A\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEn este caso,\n\n\\(X\\) y \\(Y\\) son independientes\n\\(X\\) y \\(Y\\) son dependientes si condicionamos a \\(A\\).\n\nDependiendo de la naturaleza de la asociación entre el colisionador \\(Z\\) y su descendiente \\(A\\), esta dependencia puede ser más fuerte o más débil.\nPor ejemplo, en nuestro ejemplo donde el pasto mojado es un colisionador entre cuánta agua dieron los aspersores y cuánta lluvia cayó, un descendiente del pasto mojado es el estado de las plantas del jardín. Aunque los aspersores trabajan independientemente de la lluvia, si observamos que las plantas se secaron entonces lluvia y aspersores están correlacionados: por ejemplo, si noto que los aspersores están descompuestos, entonces concluimos que no hubo lluvia.\n\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n X [label = lluvia]\n Y [label = aspersores]\n Z [label = humedad]\n A [label = plantas]\n edge [minlen = 3]\n X -> Z\n Y -> Z\n Z -> A\n}\n\", width = 200, height = 50)\n\n\n\n\n\n\nEjemplo\n\nsimular_desc <- function(n = 10){\n x <- rbern(n, 0.5) \n y <- rbinom(n, 2, 0.7)\n z <- rbern(n, p = 0.1 + 0.7 * x * (y > 1)) \n a <- rbern(n, p = 0.5 + 0.5 * z)\n tibble(x, z, y, a)\n}\nsims_colisionador <- simular_desc(50000)\n# No hay correlación\ncor(sims_colisionador$x, sims_colisionador$y)\n\n[1] 0.008227776\n\n\nSin embargo,\n\ncor(sims_colisionador |> filter(a ==0) |> select(x,y))\n\n x y\nx 1.0000000 -0.2670541\ny -0.2670541 1.0000000\n\n\n\ncor(sims_colisionador |> filter(a ==1) |> select(x,y))\n\n x y\nx 1.0000000 0.1148013\ny 0.1148013 1.0000000\n\n\n\n\n5.8.1 Ejemplo: dependencias de colisionador\nVerificamos que en nuestro modelo de Santa Clara, efectivamente nuestro modelo no implica ninguna dependencia no condicional entre sensibilidad de la prueba y prevalencia. Eso debería ser claro de la simulación, pero de todas formas lo checamos\n\nlibrary(cmdstanr)\nmod_sc <- cmdstan_model(\"./src/sclara.stan\")\nprint(mod_sc)\n\ndata {\n int<lower=0> N;\n int<lower=0> n;\n int<lower=0> kit_pos;\n int<lower=0> n_kit_pos;\n int<lower=0> kit_neg;\n int<lower=0> n_kit_neg;\n}\n\nparameters {\n real<lower=0, upper=1> theta; //seroprevalencia\n real<lower=0, upper=1> sens; //sensibilidad\n real<lower=0, upper=1> esp; //especificidad\n}\n\ntransformed parameters {\n real<lower=0, upper=1> prob_pos;\n\n prob_pos = theta * sens + (1 - theta) * (1 - esp);\n\n}\nmodel {\n // modelo de número de positivos\n n ~ binomial(N, prob_pos);\n // modelos para resultados del kit\n kit_pos ~ binomial(n_kit_pos, sens);\n kit_neg ~ binomial(n_kit_neg, esp);\n // iniciales para cantidades no medidas\n theta ~ beta(1.0, 10.0);\n sens ~ beta(2.0, 1.0);\n esp ~ beta(2.0, 1.0);\n}\n\n\nEn este caso, no pondremos información acerca de positivos en la prueba:\n\ndatos_lista <- list(N = 0, n = 0,\n kit_pos = 103, n_kit_pos = 122,\n kit_neg = 399, n_kit_neg = 401)\najuste <- mod_sc$sample(data = datos_lista, refresh = 1000, iter_sampling = 400)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 1 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 1 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 1 finished in 0.0 seconds.\nChain 2 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 2 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 2 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 2 finished in 0.0 seconds.\nChain 3 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 3 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 3 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 3 finished in 0.0 seconds.\nChain 4 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 4 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 4 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 4 finished in 0.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.0 seconds.\nTotal execution time: 0.5 seconds.\n\nsims <- ajuste$draws(c(\"theta\", \"sens\", \"esp\"), format = \"df\")\nresumen <- ajuste$summary(c(\"theta\"))\n\n\nggplot(sims, aes(x = theta, y = sens)) + geom_point() +\n scale_x_sqrt()\n\n\n\n\n\n\n\n\nNo vemos ninguna asocación entre estas dos variables.\nSin embargo, al condicionar al valor de Positivos, creamos una relación que no podemos interpretar como casual. En este caso particular supondremos prácticamente fija la sensibilidad para ver solamente lo que sucede en el colisionador de especificidad y número de positivos (la especificidad en este ejemplo es más crítica):\n\ndatos_lista <- list(N = 3300, n = 50,\n kit_pos = 1030000, n_kit_pos = 1220000, # números grandes para que esté practicamente\n# fija la sensibilidad\n kit_neg = 399, n_kit_neg = 401)\najuste <- mod_sc$sample(data = datos_lista, refresh = 1000, iter_sampling = 400)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 1 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 1 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 1 finished in 0.0 seconds.\nChain 2 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 2 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 2 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 2 finished in 0.0 seconds.\nChain 3 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 3 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 3 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 3 finished in 0.0 seconds.\nChain 4 Iteration: 1 / 1400 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 1400 [ 71%] (Warmup) \nChain 4 Iteration: 1001 / 1400 [ 71%] (Sampling) \nChain 4 Iteration: 1400 / 1400 [100%] (Sampling) \nChain 4 finished in 0.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.0 seconds.\nTotal execution time: 0.5 seconds.\n\nsims <- ajuste$draws(c(\"theta\", \"sens\", \"esp\"), format = \"df\")\nresumen <- ajuste$summary(c(\"theta\"))\n\n\nggplot(sims, aes(x = theta, y = esp)) + geom_point() \n\n\n\n\n\n\n\n\nY vemos que condiconando al colisionador, obtenemos una relación fuerte entre prevalencia y especificidad de la prueba: necesitaríamos más datos de especificidad para obtener una estimación útil.\n\nLa razón de que la especificidad es más importante en este ejemplo es que la prevalencia es muy baja al momento del estudio, y los falsos positivos pueden introducir más error en la estimación\nTambién repetimos nótese que el análisis correcto de estos datos no se puede hacer con intervalos separados para cada cantidad, sino que debe examinarse la conjunta de estos parámetros.\n\n\nCon estas tres estructuras elementales podemos entender de manera abstracta la existencia o no de asociaciones entre nodos de cualquier gráfica dirigida.", "crumbs": [ "5  Modelos gráficos y causalidad" ] @@ -444,7 +444,7 @@ "href": "06-calculo-do.html#bloqueando-puertas-traseras", "title": "6  Identificación y cálculo-do", "section": "6.5 Bloqueando puertas traseras", - "text": "6.5 Bloqueando puertas traseras\nEn las partes anteriores vimos que estratificando por los padres de la variable de tratamiento \\(X\\) podemos construir un estimador del efecto de \\(X\\) sobre otra variable \\(Y\\), pasando de una distribución observacional a una conceptualmente experimental (dado que los supuestos causales sean aproximadamente correctos).\nSin embargo, esta aplicación de la fórmula de ajuste no funciona si existen padres que no fueron observados, y por tanto no podemos estratificar por ellos. El siguiente método (ajuste por “puerta trasera”) nos da una generalización que podemos usar dado ciertos tipos de estructura en nuestro modelo causal (veremos también por ejemplo, que a veces podemos usar menos variables que padres de la variable de interés). Nótese que una vez más, este criterio sólo depende de la gráfica causal \\(G\\) asociada a nuestro modelo, y no los modelos locales que utilizemos para modelar la condicional de cada nodo.\n\n\n\n\n\n\nAjuste de puerta trasera (Pearl)\n\n\n\nSi tenemos dos variables \\(T\\) y \\(Y\\) en una gráfica \\(G\\), un conjunto \\(Z\\) de variables satisface el criterio de puerta trasera relativo a \\(T\\) y \\(Y\\) cuando \\(Z\\) bloquea cualquier camino entre \\(T\\) y \\(Y\\) que tenga una arista que incida en \\(T\\), y ninguna variable de \\(Z\\) es descendiente de \\(T\\).\nEn tal caso, podemos utilizar la fórmula de ajuste, pero en lugar de estratificar por los padres de \\(T\\), estratificamos por las variables en \\(Z\\)\n\n\nLa idea es:\n\nQueremos bloquear todos los caminos no causales entre \\(T\\) y \\(Y\\).\nQueremos no perturbar todos los caminos dirigidos de \\(T\\) a \\(Y\\) (caminos causales).\nNo queremos activar caminos no causales entre \\(T\\) y \\(Y\\) al condicionar.\n\nCumplimos 1 al estratificar por variables que bloquean los caminos que son causas de \\(T\\), pues estos caminos no son causales y distorsionan la relación entre \\(T\\) y \\(Y\\). Al mismo tiempo, no bloqueamos caminos causales porque ningúna variable de \\(Z\\) es descendiente de \\(T\\), de modo que se satisface el criterio 2 (todos los caminos causales comienzan con \\(T\\to\\)). Finalmente, al excluir descendientes de \\(T\\) también implica que no condicionamos a colisionadores del tipo \\(T\\to \\cdots \\to Z_1\\gets Y\\), pues esto activa un camino no causal entre \\(T\\) y \\(Y\\) (se cumple 3).\n\nEjemplo (Pearl)\nConsideramos primero este ejemplo simple, donde queremos evaluar la efectividad de un tratamiento en cierta enfermedad. Los datos que tenemos disponibles son si una persona recibió o no un tratamiento, y si se recuperó o no. No se registró el nivel socioeconómico, pero sabemos que el tratamiento es caro, de forma que fue accedido más por gente de NSE más alto. También que sabemos que para este tipo de tratamiento, el peso de la persona es un factor importante. Nuestros supuestos están en la siguiente gráfica:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir = LR]\n node [shape=plaintext]\n Trata\n Res\n node [shape = circle]\n NSE\n Peso\n U\n edge [minlen = 3]\n NSE -> Peso\n NSE -> Trata\n Trata -> Res\n Peso -> Res\n U -> NSE\n U -> Peso\n}\n\")\n\n\n\n\n\n\nObservamos que no podemos directamente usar la fórmula de ajuste pues NSE no es una variable observada.\nEn esta circunstancia no podríamos identificar el efecto causal, pues existen un caminos abiertos no causales. Quizá el tratamiento no es muy efectivo, y parece ser bueno pues fue aplicado a personas con menor peso que las que no recibieron el tratamiento, a través del efecto de NSE. Sin embargo, supón que tuviéramos disponible la variable Peso:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir = LR]\n node [shape=plaintext]\n Trata\n Res\n Peso\n node [shape = circle]\n NSE\n U\n edge [minlen = 3]\n NSE -> Peso\n NSE -> Trata\n Trata -> Res\n Peso -> Res\n U -> NSE\n U -> Peso\n}\n\")\n\n\n\n\n\n\nEn este caso, todavía no podemos aplicar la fórmula original de ajuste pues no conocemos \\(NSE\\). Sin embargo, podemos bloquear los caminos no causales estratificando por Peso, y entonces podemos usar el criterio de puerta trasera para identificar el efecto del tratamiento, aún cuando no tengamos NSE.\n\n\nEjemplo\nPrimero consideramos un modelo generador:\n\ninv_logit <- function(x) 1 / (1 + exp(-x))\nsimular_bd <- function(n = 10){\n nse <- sample(c(0, 1), n, replace = TRUE)\n peso <- rnorm(n, 70 - 7 * nse, 12 + 2 * nse)\n trata <- rbinom(n, 1, 0.8 * nse + 0.2 * (1 - nse))\n p_trata <- inv_logit(1 * trata - 0.2 * (peso - 70))\n res <- rbinom(n, 1, p_trata)\n tibble(nse, peso, trata, res)\n}\ndatos_bd <- simular_bd(10000)\nhead(datos_bd)\n\n# A tibble: 6 × 4\n nse peso trata res\n <dbl> <dbl> <int> <int>\n1 1 71.9 0 0\n2 0 45.0 0 1\n3 0 73.5 0 0\n4 0 66.1 0 1\n5 1 49.4 1 1\n6 0 69.0 1 1\n\n\nVeamos qué sucede si cruzamos tratamiento con resultado (es una muestra grande y el error de estimación no es importante):\n\ndatos_bd |> \n count(trata, res) |>\n group_by(trata) |> \n mutate(p = n / sum(n)) |> \n filter(res == 1) |> \n ungroup() |> \n mutate(dif = p - lag(p))\n\n# A tibble: 2 × 5\n trata res n p dif\n <int> <int> <int> <dbl> <dbl>\n1 0 1 2678 0.533 NA \n2 1 1 3686 0.741 0.208\n\n\nSabemos que esta diferencia en respuesta puede estar confundida por un camino no causal. El verdadero efecto casual podemos calcularlo en nuestras simulaciones como sigue a partir de nuestro modelo (igualmente, usamos una muestra muy grande):\n\nsimular_efecto <- function(n = 10, peso = NULL){\n # cómo es la población\n nse <- sample(c(0, 1), n, replace = TRUE)\n if(is.null(peso)){\n peso <- rnorm(n, 70 - 7 * nse, 12 + 2 * nse)\n }\n # asignar al azar\n trata <- rbinom(n, 1, 0.5)\n p_trata <- inv_logit(1 * trata - 0.2 * (peso - 70))\n res <- rbinom(n, 1, p_trata)\n tibble(nse, peso, trata, res)\n}\nsims_efecto <- simular_efecto(20000)\nresumen <- sims_efecto |> \n count(trata, res) |>\n group_by(trata) |> \n mutate(p = n / sum(n)) |> \n filter(res == 1) |> \n ungroup() |> \n mutate(dif = p - lag(p))\ndif_real <- resumen$dif[2]\nresumen\n\n# A tibble: 2 × 5\n trata res n p dif\n <int> <int> <int> <dbl> <dbl>\n1 0 1 5929 0.590 NA \n2 1 1 6996 0.703 0.113\n\n\nLa estimación ingenua del cruce simple es mucho más grande que el verdadero efecto.\nPodemos también calcular el efecto para un peso particular:\n\nsims_efecto <- simular_efecto(20000, peso = 70)\nres_70 <- sims_efecto |> \n count(trata, res) |>\n group_by(trata) |> \n mutate(p = n / sum(n)) |> \n filter(res == 1) |> \n ungroup() |> \n mutate(dif = p - lag(p))\ndif_70 <- res_70$dif[2]\nres_70\n\n# A tibble: 2 × 5\n trata res n p dif\n <int> <int> <int> <dbl> <dbl>\n1 0 1 5002 0.500 NA \n2 1 1 7344 0.735 0.235\n\n\nSuponiendo nuestro diagrama, queremos estimar estratificando por peso. Podríamos usar un sólo modelo logístico, pero pueden ser más simples los cálculos si construimos nuestro modelo en stan. En este caso, podríamos calcular las diferencias para un peso particular, por ejemplo 70 kg (en lugar de modelar estaturas para producir una estimación de diferencia promedio).\nUsaremos una muestra de 2 mil personas:\n\nmod_trata <- cmdstan_model(\"./src/trata-backdoor.stan\")\nprint(mod_trata)\n\ndata {\n int<lower=0> N;\n vector[N] trata;\n array[N] int res;\n vector[N] peso;\n\n}\n\ntransformed data {\n real media_peso;\n\n // centrar\n media_peso = mean(peso);\n}\n\nparameters {\n real gamma_0;\n real gamma_1;\n real gamma_2;\n}\n\ntransformed parameters {\n vector[N] p_logit_res;\n\n p_logit_res = gamma_0 + gamma_1 * trata + gamma_2 * (peso - media_peso);\n\n}\n\nmodel {\n // modelo de resultado\n res ~ bernoulli_logit(p_logit_res);\n gamma_0 ~ normal(0, 2);\n gamma_1 ~ normal(0, 1);\n gamma_2 ~ normal(0, 0.2);\n\n\n}\ngenerated quantities {\n real dif_trata;\n real p_trata;\n real p_no_trata;\n\n real peso_sim = 70;\n {\n array[2000] int res_trata;\n array[2000] int res_no_trata;\n for(k in 1:2000){\n res_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 1 +\n gamma_2 * (peso_sim - media_peso)));\n res_no_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 0 +\n gamma_2 * (peso_sim - media_peso)));\n }\n dif_trata = mean(res_trata) - mean(res_no_trata);\n }\n}\n\n\n\nset.seed(915)\ndatos_bd <- simular_bd(2000)\ndatos_lista <- list(N = nrow(datos_bd),\n trata = datos_bd$trata, res = datos_bd$res,\n peso = datos_bd$peso)\najuste <- mod_trata$sample(data = datos_lista, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 1.9 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 2.0 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 1.9 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 2.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 1.9 seconds.\nTotal execution time: 8.2 seconds.\n\nsims <- ajuste$draws( format = \"df\")\nresumen <- ajuste$summary(c( \"dif_trata\"))\n\n\nresumen |> select(variable, mean, q5, q95)\n\n# A tibble: 1 × 4\n variable mean q5 q95\n <chr> <dbl> <dbl> <dbl>\n1 dif_trata 0.214 0.162 0.268\n\nsims |> select(dif_trata) |> \n ggplot(aes(x = dif_trata)) + geom_histogram() +\n geom_vline(xintercept = dif_70, colour = \"red\")\n\nWarning: Dropping 'draws_df' class as required metadata was removed.\n\n\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nY obtenemos una estimación correcta del efecto en 70 kg. Podríamos también calcular el efecto en distintos pesos (nuestro estimador es una curva), promediar estimando una distribución de pesos modelada, o tomar una distribución fija de pesos para modelar (cada una de estas estrategias tiene propósitos diferentes).\nSi queremos tener un efecto promedio, podemos modelar los pesos. Otra estrategia es promediar sobre los valores observados de la muestra. Nótese que esto ignora una parte de la incertidumbre proveniente de la muestra particular usada.\n\nmod_trata <- cmdstan_model(\"./src/trata-backdoor-promedio.stan\")\nprint(mod_trata)\n\ndata {\n int<lower=0> N;\n vector[N] trata;\n array[N] int res;\n vector[N] peso;\n\n}\n\ntransformed data {\n real media_peso;\n\n // centrar\n media_peso = mean(peso);\n}\n\nparameters {\n real gamma_0;\n real gamma_1;\n real gamma_2;\n}\n\ntransformed parameters {\n vector[N] p_logit_res;\n\n p_logit_res = gamma_0 + gamma_1 * trata + gamma_2 * (peso - media_peso);\n\n}\n\nmodel {\n // modelo de resultado\n res ~ bernoulli_logit(p_logit_res);\n gamma_0 ~ normal(0, 2);\n gamma_1 ~ normal(0, 1);\n gamma_2 ~ normal(0, 0.2);\n\n\n}\ngenerated quantities {\n real dif_trata;\n real p_trata;\n real p_no_trata;\n vector[N] probs;\n\n for(i in 1:N){\n probs[i] = 1.0 / N;\n }\n\n {\n array[2000] int res_trata;\n array[2000] int res_no_trata;\n for(k in 1:2000){\n real peso_sim = peso[categorical_rng(probs)];\n res_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 1 +\n gamma_2 * (peso_sim - media_peso)));\n res_no_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 0 +\n gamma_2 * (peso_sim - media_peso)));\n }\n p_trata = mean(res_trata);\n p_no_trata = mean(res_no_trata);\n }\n dif_trata = p_trata - p_no_trata;\n\n}\n\n\n\ndatos_lista <- list(N = nrow(datos_bd),\n trata = datos_bd$trata, res = datos_bd$res,\n peso = datos_bd$peso)\najuste <- mod_trata$sample(data = datos_lista, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 11.0 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 10.9 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 10.9 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 10.8 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 10.9 seconds.\nTotal execution time: 44.0 seconds.\n\nsims <- ajuste$draws(c(\"dif_trata\"), format = \"df\")\n\n\nresumen <- ajuste$summary(c( \"dif_trata\"))\nresumen |> select(variable, mean, q5, q95)\n\n# A tibble: 1 × 4\n variable mean q5 q95\n <chr> <dbl> <dbl> <dbl>\n1 dif_trata 0.111 0.0805 0.141\n\nsims |> select(dif_trata) |> \n ggplot(aes(x = dif_trata)) + geom_histogram() +\n geom_vline(xintercept = dif_real, colour = \"red\")\n\nWarning: Dropping 'draws_df' class as required metadata was removed.\n\n\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nY recuperamos nuevamente el efecto verdadero que mostramos arriba.", + "text": "6.5 Bloqueando puertas traseras\nEn las partes anteriores vimos que estratificando por los padres de la variable de tratamiento \\(X\\) podemos construir un estimador del efecto de \\(X\\) sobre otra variable \\(Y\\), pasando de una distribución observacional a una conceptualmente experimental (dado que los supuestos causales sean aproximadamente correctos).\nSin embargo, esta aplicación de la fórmula de ajuste no funciona si existen padres que no fueron observados, y por tanto no podemos estratificar por ellos. El siguiente método (ajuste por “puerta trasera”) nos da una generalización que podemos usar dado ciertos tipos de estructura en nuestro modelo causal (veremos también por ejemplo, que a veces podemos usar menos variables que padres de la variable de interés). Nótese que una vez más, este criterio sólo depende de la gráfica causal \\(G\\) asociada a nuestro modelo, y no los modelos locales que utilizemos para modelar la condicional de cada nodo.\n\n\n\n\n\n\nAjuste de puerta trasera (Pearl)\n\n\n\nSi tenemos dos variables \\(T\\) y \\(Y\\) en una gráfica \\(G\\), un conjunto \\(Z\\) de variables satisface el criterio de puerta trasera relativo a \\(T\\) y \\(Y\\) cuando \\(Z\\) bloquea cualquier camino entre \\(T\\) y \\(Y\\) que tenga una arista que incida en \\(T\\), y ninguna variable de \\(Z\\) es descendiente de \\(T\\).\nEn tal caso, podemos utilizar la fórmula de ajuste, pero en lugar de estratificar por los padres de \\(T\\), estratificamos por las variables en \\(Z\\)\n\n\nLa idea es:\n\nQueremos bloquear todos los caminos no causales entre \\(T\\) y \\(Y\\).\nQueremos no perturbar todos los caminos dirigidos de \\(T\\) a \\(Y\\) (caminos causales).\nNo queremos activar caminos no causales entre \\(T\\) y \\(Y\\) al condicionar.\n\nCumplimos 1 al estratificar por variables que bloquean los caminos que son causas de \\(T\\), pues estos caminos no son causales y distorsionan la relación entre \\(T\\) y \\(Y\\). Al mismo tiempo, no bloqueamos caminos causales porque ningúna variable de \\(Z\\) es descendiente de \\(T\\), de modo que se satisface el criterio 2 (todos los caminos causales comienzan con \\(T\\to\\)). Finalmente, al excluir descendientes de \\(T\\) también implica que no condicionamos a colisionadores del tipo \\(T\\to \\cdots \\to Z_1\\gets Y\\), pues esto activa un camino no causal entre \\(T\\) y \\(Y\\) (se cumple 3).\n\nEjemplo (Pearl)\nConsideramos primero este ejemplo simple, donde queremos evaluar la efectividad de un tratamiento en cierta enfermedad. Los datos que tenemos disponibles son si una persona recibió o no un tratamiento, y si se recuperó o no. No se registró el nivel socioeconómico, pero sabemos que el tratamiento es caro, de forma que fue accedido más por gente de NSE más alto. También que sabemos que para este tipo de tratamiento, el peso de la persona es un factor importante. Nuestros supuestos están en la siguiente gráfica:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir = LR]\n node [shape=plaintext]\n Trata\n Res\n node [shape = circle]\n NSE\n Peso\n U\n edge [minlen = 3]\n NSE -> Peso\n NSE -> Trata\n Trata -> Res\n Peso -> Res\n U -> NSE\n U -> Peso\n}\n\")\n\n\n\n\n\n\nObservamos que no podemos directamente usar la fórmula de ajuste pues NSE no es una variable observada.\nEn esta circunstancia no podríamos identificar el efecto causal, pues existen un caminos abiertos no causales. Quizá el tratamiento no es muy efectivo, y parece ser bueno pues fue aplicado a personas con menor peso que las que no recibieron el tratamiento, a través del efecto de NSE. Sin embargo, supón que tuviéramos disponible la variable Peso:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir = LR]\n node [shape=plaintext]\n Trata\n Res\n Peso\n node [shape = circle]\n NSE\n U\n edge [minlen = 3]\n NSE -> Peso\n NSE -> Trata\n Trata -> Res\n Peso -> Res\n U -> NSE\n U -> Peso\n}\n\")\n\n\n\n\n\n\nEn este caso, todavía no podemos aplicar la fórmula original de ajuste pues no conocemos \\(NSE\\). Sin embargo, podemos bloquear los caminos no causales estratificando por Peso, y entonces podemos usar el criterio de puerta trasera para identificar el efecto del tratamiento, aún cuando no tengamos NSE.\n\n\nEjemplo\nPrimero consideramos un modelo generador:\n\ninv_logit <- function(x) 1 / (1 + exp(-x))\nsimular_bd <- function(n = 10){\n nse <- sample(c(0, 1), n, replace = TRUE)\n peso <- rnorm(n, 70 - 7 * nse, 12 + 2 * nse)\n trata <- rbinom(n, 1, 0.8 * nse + 0.2 * (1 - nse))\n p_trata <- inv_logit(1 * trata - 0.2 * (peso - 70))\n res <- rbinom(n, 1, p_trata)\n tibble(nse, peso, trata, res)\n}\ndatos_bd <- simular_bd(10000)\nhead(datos_bd)\n\n# A tibble: 6 × 4\n nse peso trata res\n <dbl> <dbl> <int> <int>\n1 1 71.9 0 0\n2 0 45.0 0 1\n3 0 73.5 0 0\n4 0 66.1 0 1\n5 1 49.4 1 1\n6 0 69.0 1 1\n\n\nVeamos qué sucede si cruzamos tratamiento con resultado (es una muestra grande y el error de estimación no es importante):\n\ndatos_bd |> \n count(trata, res) |>\n group_by(trata) |> \n mutate(p = n / sum(n)) |> \n filter(res == 1) |> \n ungroup() |> \n mutate(dif = p - lag(p))\n\n# A tibble: 2 × 5\n trata res n p dif\n <int> <int> <int> <dbl> <dbl>\n1 0 1 2678 0.533 NA \n2 1 1 3686 0.741 0.208\n\n\nSabemos que esta diferencia en respuesta puede estar confundida por un camino no causal. El verdadero efecto casual podemos calcularlo en nuestras simulaciones como sigue a partir de nuestro modelo (igualmente, usamos una muestra muy grande):\n\nsimular_efecto <- function(n = 10, peso = NULL){\n # cómo es la población\n nse <- sample(c(0, 1), n, replace = TRUE)\n if(is.null(peso)){\n peso <- rnorm(n, 70 - 7 * nse, 12 + 2 * nse)\n }\n # asignar al azar\n trata <- rbinom(n, 1, 0.5)\n p_trata <- inv_logit(1 * trata - 0.2 * (peso - 70))\n res <- rbinom(n, 1, p_trata)\n tibble(nse, peso, trata, res)\n}\nsims_efecto <- simular_efecto(20000)\nresumen <- sims_efecto |> \n count(trata, res) |>\n group_by(trata) |> \n mutate(p = n / sum(n)) |> \n filter(res == 1) |> \n ungroup() |> \n mutate(dif = p - lag(p))\ndif_real <- resumen$dif[2]\nresumen\n\n# A tibble: 2 × 5\n trata res n p dif\n <int> <int> <int> <dbl> <dbl>\n1 0 1 5929 0.590 NA \n2 1 1 6996 0.703 0.113\n\n\nLa estimación ingenua del cruce simple es mucho más grande que el verdadero efecto.\nPodemos también calcular el efecto para un peso particular:\n\nsims_efecto <- simular_efecto(20000, peso = 70)\nres_70 <- sims_efecto |> \n count(trata, res) |>\n group_by(trata) |> \n mutate(p = n / sum(n)) |> \n filter(res == 1) |> \n ungroup() |> \n mutate(dif = p - lag(p))\ndif_70 <- res_70$dif[2]\nres_70\n\n# A tibble: 2 × 5\n trata res n p dif\n <int> <int> <int> <dbl> <dbl>\n1 0 1 5002 0.500 NA \n2 1 1 7344 0.735 0.235\n\n\nSuponiendo nuestro diagrama, queremos estimar estratificando por peso. Podríamos usar un sólo modelo logístico, pero pueden ser más simples los cálculos si construimos nuestro modelo en stan. En este caso, podríamos calcular las diferencias para un peso particular, por ejemplo 70 kg (en lugar de modelar estaturas para producir una estimación de diferencia promedio).\nUsaremos una muestra de 2 mil personas:\n\nmod_trata <- cmdstan_model(\"./src/trata-backdoor.stan\")\nprint(mod_trata)\n\ndata {\n int<lower=0> N;\n vector[N] trata;\n array[N] int res;\n vector[N] peso;\n\n}\n\ntransformed data {\n real media_peso;\n\n // centrar\n media_peso = mean(peso);\n}\n\nparameters {\n real gamma_0;\n real gamma_1;\n real gamma_2;\n}\n\ntransformed parameters {\n vector[N] p_logit_res;\n\n p_logit_res = gamma_0 + gamma_1 * trata + gamma_2 * (peso - media_peso);\n\n}\n\nmodel {\n // modelo de resultado\n res ~ bernoulli_logit(p_logit_res);\n gamma_0 ~ normal(0, 2);\n gamma_1 ~ normal(0, 1);\n gamma_2 ~ normal(0, 0.2);\n\n\n}\ngenerated quantities {\n real dif_trata;\n real p_trata;\n real p_no_trata;\n\n real peso_sim = 70;\n {\n array[2000] int res_trata;\n array[2000] int res_no_trata;\n for(k in 1:2000){\n res_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 1 +\n gamma_2 * (peso_sim - media_peso)));\n res_no_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 0 +\n gamma_2 * (peso_sim - media_peso)));\n }\n dif_trata = mean(res_trata) - mean(res_no_trata);\n }\n}\n\n\n\nset.seed(915)\ndatos_bd <- simular_bd(2000)\ndatos_lista <- list(N = nrow(datos_bd),\n trata = datos_bd$trata, res = datos_bd$res,\n peso = datos_bd$peso)\najuste <- mod_trata$sample(data = datos_lista, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 1.9 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 2.0 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 1.9 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 2.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 1.9 seconds.\nTotal execution time: 8.1 seconds.\n\nsims <- ajuste$draws( format = \"df\")\nresumen <- ajuste$summary(c( \"dif_trata\"))\n\n\nresumen |> select(variable, mean, q5, q95)\n\n# A tibble: 1 × 4\n variable mean q5 q95\n <chr> <dbl> <dbl> <dbl>\n1 dif_trata 0.214 0.162 0.268\n\nsims |> select(dif_trata) |> \n ggplot(aes(x = dif_trata)) + geom_histogram() +\n geom_vline(xintercept = dif_70, colour = \"red\")\n\nWarning: Dropping 'draws_df' class as required metadata was removed.\n\n\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nY obtenemos una estimación correcta del efecto en 70 kg. Podríamos también calcular el efecto en distintos pesos (nuestro estimador es una curva), promediar estimando una distribución de pesos modelada, o tomar una distribución fija de pesos para modelar (cada una de estas estrategias tiene propósitos diferentes).\nSi queremos tener un efecto promedio, podemos modelar los pesos. Otra estrategia es promediar sobre los valores observados de la muestra. Nótese que esto ignora una parte de la incertidumbre proveniente de la muestra particular usada.\n\nmod_trata <- cmdstan_model(\"./src/trata-backdoor-promedio.stan\")\nprint(mod_trata)\n\ndata {\n int<lower=0> N;\n vector[N] trata;\n array[N] int res;\n vector[N] peso;\n\n}\n\ntransformed data {\n real media_peso;\n\n // centrar\n media_peso = mean(peso);\n}\n\nparameters {\n real gamma_0;\n real gamma_1;\n real gamma_2;\n}\n\ntransformed parameters {\n vector[N] p_logit_res;\n\n p_logit_res = gamma_0 + gamma_1 * trata + gamma_2 * (peso - media_peso);\n\n}\n\nmodel {\n // modelo de resultado\n res ~ bernoulli_logit(p_logit_res);\n gamma_0 ~ normal(0, 2);\n gamma_1 ~ normal(0, 1);\n gamma_2 ~ normal(0, 0.2);\n\n\n}\ngenerated quantities {\n real dif_trata;\n real p_trata;\n real p_no_trata;\n vector[N] probs;\n\n for(i in 1:N){\n probs[i] = 1.0 / N;\n }\n\n {\n array[2000] int res_trata;\n array[2000] int res_no_trata;\n for(k in 1:2000){\n real peso_sim = peso[categorical_rng(probs)];\n res_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 1 +\n gamma_2 * (peso_sim - media_peso)));\n res_no_trata[k] = bernoulli_rng(\n inv_logit(gamma_0 + gamma_1 * 0 +\n gamma_2 * (peso_sim - media_peso)));\n }\n p_trata = mean(res_trata);\n p_no_trata = mean(res_no_trata);\n }\n dif_trata = p_trata - p_no_trata;\n\n}\n\n\n\ndatos_lista <- list(N = nrow(datos_bd),\n trata = datos_bd$trata, res = datos_bd$res,\n peso = datos_bd$peso)\najuste <- mod_trata$sample(data = datos_lista, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 11.0 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 10.9 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 10.9 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 10.8 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 10.9 seconds.\nTotal execution time: 43.9 seconds.\n\nsims <- ajuste$draws(c(\"dif_trata\"), format = \"df\")\n\n\nresumen <- ajuste$summary(c( \"dif_trata\"))\nresumen |> select(variable, mean, q5, q95)\n\n# A tibble: 1 × 4\n variable mean q5 q95\n <chr> <dbl> <dbl> <dbl>\n1 dif_trata 0.111 0.0805 0.141\n\nsims |> select(dif_trata) |> \n ggplot(aes(x = dif_trata)) + geom_histogram() +\n geom_vline(xintercept = dif_real, colour = \"red\")\n\nWarning: Dropping 'draws_df' class as required metadata was removed.\n\n\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nY recuperamos nuevamente el efecto verdadero que mostramos arriba.", "crumbs": [ "6  Identificación y cálculo-do" ] @@ -464,7 +464,7 @@ "href": "06-calculo-do.html#el-criterio-de-puerta-delantera", "title": "6  Identificación y cálculo-do", "section": "6.7 El criterio de puerta delantera", - "text": "6.7 El criterio de puerta delantera\nEn algunos casos, puede ser que no sea posible bloquear algún camino no causal con variables observadas. Un ejemplo clásico es el de la discusión acerca de la relación de fumar con cáncer de pulmón. Algunos estadísticos plantearon que los estudios de asociación entre fumar y cáncer de pulmón podrían tener efectos gravemente confundidos, por ejemplo, por aspectos genéticos que hacen a una persona propensa a fumar al mismo tiempo que aumenta su probabilidad de fumar:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n F\n C\n node [shape = circle]\n U\n edge [minlen = 3]\n U -> F\n U -> C\n F -> C\n{rank= same; C; F}\n}\n\")\n\n\n\n\n\n\nEn este caso, el efecto de fumar (\\(F\\)) sobre cáncer (\\(C\\)) no es identificable pues no podemos condicionar a la variable de Genotipo (\\(U\\)). Supongamos que tenemos una medida adicional, que es la cantidad de depósitos de alquitrán den los pulmones de los pacientes. Este es es afectado por \\(F\\), y a su vez, el alquitrán incrementa la probabilidad de cáncer:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n F\n C\n A\n node [shape = circle]\n U\n edge [minlen = 3]\n U -> F\n U -> C\n F -> A\n A -> C\n{rank= same; C; F; A}\n}\n\")\n\n\n\n\n\n\nLa idea es primero estimar el efecto de \\(F\\) sobre \\(A\\), y después estimar el efecto de \\(A\\) sobre \\(C\\). La “composición” de estos dos efectos, dado el diagrama, debe darnos el estimador correcto. Primero consideramos el efecto de \\(F\\) sobre \\(A\\), y tenemos que (regla 2)\n\\[p(a|do(f)) = p(a|f),\\] La igualdad se debe a que una vez que condicionamos a \\(F\\) no hay puertas traseras entre \\(F\\) y \\(A\\) (pues no condicionamos a \\(C\\)). Esta dependencia causal la podemos entonces estimar de los datos.\nEl efecto de \\(A\\) sobre \\(C\\) también es identificable, pues el camino no causal se bloquea cuando condicionamos a \\(F\\), de forma que por la fórmula de ajuste:\n\\[p(c|do(a)) = \\int p(c|a, f') p(f')\\, df'\\]\nAhora encadenamos estas dos ecuaciones:\n\\[p(c|do(f)) = \\int p(c|do(a))p(a|f)\\,da\\]\nque equivale en simulación a: dado un valor de \\(F\\), simulamos \\(A\\) con nuestro modelo ajustado con datos naturales. Ahora intervenimos \\(A\\) con el valor \\(a\\) que obtuvimos y simulamos \\(C\\). Sin embargo, para hacer este último paso con datos naturales, necesitamos usar el criterio de puerta trasera como explicamos arriba: simulamos entonces \\(f´\\) de \\(p(f)\\), y después simulamos \\(C\\) en función de \\(a\\) y \\(f´\\) (con una distribución construida a partir de datos).\nRequerimos en este caso construir y estimar la condicional \\(p(c|a, f)\\) basado en los datos.\nEn fórmula, en general, se escribe como:\n\n\n\n\n\n\nCriterio de fuerta delantera (Pearl)\n\n\n\nDecimos que un conjunto de variables \\(A\\) satisface el criterio de puerta delantera en relación a las variables \\(F\\) y \\(C\\) cuando:\n\n\\(A\\) intercepta todos las cadenas dirigidos de \\(F\\) a \\(C\\)\nNo hay ningún camino activo de puerta trasera de \\(F\\) a \\(A\\)\nTodos los caminos de puerta trasera de \\(A\\) a \\(C\\) están bloqueados por \\(F\\).\n\nSi \\(A\\) satisface el criterio de puerta delantera en relación a \\(F\\) y \\(C\\), entonces el efecto causal de \\(F\\) en \\(C\\) es identificable y está dado por la fórmula:\n\\[p(c|do(f)) = \\int \\left [ \\int p(c|a,f´)p(f´)\\,df´ \\right ] p(a|f)\\,da\\]\n\n\nTodas estas cantidades puede estimarse de los datos.\n\nEjemplo: proceso generador\nAntes de aplicar este nuevo procedimiento, describamos el proceso generador que utilizaremos:\n\n# simular distribución natural\nsimular_fd <- function(n = 10, efecto_a = 0.3){\n ## causa común\n u <- rnorm(n, 0, 1);\n # cantidad que fuma\n f <- exp(rnorm(n, 1 + 0.2 * u, 0.1))\n # acumulación de alquitrán\n a <- rnorm(n, 4 * f, 2)\n # probabilidad de cancer\n p_c <- inv_logit(-6 + efecto_a * a + 2 * u)\n c <- rbinom(n, 1, p_c)\n tibble(f, a, c, u)\n}\n# simular datos intervenidos (suponiendo que conocemos todo)\nsim_int_f <- function(n = 100, do_f = 0.3, efecto_a = 0.3){\n a <- rnorm(n, 4 * do_f, 2)\n u <- rnorm(n, 0, 1)\n p_c <- inv_logit(-6 + efecto_a * a + 2 * u)\n c <- rbinom(n, 1, p_c)\n tibble(do_f = do_f, media_c = mean(c))\n}\n\n\nset.seed(4481)\nsims_fd <- simular_fd(5000)\nsims_fd_1 <- simular_fd(10000)\nqplot(sims_fd$f, sims_fd$a)\n\nWarning: `qplot()` was deprecated in ggplot2 3.4.0.\n\n\n\n\n\n\n\n\n\n¿Cómo se ve la relación de fumador con cáncer? En esta gráfica mostramos también el valor de la variable no observada \\(U\\). Nótese que parte de la correlación positiva que existe es debido a esta variable \\(U\\).\n\nggplot(sims_fd, aes(x = f, y = c, colour = u)) + \n geom_jitter() + scale_colour_continuous(type = \"viridis\")\n\n\n\n\n\n\n\n\nAhora veamos cómo se ve el efecto de \\(F\\) sobre \\(C\\) y también cómo se ve el cruce de \\(F\\) y \\(C\\) en los datos naturales:\n\nsims_1 <- map_df(seq(1, 4, 0.5), ~ sim_int_f(100000, .x))\n\nsims_1 |> \n ggplot() + geom_line(aes(x = do_f, y = media_c)) +\n geom_smooth(data = sims_fd_1, aes(x = f, y = c), method = \"loess\", span = 0.3, se = FALSE, colour =\"red\") + xlab(\"Grado de tabaquismo\") +\n xlim(c(1,4))\n\n`geom_smooth()` using formula = 'y ~ x'\n\n\nWarning: Removed 376 rows containing non-finite values (`stat_smooth()`).\n\n\n\n\n\n\n\n\n\nEn efecto causal promedio de fumar, en cada nivel, sobre la incidencia de cáncer de pulmón, suponiendo nuestro proceso generador. Nótese que la relación no es tan fuerte como observamos en los datos naturales (en rojo). Esto se debe a que en los datos naturales, las personas existe una causa común entre no fumar y prevenir cáncer de pulmón.\n\n\nEjemplo: estimación con puerta delantera\nVeamos cómo sería la estimación si tuviéramos datos disponible, y si es que podemos recuperar el efecto correcto dados los datos observados y la técnica de puerta delantera.\nNótese que sólo necesitamos \\(p(c|a, f), p(a|f)\\) y \\(p(f)\\). Estos son modelos estadísticos con el que podemos identificar el efecto que nos interesa. Una vez que los estimemos, podemos usar simulación:\n\nFijamos una \\(f\\).\nSimulamos una \\(a\\) del modelo \\(p(a|f)\\)\nPara calcular \\(\\int p(c|a,f')p(f')\\), tenemos que simular un valor \\(f'\\) de la marginal de \\(p(f)\\), y luego, sustituir junto la \\(a\\) de 1 para simular una \\(c\\) de \\(p(c|a, f')\\).\nConsideramos solamente \\(c\\) y \\(f\\) para resumir el efecto.\n\n\nset.seed(481)\nsims_fd <- simular_fd(2000)\nmod_front_door <- cmdstan_model(\"./src/front-door.stan\")\nprint(mod_front_door)\n\ndata {\n int<lower=0> N;\n int<lower=0> n_f;\n vector[N] f;\n vector[N] a;\n array[N] int<lower=0, upper=1> c;\n array[n_f] real do_f;\n\n}\n\ntransformed data {\n real media_a;\n real media_f;\n\n media_a = mean(a);\n media_f = mean(f);\n}\n\nparameters {\n real<lower=0> alpha;\n real alpha_a;\n real<lower=0> alpha_f;\n real int_a;\n real beta_0;\n real<lower=0> beta_1;\n real<lower=0> beta;\n real<lower=0> a_f;\n real<lower=0> b_f;\n real<lower=0> sigma_a;\n real<lower=0> sigma_f;\n\n}\n\n\n\ntransformed parameters {\n\n\n}\n\nmodel {\n f ~ gamma(a_f, b_f);\n a ~ normal(beta * f, sigma_a);\n c ~ bernoulli_logit(int_a + alpha_a * a + alpha_f * f);\n alpha_a ~ normal(0, 1);\n alpha_f ~ normal(0, 1);\n int_a ~ normal(0, 3);\n sigma_a ~ normal(0, 1);\n sigma_f ~ normal(0, 0.1);\n alpha ~ normal(0, 1);\n beta ~ normal(0, 1);\n beta_0 ~ normal(0, 3);\n beta_1 ~ normal(0, 1);\n\n}\ngenerated quantities {\n array[n_f] real mean_c;\n\n for(i in 1:n_f){\n array[2000] real res_sim;\n for(j in 1:2000){\n real a_sim = normal_rng(beta * (do_f[i]), sigma_a);\n real f_sim = gamma_rng(a_f, b_f);\n res_sim[j] = bernoulli_rng(inv_logit(int_a + alpha_a * a_sim + alpha_f * f_sim));\n }\n mean_c[i] = mean(res_sim);\n }\n\n}\n\n\n\ndo_f <- seq(1, 4, 0.1)\nn_f <- length(do_f)\nsims <- mod_front_door$sample(data = list(N = nrow(sims_fd),\n f = sims_fd$f, a = sims_fd$a,\n c = sims_fd$c, do_f = do_f, n_f = n_f),\n init = 0.01, step_size = 0.01, \n refresh = 1000,\n parallel_chains = 4)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 42.7 seconds.\nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 43.4 seconds.\nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 44.1 seconds.\nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 44.3 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 43.6 seconds.\nTotal execution time: 44.4 seconds.\n\n\n\nsims_efecto_tbl <- sims$draws(\"mean_c\", format = \"df\") |> \n pivot_longer(cols = contains(\"mean_c\"), values_to = \"media_c\") |> \n separate(name, c(\"nom\", \"id\"), \n sep = \"[\\\\[\\\\]]\", convert = TRUE, extra = \"drop\") |> \n left_join(tibble(f = do_f) |> \n mutate(id = seq_along(f))) \nresumen_tbl <- sims_efecto_tbl |> \n group_by(id, f) |> \n summarise(media = mean(media_c), \n q5 = quantile(media_c, 0.05),\n q95 = quantile(media_c, 0.95))\n\n\nggplot(resumen_tbl) + \n geom_linerange(aes(x= f, ymax = q95, ymin = q5), colour = \"red\") + \n geom_point(aes(x = f, y = media), colour = \"red\") +\n geom_line(data = sims_1, aes(x = do_f, y = media_c)) +\n xlab(\"Nivel de tabaquismo\") + ylab(\"Prop afectada\")\n\n\n\n\n\n\n\n\nY parece que hemos obtenido una estimación razonable del efecto causal de fumar sobre cáncer. Recordemos también que debemos ser cuidadosos al comparar intervalos que salen del mismo modelo por su nivel de traslape.\nPor ejemplo, si quisiéramos calcular contrastes con el nivel 2 de tabaquismo:\n\nefecto_2 <- sims_efecto_tbl |> filter(f == 2) |> \n select(.draw, efecto_2 = media_c)\ncomp_tbl <- left_join(sims_efecto_tbl, efecto_2) |> \n mutate(dif_2 = media_c - efecto_2)\n\nJoining with `by = join_by(.draw)`\n\ncomp_tbl |> group_by(f) |> \n summarise(media = mean(dif_2), q5 = quantile(dif_2, 0.05),\n q95 = quantile(dif_2, 0.95)) |> \nggplot() + geom_linerange(aes(x= f, ymax = q95, ymin = q5)) + geom_point(aes(x = f, y = media)) +\n xlab(\"Nivel de tabaquismo\") + ylab(\"Prop afectada\")\n\n\n\n\n\n\n\n\nNota: nótese como en este ejemplo hemos evitado incluir en nuestro modelo la variable no observada \\(U\\), gracias al procedimiento de puerta delantera descrito arriba.\nEs posible sin embargo intentar un modelo completo bayesiano, sin necesidad de recordar la fórmula. El procedimiento, que es más difícil de ajustar: considera una variable latente \\(U\\) no observada, y es necesario definir cómo puede ser su relación con sus descendientes. Es necesario más cuidado en definir formas funcionales e iniciales apropiadas para que los muestreadores funcionen apropiadamente.\n\n\n\n\nMcElreath, R. 2020. Statistical Rethinking: A Bayesian Course with Examples in R and Stan. A Chapman & Hall libro. CRC Press. https://books.google.com.mx/books?id=Ie2vxQEACAAJ.", + "text": "6.7 El criterio de puerta delantera\nEn algunos casos, puede ser que no sea posible bloquear algún camino no causal con variables observadas. Un ejemplo clásico es el de la discusión acerca de la relación de fumar con cáncer de pulmón. Algunos estadísticos plantearon que los estudios de asociación entre fumar y cáncer de pulmón podrían tener efectos gravemente confundidos, por ejemplo, por aspectos genéticos que hacen a una persona propensa a fumar al mismo tiempo que aumenta su probabilidad de fumar:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n F\n C\n node [shape = circle]\n U\n edge [minlen = 3]\n U -> F\n U -> C\n F -> C\n{rank= same; C; F}\n}\n\")\n\n\n\n\n\n\nEn este caso, el efecto de fumar (\\(F\\)) sobre cáncer (\\(C\\)) no es identificable pues no podemos condicionar a la variable de Genotipo (\\(U\\)). Supongamos que tenemos una medida adicional, que es la cantidad de depósitos de alquitrán den los pulmones de los pacientes. Este es es afectado por \\(F\\), y a su vez, el alquitrán incrementa la probabilidad de cáncer:\n\n\nCódigo\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2]\n node [shape=plaintext]\n F\n C\n A\n node [shape = circle]\n U\n edge [minlen = 3]\n U -> F\n U -> C\n F -> A\n A -> C\n{rank= same; C; F; A}\n}\n\")\n\n\n\n\n\n\nLa idea es primero estimar el efecto de \\(F\\) sobre \\(A\\), y después estimar el efecto de \\(A\\) sobre \\(C\\). La “composición” de estos dos efectos, dado el diagrama, debe darnos el estimador correcto. Primero consideramos el efecto de \\(F\\) sobre \\(A\\), y tenemos que (regla 2)\n\\[p(a|do(f)) = p(a|f),\\] La igualdad se debe a que una vez que condicionamos a \\(F\\) no hay puertas traseras entre \\(F\\) y \\(A\\) (pues no condicionamos a \\(C\\)). Esta dependencia causal la podemos entonces estimar de los datos.\nEl efecto de \\(A\\) sobre \\(C\\) también es identificable, pues el camino no causal se bloquea cuando condicionamos a \\(F\\), de forma que por la fórmula de ajuste:\n\\[p(c|do(a)) = \\int p(c|a, f') p(f')\\, df'\\]\nAhora encadenamos estas dos ecuaciones:\n\\[p(c|do(f)) = \\int p(c|do(a))p(a|f)\\,da\\]\nque equivale en simulación a: dado un valor de \\(F\\), simulamos \\(A\\) con nuestro modelo ajustado con datos naturales. Ahora intervenimos \\(A\\) con el valor \\(a\\) que obtuvimos y simulamos \\(C\\). Sin embargo, para hacer este último paso con datos naturales, necesitamos usar el criterio de puerta trasera como explicamos arriba: simulamos entonces \\(f´\\) de \\(p(f)\\), y después simulamos \\(C\\) en función de \\(a\\) y \\(f´\\) (con una distribución construida a partir de datos).\nRequerimos en este caso construir y estimar la condicional \\(p(c|a, f)\\) basado en los datos.\nEn fórmula, en general, se escribe como:\n\n\n\n\n\n\nCriterio de fuerta delantera (Pearl)\n\n\n\nDecimos que un conjunto de variables \\(A\\) satisface el criterio de puerta delantera en relación a las variables \\(F\\) y \\(C\\) cuando:\n\n\\(A\\) intercepta todos las cadenas dirigidos de \\(F\\) a \\(C\\)\nNo hay ningún camino activo de puerta trasera de \\(F\\) a \\(A\\)\nTodos los caminos de puerta trasera de \\(A\\) a \\(C\\) están bloqueados por \\(F\\).\n\nSi \\(A\\) satisface el criterio de puerta delantera en relación a \\(F\\) y \\(C\\), entonces el efecto causal de \\(F\\) en \\(C\\) es identificable y está dado por la fórmula:\n\\[p(c|do(f)) = \\int \\left [ \\int p(c|a,f´)p(f´)\\,df´ \\right ] p(a|f)\\,da\\]\n\n\nTodas estas cantidades puede estimarse de los datos.\n\nEjemplo: proceso generador\nAntes de aplicar este nuevo procedimiento, describamos el proceso generador que utilizaremos:\n\n# simular distribución natural\nsimular_fd <- function(n = 10, efecto_a = 0.3){\n ## causa común\n u <- rnorm(n, 0, 1);\n # cantidad que fuma\n f <- exp(rnorm(n, 1 + 0.2 * u, 0.1))\n # acumulación de alquitrán\n a <- rnorm(n, 4 * f, 2)\n # probabilidad de cancer\n p_c <- inv_logit(-6 + efecto_a * a + 2 * u)\n c <- rbinom(n, 1, p_c)\n tibble(f, a, c, u)\n}\n# simular datos intervenidos (suponiendo que conocemos todo)\nsim_int_f <- function(n = 100, do_f = 0.3, efecto_a = 0.3){\n a <- rnorm(n, 4 * do_f, 2)\n u <- rnorm(n, 0, 1)\n p_c <- inv_logit(-6 + efecto_a * a + 2 * u)\n c <- rbinom(n, 1, p_c)\n tibble(do_f = do_f, media_c = mean(c))\n}\n\n\nset.seed(4481)\nsims_fd <- simular_fd(5000)\nsims_fd_1 <- simular_fd(10000)\nqplot(sims_fd$f, sims_fd$a)\n\nWarning: `qplot()` was deprecated in ggplot2 3.4.0.\n\n\n\n\n\n\n\n\n\n¿Cómo se ve la relación de fumador con cáncer? En esta gráfica mostramos también el valor de la variable no observada \\(U\\). Nótese que parte de la correlación positiva que existe es debido a esta variable \\(U\\).\n\nggplot(sims_fd, aes(x = f, y = c, colour = u)) + \n geom_jitter() + scale_colour_continuous(type = \"viridis\")\n\n\n\n\n\n\n\n\nAhora veamos cómo se ve el efecto de \\(F\\) sobre \\(C\\) y también cómo se ve el cruce de \\(F\\) y \\(C\\) en los datos naturales:\n\nsims_1 <- map_df(seq(1, 4, 0.5), ~ sim_int_f(100000, .x))\n\nsims_1 |> \n ggplot() + geom_line(aes(x = do_f, y = media_c)) +\n geom_smooth(data = sims_fd_1, aes(x = f, y = c), method = \"loess\", span = 0.3, se = FALSE, colour =\"red\") + xlab(\"Grado de tabaquismo\") +\n xlim(c(1,4))\n\n`geom_smooth()` using formula = 'y ~ x'\n\n\nWarning: Removed 376 rows containing non-finite values (`stat_smooth()`).\n\n\n\n\n\n\n\n\n\nEn efecto causal promedio de fumar, en cada nivel, sobre la incidencia de cáncer de pulmón, suponiendo nuestro proceso generador. Nótese que la relación no es tan fuerte como observamos en los datos naturales (en rojo). Esto se debe a que en los datos naturales, las personas existe una causa común entre no fumar y prevenir cáncer de pulmón.\n\n\nEjemplo: estimación con puerta delantera\nVeamos cómo sería la estimación si tuviéramos datos disponible, y si es que podemos recuperar el efecto correcto dados los datos observados y la técnica de puerta delantera.\nNótese que sólo necesitamos \\(p(c|a, f), p(a|f)\\) y \\(p(f)\\). Estos son modelos estadísticos con el que podemos identificar el efecto que nos interesa. Una vez que los estimemos, podemos usar simulación:\n\nFijamos una \\(f\\).\nSimulamos una \\(a\\) del modelo \\(p(a|f)\\)\nPara calcular \\(\\int p(c|a,f')p(f')\\), tenemos que simular un valor \\(f'\\) de la marginal de \\(p(f)\\), y luego, sustituir junto la \\(a\\) de 1 para simular una \\(c\\) de \\(p(c|a, f')\\).\nConsideramos solamente \\(c\\) y \\(f\\) para resumir el efecto.\n\n\nset.seed(481)\nsims_fd <- simular_fd(2000)\nmod_front_door <- cmdstan_model(\"./src/front-door.stan\")\nprint(mod_front_door)\n\ndata {\n int<lower=0> N;\n int<lower=0> n_f;\n vector[N] f;\n vector[N] a;\n array[N] int<lower=0, upper=1> c;\n array[n_f] real do_f;\n\n}\n\ntransformed data {\n real media_a;\n real media_f;\n\n media_a = mean(a);\n media_f = mean(f);\n}\n\nparameters {\n real<lower=0> alpha;\n real alpha_a;\n real<lower=0> alpha_f;\n real int_a;\n real beta_0;\n real<lower=0> beta_1;\n real<lower=0> beta;\n real<lower=0> a_f;\n real<lower=0> b_f;\n real<lower=0> sigma_a;\n real<lower=0> sigma_f;\n\n}\n\n\n\ntransformed parameters {\n\n\n}\n\nmodel {\n f ~ gamma(a_f, b_f);\n a ~ normal(beta * f, sigma_a);\n c ~ bernoulli_logit(int_a + alpha_a * a + alpha_f * f);\n alpha_a ~ normal(0, 1);\n alpha_f ~ normal(0, 1);\n int_a ~ normal(0, 3);\n sigma_a ~ normal(0, 1);\n sigma_f ~ normal(0, 0.1);\n alpha ~ normal(0, 1);\n beta ~ normal(0, 1);\n beta_0 ~ normal(0, 3);\n beta_1 ~ normal(0, 1);\n\n}\ngenerated quantities {\n array[n_f] real mean_c;\n\n for(i in 1:n_f){\n array[2000] real res_sim;\n for(j in 1:2000){\n real a_sim = normal_rng(beta * (do_f[i]), sigma_a);\n real f_sim = gamma_rng(a_f, b_f);\n res_sim[j] = bernoulli_rng(inv_logit(int_a + alpha_a * a_sim + alpha_f * f_sim));\n }\n mean_c[i] = mean(res_sim);\n }\n\n}\n\n\n\ndo_f <- seq(1, 4, 0.1)\nn_f <- length(do_f)\nsims <- mod_front_door$sample(data = list(N = nrow(sims_fd),\n f = sims_fd$f, a = sims_fd$a,\n c = sims_fd$c, do_f = do_f, n_f = n_f),\n init = 0.01, step_size = 0.01, \n refresh = 1000,\n parallel_chains = 4)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 43.0 seconds.\nChain 4 finished in 43.0 seconds.\nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 44.3 seconds.\nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 44.6 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 43.7 seconds.\nTotal execution time: 44.7 seconds.\n\n\n\nsims_efecto_tbl <- sims$draws(\"mean_c\", format = \"df\") |> \n pivot_longer(cols = contains(\"mean_c\"), values_to = \"media_c\") |> \n separate(name, c(\"nom\", \"id\"), \n sep = \"[\\\\[\\\\]]\", convert = TRUE, extra = \"drop\") |> \n left_join(tibble(f = do_f) |> \n mutate(id = seq_along(f))) \nresumen_tbl <- sims_efecto_tbl |> \n group_by(id, f) |> \n summarise(media = mean(media_c), \n q5 = quantile(media_c, 0.05),\n q95 = quantile(media_c, 0.95))\n\n\nggplot(resumen_tbl) + \n geom_linerange(aes(x= f, ymax = q95, ymin = q5), colour = \"red\") + \n geom_point(aes(x = f, y = media), colour = \"red\") +\n geom_line(data = sims_1, aes(x = do_f, y = media_c)) +\n xlab(\"Nivel de tabaquismo\") + ylab(\"Prop afectada\")\n\n\n\n\n\n\n\n\nY parece que hemos obtenido una estimación razonable del efecto causal de fumar sobre cáncer. Recordemos también que debemos ser cuidadosos al comparar intervalos que salen del mismo modelo por su nivel de traslape.\nPor ejemplo, si quisiéramos calcular contrastes con el nivel 2 de tabaquismo:\n\nefecto_2 <- sims_efecto_tbl |> filter(f == 2) |> \n select(.draw, efecto_2 = media_c)\ncomp_tbl <- left_join(sims_efecto_tbl, efecto_2) |> \n mutate(dif_2 = media_c - efecto_2)\n\nJoining with `by = join_by(.draw)`\n\ncomp_tbl |> group_by(f) |> \n summarise(media = mean(dif_2), q5 = quantile(dif_2, 0.05),\n q95 = quantile(dif_2, 0.95)) |> \nggplot() + geom_linerange(aes(x= f, ymax = q95, ymin = q5)) + geom_point(aes(x = f, y = media)) +\n xlab(\"Nivel de tabaquismo\") + ylab(\"Prop afectada\")\n\n\n\n\n\n\n\n\nNota: nótese como en este ejemplo hemos evitado incluir en nuestro modelo la variable no observada \\(U\\), gracias al procedimiento de puerta delantera descrito arriba.\nEs posible sin embargo intentar un modelo completo bayesiano, sin necesidad de recordar la fórmula. El procedimiento, que es más difícil de ajustar: considera una variable latente \\(U\\) no observada, y es necesario definir cómo puede ser su relación con sus descendientes. Es necesario más cuidado en definir formas funcionales e iniciales apropiadas para que los muestreadores funcionen apropiadamente.\n\n\n\n\nMcElreath, R. 2020. Statistical Rethinking: A Bayesian Course with Examples in R and Stan. A Chapman & Hall libro. CRC Press. https://books.google.com.mx/books?id=Ie2vxQEACAAJ.", "crumbs": [ "6  Identificación y cálculo-do" ] @@ -554,7 +554,7 @@ "href": "08-mcmc.html#monte-carlo-hamiltoniano", "title": "8  Markov Chain Monte Carlo", "section": "8.2 Monte Carlo Hamiltoniano", - "text": "8.2 Monte Carlo Hamiltoniano\nUna manera de mejorar la exploración de Metropolis es utilizar una distribución de propuestas más apropiada. La intuición en el caso anterior es:\n\nHay direcciones de más curvatura de la posterior que otras: movimientos relativamente chicos en las direcciones de alta curvatura nos llevan a regiones de probabilidad demasiado baja, y entonces tendemos a rechazar. Pero hacer movimientos aún más chicos para evitar rechazos nos lleva a explorar muy lentamente el espacio de parámetros.\nPodríamos evitar esto si nuestros saltos siguieran la curvatura natural de la distribución, como una pelota que rueda por la superficie de la distribución objetivo (con signo negativo, de forma que regiones de probabilidad alta sean valles o regiones bajas).\n\nLa idea de HMC es considerar el problema de muestrear de una distribución como un problema físico, donde introducimos aleatoridad solamente en cuanto a la “energía” de la pelota que va a explorar la posterior. Inicialmente impartimos un momento tomado al azar a la pelota, seguimos su trayectoria por un tiempo y el lugar a donde llega es nuestra nueva simulación. Esto permite que podamos dar saltos más grandes, sin “despeñarnos” en regiones de probabilidad muy baja y así evitar rechazos.\nAdicionalmente, veremos que si definimos el sistema físico apropiadamente, es posible obtener ecuaciones de balance detallado, lo cual en teoría nos garantiza una manera de transicionar que resultará a largo plazo en una muestra de la distribución objetivo.\n\nFormulación Hamiltoniana 1: introducción\nPrimero veremos cuál es la formulación Hamiltoniana (muy simple) de un sistema físico que nos sirve para encontrar la trayectoria de partículas del sistema. Consideremos una sola partícula cuya posición está dada por \\(q\\), que suponemos en una sola dimensión. La partícula rueda en una superficie cuya altura describimos como \\(V(q)\\), y tiene en cada instante tiene momento \\(p = m\\dot{q}\\).\nEl Hamiltoniano es la energía total de este sistema, en el espacio fase que describe el estado de cada partícula dadas su posición y momento \\((p,q)\\), y es la suma de energía cinética más energía potencial:\n\\(H(p,q) = T(p) + V(q)\\)\ndonde \\(V(q) = q^2/2\\) está dada y \\(T(p) = \\frac{p^2}{2m}\\), de modo que\n\\[H(p, q) = \\frac{p^2}{2m} + V(q) = \\frac{p^2}{2m} + \\frac{q^2}{2}\\]\nAhora consideremos las curvas de nivel de \\(H\\) (energía total constante), que en este caso se conservan a lo largo del movimiento de la partícula. Como sabemos por cálculo, estas curvas son perpendiculares al gradiente del Hamiltoniano, que es \\((\\partial{H}/\\partial{p}, \\partial{H}/\\partial{q})\\). El movimiento de las partículas, sin embargo, es a lo largo de las curvas de nivel, de manera que el flujo instantáneo debe estar dado por el gradiente de \\(H\\) rotado 90 grados, es decir, por \\((\\partial{H}/\\partial{q}, -\\partial{H}/\\partial{p})\\).\nEntonces tenemos que el movimiento de la partícula debe cumplir las ecuaciones de Hamilton:\n\\[\\frac{dp}{dt} = \\frac{\\partial{H}}{\\partial{q}}, \\frac{dq}{dt} = -\\frac{\\partial{H}}{\\partial{p}}\\] Simplificando y usando la definición de \\(H\\), obtenemos que \\[\\frac{dq}{dt} = \\frac{p}{m}, \\frac{dp}{dt} = -\\frac{\\partial{V}}{\\partial{q}} = -q\\] Ilustramos este campo vectorial en la siguiente gráfica, donde escogemos \\(V(q) = q^2/2\\), \\(m=1\\), y dibujamos algunas curvas de nivel del Hamiltoniano:\n\n\nCódigo\nespacio_fase_1 <- tibble(p = seq(-3, 3, length.out = 1000), q = seq(-3, 3, length.out = 1000)) |> \n expand(p, q) |> \n mutate(dq = p, dp = -q) |> \n mutate(H = p^2/2 + q^2/2)\nespacio_fase <- tibble(p = seq(-3, 3, length.out = 10), q = seq(-3, 3, length.out = 10)) |> \n expand(p, q) |> \n mutate(dq = p, dp = -q)\nespacio_fase |> \n ggplot(aes(p, q)) +\n geom_contour(data = espacio_fase_1, aes(x = p, y = q, z = H)) +\n geom_segment(aes(xend = p + dp/5, yend = q + dq/5), \n arrow = arrow(length = unit(0.1, \"inches\"))) +\n theme_minimal() +\n labs(subtitle = \"Movimiento en espacio fase: 1 dimensión\")\n\n\n\n\n\n\n\n\n\nOjo: este no es le movimiento de una partícula en dimensión 2: es el movimiento de la partícula en el espacio fase \\((p,q)\\), y la variable de posición \\(q\\) es de dimensión 1. Los ciclos de la gráfica muestran como conforme la partícula se mueve, energía potencial y cinética se intercambian a lo largo de su trayectoria en un “hilo”.\n\n\nFormulación Hamiltoniana 2: densidades de probabilidad\nConsideremos una partícula en el espacio de parámetros \\(\\theta\\). En esta formulación, si \\(\\theta\\) son los parámetros de interés, consideramos la energía potencial del sistema como \\(V(p) = -\\log p(\\theta)\\), donde \\(p(\\theta)\\) es la distribución objetivo.\nBuscamos simular del sistema con ecuaciones de movimiento para \\(\\theta\\). Como hicimos antes, vamos a “levantar” al espacio fase incluyendo el momento, que denotaremos como \\(\\rho\\). La energía cinética, en el caso más simple, podemos definirla (en la práctica existen reescalamientos) como como \\(T(\\rho) =\\frac{1}{2}\\sum_i \\rho_i^2\\) (la energía cinética es proporcional al momento cuadrado, pues el momento es masa por velocidad).\nEl Hamiltoniano por definición \\(H(\\rho, \\theta) = T(\\rho) + V(\\theta)\\), y las ecuaciones de Hamilton son las mismas que arriba, que en este caso nos dan\n\\[\\frac{d\\theta}{dt} = \\rho, \\frac{d\\rho}{dt} = \\nabla(\\log(p(\\theta)).\\]\nSi resolvemos estas ecuaciones, podemos entonces simular del sistema como sigue:\n\nDado un punto inicial \\(\\theta\\), escogemos un momento inicial \\(\\rho\\) al azar, por ejemplo cada componente normal \\(N(0,1)\\) (en la práctica existe un reescalamiento, pero en general queremos que \\(p(\\rho) = p(-\\rho)\\)). Es decir, agregamos inicialmente una cantidad aleatoria de energía a la partícula.\nUsando las ecuaciones de Hamilton, actualizamos la posición \\(\\theta\\) y el momento de la partícula un cierto tiempo \\(t\\) fijo, de manera que no quedemos muy cerca del valor inicial, pero tampoco hagamos demasiado trabajo computacional.\nLa posición nueva \\(\\theta^*\\) es aceptada como nuestra nueva simulación (si el paso 2 es exacto, pero frecuentemente no lo es).\nRepetimos los pasos 1-3 un número suficiente de veces para obtener simulaciones de la posterior.\n\nEste método produce simulaciones de la distribución objetivo bajo condiciones de regularidad. Podemos demostrar por ejemplo, que se cumple el balance detallado.\n\n\nBalance detallado para HMC\nSupongamos que las transiciones que da este sistema son \\(q(y|x)\\). Nótese que dado el momento simulado, tenemos el estado \\((\\rho, x)\\), y la transición \\(x\\to\\y\\) es determinista, gobernada por las ecuaciones de Hamilton. Escribimos la transición como \\[(\\rho, x) \\to (\\rho^*, y).\\] Nótese que \\(\\rho\\) y \\(x\\) determinan la transición, de modo que\n\\[p(x)q(y|x) = p(x)p(\\rho) = \\exp(-H(\\rho, x)) = \\exp(-H(\\rho^*, y))\\] Que es cierto por conservación de la energía total y la transición sigue exactamente trayectorias del Hamiltoniano. Esta última cantidad, usando un argumento similar, es igual a\n\\[p(y)p(\\rho^*) = p(y)p(-\\rho^*) = p(y) q(x|y)\\] La segunda igualdad se da porque \\(p(\\rho)\\) es Gaussiana (simétrica). Y finalmente, la última igualdad se da porque si necesitamos momento \\(\\rho\\) para llegar de \\(x\\) a \\((\\rho^*, y)\\), entonces necesitamos \\(-\\rho^*\\) (volteamos la velocidad ifnal) para llegar de \\(y\\) a \\((\\rho, x)\\), pues el sistema físico es reversible.\nNótese que este argumento se rompe si por ejemplo si es imposible transicionar de un punto a otro (por ejemplo, cuando la distribución objetivo \\(p\\) tiene dos regiones separadas de probabilidad positiva).\n\n\nIntegración de las ecuaciones de Hamilton\nPara aproximar soluciones de estas ecuaciones diferenciales utilizamos el integrador leapfrog, en el que hacemos actualizaciones alternadas de posición y momento con un tamaño de paso \\(\\epsilon\\) chico. Hacemos este paso un número \\(L\\) de veces, para no quedar muy cerca del valor inicial.\nEn nuestro ejemplo, actualizaríamos por ejemplo el momento a la mitad del paso:\n\\[\\rho_{t+\\epsilon/2} = \\rho_t - \\frac{\\epsilon}{2}\\nabla(\\log(p(\\theta_t)))\\] Seguido de una actualización de la posición:\n\\[\\theta_{t+\\epsilon} = \\theta_t + \\epsilon \\rho_{t+\\epsilon/2}\\] y finalmente otra actualización del momento:\n\\[\\rho_{t+\\epsilon} = \\rho_{t+\\epsilon/2} - \\frac{\\epsilon}{2}\\nabla(\\log(p(\\theta_{t+\\epsilon})))\\] Al final de este proceso, encontraremos que por errores numéricos, quizá el Hamiltoniano varió un poco. Si esto sucede, podemos hacer un paso de aceptación y rechazo como en Metropolis Hastings, donde la probabilidad de aceptar es\n\\[\\min\\left(1, \\exp(H(\\rho,\\theta) - H(\\rho^{*},\\theta^{*}))\\right)\\] donde \\(\\rho^{*}\\) y \\(\\theta^{*}\\) son los valores de momento y posición nuevos y \\(H(\\rho,\\theta)\\) es el Hamiltoniano en el paso anterior.\nObservaciones:\n\nUn caso posible obtengamos desbordes o casi desbordes numéricos del momento o la posición (el Hamiltoniano en el punto inicial es órdenes de magnitud diferente que el inicial, ver el manual de Stan ). Esto indica problemas graves con el algoritmo de integración, y en general marcamos estas iteraciones como divergentes. Estas fallas pueden producir, como veremos, exploración insuficiente de la distribución objetivo.\nSi queremos usar HMC directamente, es delicado afinar el tamaño de paso, la distribución de propuesta para el momento, y el número de saltos \\(L\\). En Stan, que usa una variación de HMC, estos valores son ajustados en el periodo de calentamiento o warmup, antes de\n\n\n\nEjemplo: HMC en una distribución normal bivariada\nPrimero calculamos el gradiente que requerimos. En este caso, podemos hacerlo analíticamente:\n\nconstruir_log_p <- function(m, Sigma){\n Sigma_inv <- solve(Sigma)\n function(z){\n - 0.5 * (t(z-m) %*% Sigma_inv %*% (z-m))\n }\n}\nSigma <- matrix(c(1, 0.8, 0.8, 1), nrow = 2)\nm <- c(2, 3)\nlog_p <- construir_log_p(m, Sigma)\n# en diferenciación automática, el siguiente constructor\n# puede tomar como argumento log_p, pero aquí la escribimos\n# explícitamente\nconstruir_grad_log_p <- function(m, Sigma){\n Sigma_inv <- solve(Sigma)\n function(theta){\n - Sigma_inv %*% (theta-m)\n }\n}\ngrad_log_p <- construir_grad_log_p(m, Sigma)\nconstruir_H <- function(m, Sigma){\n Sigma_inv <- solve(Sigma)\n function(theta, rho){\n - log_p(theta) + 0.5 * sum(rho^2)\n }\n}\nH <- construir_H(m, Sigma)\nlog_p(c(1,3))\n\n [,1]\n[1,] -1.388889\n\ngrad_log_p(c(1,3))\n\n [,1]\n[1,] 2.777778\n[2,] -2.222222\n\n\nAhora, implementamos el algoritmo de HMC. Primero, definimos una función\n\nhamilton_mc <- function(n, theta_0 = c(0,0), log_p, grad_log_p, epsilon, L){\n p <- length(theta_0)\n theta <- matrix(0, n, p)\n theta[1, ] <- theta_0\n rho <- matrix(0, n, p)\n theta_completa <- matrix(0, n*L, p)\n theta_completa[1, 0] <- theta_0\n rho_completa <- matrix(0, n*L, p) \n indice_completa <- 2\n rechazo <- 0\n for(i in 2:n){\n prop_rho <- rnorm(p)\n rho[i-1, ] <- prop_rho\n prop_theta <- theta[i-1, ]\n for(t in 1:L){\n prop_rho <- prop_rho + 0.5 * epsilon * grad_log_p(prop_theta)\n prop_theta <- prop_theta + epsilon * prop_rho \n prop_rho <- prop_rho + 0.5 * epsilon * grad_log_p(prop_theta)\n theta_completa[indice_completa,] <- prop_theta\n rho_completa[indice_completa,] <- prop_rho\n indice_completa <- indice_completa + 1\n }\n \n q <- min(1, exp(H(theta[i-1, ], rho[i-1, ]) - \n H(prop_theta, prop_rho))) \n if(runif(1) < q){\n theta[i, ] <- prop_theta\n } else {\n rechazo <- rechazo + 1\n theta[i, ] <- theta[i-1, ]\n rho[i, ] <- rho[i-1, ]\n theta_completa[indice_completa - 1,] <- theta[i-1, ]\n rho_completa[indice_completa - 1,] <- rho[i-1, ]\n } \n }\n print(rechazo / n)\n list(sims = tibble(x = theta[,1], y = theta[,2]),\n trayectorias = tibble(x = theta_completa[,1], y = theta_completa[,2]) |>\n mutate(iteracion = rep(1:n, each = L), paso = rep(1:L, times = n)))\n}\n\nRevisamos que la muestra aproxima apropiadamente nuestra distribución\n\nset.seed(10)\nhmc_salida <- hamilton_mc(1000, c(0,0), log_p, grad_log_p, 0.2, 12)\n\n[1] 0.016\n\nggplot(hmc_salida$sims, aes(x = x, y = y)) + geom_point() +\n stat_ellipse(data = sims_normal, aes(x, y), \n level = c(0.9), type = \"norm\", colour = \"salmon\") +\n stat_ellipse(data = sims_normal, aes(x, y), \n level = c( 0.5), type = \"norm\", colour = \"salmon\") +\n stat_ellipse(level = c( 0.9), colour = \"green\", type = \"norm\") +\n stat_ellipse(level = c( 0.5), colour = \"green\", type = \"norm\") \n\n\n\n\n\n\n\n\n\ntray_tbl <- hmc_salida$trayectorias\nhead(tray_tbl)\n\n# A tibble: 6 × 4\n x y iteracion paso\n <dbl> <dbl> <int> <int>\n1 0 0 1 1\n2 -0.0185 0.0409 1 2\n3 -0.0757 0.231 1 3\n4 -0.148 0.545 1 4\n5 -0.201 0.940 1 5\n6 -0.192 1.37 1 6\n\n\n\nlibrary(gganimate)\nanim_hmc <- ggplot(tray_tbl |> mutate(iter = 4*as.numeric(paso == 1), \n s = as.numeric(paso == 2)) |> \n filter(iteracion < 30) |> \n mutate(tiempo = row_number()) |> \n mutate(tiempo = tiempo + cumsum(50 * s)), \n aes(x = x, y = y)) + \n geom_point(aes(colour = iter, alpha = iter, size = iter, group = tiempo)) +\n geom_path(colour = \"gray\", alpha = 0.5) +\n transition_reveal(tiempo) +\n elipses_normal +\n theme(legend.position = \"none\") \nanim_save(animation = anim_hmc, filename = \"figuras/hmc-normal.gif\", \n renderer = gifski_renderer())\n\n\n\n\nHMC\n\n\nObservaciones:\n\nNótese que ahora podemos dar pasos más grandes a lo largo de los lugares donde concentra mayor probabilidad.\nEsto implica dos cosas: evitamos el comportamiento de caminata aleatoria (pasos muy cortos), y también tasas de rechazo alto (cuando los pasos son muy grandes en HMC)\nEl algoritmo utiliza información adicional: además de calcular la posterior, como en metropolis, es necesario calcular también el gradiente de la posterior.\nEste algoritmo hace más trabajo para cada iteración (requiere la integración leapfrog), pero cada iteración es más informativa\nBien afinado, funciona para problemas de dimensión alta (cientos o miles de parámetros), donde geométricamente la densidad está concentrada en un espacio geométricamente chico. Existen todavía dificultades que discutiremos en otros modelos más adelante.\n\n\n\n\n\n\n\nTip\n\n\n\nObservamos que hasta ahora no hemos aplicado estos algoritmos para simular de la posterior de un modelo: hemos tomado distribuciones fijas y usamos MCMC para simular de ellas. El proceso para una posterior es el mismo, pero usualmente más complicado pues generalmente involucra mucho más parámetros y una posterior que no tiene una forma analítica conocida.\nSin embargo, la aplicación para una posterior es la misma: siempre podemos calcular el logaritmo de la posterior (al menos hasta una constante de proporcionalidad), y siempre podemos usar diferenciación automática para calcular el gradiente de la log posterior. Podemos aplicar entonces HMC o Metropolis.\n\n\n\n\nComparación de HMC y Metropolis\nFinalmente, haremos una comparación entre el desempeño de HMC y Metropolis en el caso de la distribución normal. Utilizaremos otra normal bivariada con más correlación.\n\nset.seed(737)\nSigma <- matrix(c(1, -0.9, -0.9, 1), nrow = 2)\nm <- c(1, 1)\nlog_p <- construir_log_p(m, Sigma)\ngrad_log_p <- construir_grad_log_p(m, Sigma)\nsystem.time(hmc_1 <- hamilton_mc(1000, c(1,2), log_p, grad_log_p, 0.2, 12))\n\n[1] 0.042\n\n\n user system elapsed \n 0.065 0.000 0.065 \n\nsystem.time(metropolis_1 <- metropolis_mc(1000, c(1,2), log_p, 0.2, 0.2))\n\n[1] 0.204\n\n\n user system elapsed \n 0.018 0.000 0.018 \n\nsystem.time(metropolis_2 <- metropolis_mc(1000, c(1,2), log_p, 1, 1))\n\n[1] 0.692\n\n\n user system elapsed \n 0.018 0.000 0.018 \n\n\n\nsims_hmc <- hmc_1$sims |> mutate(n_sim = row_number()) |> \n mutate(algoritmo = \"hmc\")\nsims_metropolis_1 <- metropolis_1 |> \n mutate(algoritmo = \"metropolis (corto)\") \nsims_metropolis_2 <- metropolis_2 |> \n mutate(algoritmo = \"metropolis (largo)\") \nsims_comp <- bind_rows(sims_hmc, sims_metropolis_1, sims_metropolis_2)\nanim_comp <- ggplot(sims_comp |> filter(n_sim < 200)) + \n transition_reveal(n_sim) +\n theme(legend.position = \"none\") +\n geom_path(aes(x, y), colour = \"gray\", alpha = 0.2) + \n geom_point(aes(x, y, group = n_sim)) +\n facet_wrap(~algoritmo)\nanim_save(animation = anim_comp, filename = \"figuras/comparacion-normal.gif\", height = 250, width = 500,\n units = \"px\",\n renderer = gifski_renderer())\n\n\n\n\nComparación\n\n\n\n\nHMC en Stan\nEn Stan se incluyen tres componentes adicionales importantes para estimar posteriores de manera eficiente:\n\nPeriodos de warm-up (calentamiento) y sampling (muestreo). En el periodo de calentamiento, el muestreador afina tamaños de paso, escalamiento de la distribución de propuesta (normal multivariada), y otros parámetros de manera automática.\nImplementación de diferenciación automática para no tener que calcular el grandiente de la log posterior directamente. A partir del código que damos, se crean automáticamente funciones que calculan el grandiente (no es una aproximación numérica).\nImplementación de HMC sin vueltas en U (NUTS): una afinación adicional es dinámicamente adaptar el número de pasos de integración para evitar “regresos”, como vimos que sucedía en los ejemplos de arriba. Ver por ejemplo aquí, o la documentación de Stan.", + "text": "8.2 Monte Carlo Hamiltoniano\nUna manera de mejorar la exploración de Metropolis es utilizar una distribución de propuestas más apropiada. La intuición en el caso anterior es:\n\nHay direcciones de más curvatura de la posterior que otras: movimientos relativamente chicos en las direcciones de alta curvatura nos llevan a regiones de probabilidad demasiado baja, y entonces tendemos a rechazar. Pero hacer movimientos aún más chicos para evitar rechazos nos lleva a explorar muy lentamente el espacio de parámetros.\nPodríamos evitar esto si nuestros saltos siguieran la curvatura natural de la distribución, como una pelota que rueda por la superficie de la distribución objetivo (con signo negativo, de forma que regiones de probabilidad alta sean valles o regiones bajas).\n\nLa idea de HMC es considerar el problema de muestrear de una distribución como un problema físico, donde introducimos aleatoridad solamente en cuanto a la “energía” de la pelota que va a explorar la posterior. Inicialmente impartimos un momento tomado al azar a la pelota, seguimos su trayectoria por un tiempo y el lugar a donde llega es nuestra nueva simulación. Esto permite que podamos dar saltos más grandes, sin “despeñarnos” en regiones de probabilidad muy baja y así evitar rechazos.\nAdicionalmente, veremos que si definimos el sistema físico apropiadamente, es posible obtener ecuaciones de balance detallado, lo cual en teoría nos garantiza una manera de transicionar que resultará a largo plazo en una muestra de la distribución objetivo.\n\nFormulación Hamiltoniana 1: introducción\nPrimero veremos cuál es la formulación Hamiltoniana (muy simple) de un sistema físico que nos sirve para encontrar la trayectoria de partículas del sistema. Consideremos una sola partícula cuya posición está dada por \\(q\\), que suponemos en una sola dimensión. La partícula rueda en una superficie cuya altura describimos como \\(V(q)\\), y tiene en cada instante tiene momento \\(p = m\\dot{q}\\).\nEl Hamiltoniano es la energía total de este sistema, en el espacio fase que describe el estado de cada partícula dadas su posición y momento \\((p,q)\\), y es la suma de energía cinética más energía potencial:\n\\(H(p,q) = T(p) + V(q)\\)\ndonde \\(V(q) = q^2/2\\) está dada y \\(T(p) = \\frac{p^2}{2m}\\), de modo que\n\\[H(p, q) = \\frac{p^2}{2m} + V(q) = \\frac{p^2}{2m} + \\frac{q^2}{2}\\]\nAhora consideremos las curvas de nivel de \\(H\\) (energía total constante), que en este caso se conservan a lo largo del movimiento de la partícula. Como sabemos por cálculo, estas curvas son perpendiculares al gradiente del Hamiltoniano, que es \\((\\partial{H}/\\partial{p}, \\partial{H}/\\partial{q})\\). El movimiento de las partículas, sin embargo, es a lo largo de las curvas de nivel, de manera que el flujo instantáneo debe estar dado por el gradiente de \\(H\\) rotado 90 grados, es decir, por \\((\\partial{H}/\\partial{q}, -\\partial{H}/\\partial{p})\\).\nEntonces tenemos que el movimiento de la partícula debe cumplir las ecuaciones de Hamilton:\n\\[\\frac{dp}{dt} = \\frac{\\partial{H}}{\\partial{q}}, \\frac{dq}{dt} = -\\frac{\\partial{H}}{\\partial{p}}\\] Simplificando y usando la definición de \\(H\\), obtenemos que \\[\\frac{dq}{dt} = \\frac{p}{m}, \\frac{dp}{dt} = -\\frac{\\partial{V}}{\\partial{q}} = -q\\] Ilustramos este campo vectorial en la siguiente gráfica, donde escogemos \\(V(q) = q^2/2\\), \\(m=1\\), y dibujamos algunas curvas de nivel del Hamiltoniano:\n\n\nCódigo\nespacio_fase_1 <- tibble(p = seq(-3, 3, length.out = 1000), q = seq(-3, 3, length.out = 1000)) |> \n expand(p, q) |> \n mutate(dq = p, dp = -q) |> \n mutate(H = p^2/2 + q^2/2)\nespacio_fase <- tibble(p = seq(-3, 3, length.out = 10), q = seq(-3, 3, length.out = 10)) |> \n expand(p, q) |> \n mutate(dq = p, dp = -q)\nespacio_fase |> \n ggplot(aes(p, q)) +\n geom_contour(data = espacio_fase_1, aes(x = p, y = q, z = H)) +\n geom_segment(aes(xend = p + dp/5, yend = q + dq/5), \n arrow = arrow(length = unit(0.1, \"inches\"))) +\n theme_minimal() +\n labs(subtitle = \"Movimiento en espacio fase: 1 dimensión\")\n\n\n\n\n\n\n\n\n\nOjo: este no es le movimiento de una partícula en dimensión 2: es el movimiento de la partícula en el espacio fase \\((p,q)\\), y la variable de posición \\(q\\) es de dimensión 1. Los ciclos de la gráfica muestran como conforme la partícula se mueve, energía potencial y cinética se intercambian a lo largo de su trayectoria en un “hilo”.\n\n\nFormulación Hamiltoniana 2: densidades de probabilidad\nConsideremos una partícula en el espacio de parámetros \\(\\theta\\). En esta formulación, si \\(\\theta\\) son los parámetros de interés, consideramos la energía potencial del sistema como \\(V(p) = -\\log p(\\theta)\\), donde \\(p(\\theta)\\) es la distribución objetivo.\nBuscamos simular del sistema con ecuaciones de movimiento para \\(\\theta\\). Como hicimos antes, vamos a “levantar” al espacio fase incluyendo el momento, que denotaremos como \\(\\rho\\). La energía cinética, en el caso más simple, podemos definirla (en la práctica existen reescalamientos) como como \\(T(\\rho) =\\frac{1}{2}\\sum_i \\rho_i^2\\) (la energía cinética es proporcional al momento cuadrado, pues el momento es masa por velocidad).\nEl Hamiltoniano por definición \\(H(\\rho, \\theta) = T(\\rho) + V(\\theta)\\), y las ecuaciones de Hamilton son las mismas que arriba, que en este caso nos dan\n\\[\\frac{d\\theta}{dt} = \\rho, \\frac{d\\rho}{dt} = \\nabla(\\log(p(\\theta)).\\]\nSi resolvemos estas ecuaciones, podemos entonces simular del sistema como sigue:\n\nDado un punto inicial \\(\\theta\\), escogemos un momento inicial \\(\\rho\\) al azar, por ejemplo cada componente normal \\(N(0,1)\\) (en la práctica existe un reescalamiento, pero en general queremos que \\(p(\\rho) = p(-\\rho)\\)). Es decir, agregamos inicialmente una cantidad aleatoria de energía a la partícula.\nUsando las ecuaciones de Hamilton, actualizamos la posición \\(\\theta\\) y el momento de la partícula un cierto tiempo \\(t\\) fijo, de manera que no quedemos muy cerca del valor inicial, pero tampoco hagamos demasiado trabajo computacional.\nLa posición nueva \\(\\theta^*\\) es aceptada como nuestra nueva simulación (si el paso 2 es exacto, pero frecuentemente no lo es).\nRepetimos los pasos 1-3 un número suficiente de veces para obtener simulaciones de la posterior.\n\nEste método produce simulaciones de la distribución objetivo bajo condiciones de regularidad. Podemos demostrar por ejemplo, que se cumple el balance detallado.\n\n\nBalance detallado para HMC\nSupongamos que las transiciones que da este sistema son \\(q(y|x)\\). Nótese que dado el momento simulado, tenemos el estado \\((\\rho, x)\\), y la transición \\(x\\to\\y\\) es determinista, gobernada por las ecuaciones de Hamilton. Escribimos la transición como \\[(\\rho, x) \\to (\\rho^*, y).\\] Nótese que \\(\\rho\\) y \\(x\\) determinan la transición, de modo que\n\\[p(x)q(y|x) = p(x)p(\\rho) = \\exp(-H(\\rho, x)) = \\exp(-H(\\rho^*, y))\\] Que es cierto por conservación de la energía total y la transición sigue exactamente trayectorias del Hamiltoniano. Esta última cantidad, usando un argumento similar, es igual a\n\\[p(y)p(\\rho^*) = p(y)p(-\\rho^*) = p(y) q(x|y)\\] La segunda igualdad se da porque \\(p(\\rho)\\) es Gaussiana (simétrica). Y finalmente, la última igualdad se da porque si necesitamos momento \\(\\rho\\) para llegar de \\(x\\) a \\((\\rho^*, y)\\), entonces necesitamos \\(-\\rho^*\\) (volteamos la velocidad ifnal) para llegar de \\(y\\) a \\((\\rho, x)\\), pues el sistema físico es reversible.\nNótese que este argumento se rompe si por ejemplo si es imposible transicionar de un punto a otro (por ejemplo, cuando la distribución objetivo \\(p\\) tiene dos regiones separadas de probabilidad positiva).\n\n\nIntegración de las ecuaciones de Hamilton\nPara aproximar soluciones de estas ecuaciones diferenciales utilizamos el integrador leapfrog, en el que hacemos actualizaciones alternadas de posición y momento con un tamaño de paso \\(\\epsilon\\) chico. Hacemos este paso un número \\(L\\) de veces, para no quedar muy cerca del valor inicial.\nEn nuestro ejemplo, actualizaríamos por ejemplo el momento a la mitad del paso:\n\\[\\rho_{t+\\epsilon/2} = \\rho_t - \\frac{\\epsilon}{2}\\nabla(\\log(p(\\theta_t)))\\] Seguido de una actualización de la posición:\n\\[\\theta_{t+\\epsilon} = \\theta_t + \\epsilon \\rho_{t+\\epsilon/2}\\] y finalmente otra actualización del momento:\n\\[\\rho_{t+\\epsilon} = \\rho_{t+\\epsilon/2} - \\frac{\\epsilon}{2}\\nabla(\\log(p(\\theta_{t+\\epsilon})))\\] Al final de este proceso, encontraremos que por errores numéricos, quizá el Hamiltoniano varió un poco. Si esto sucede, podemos hacer un paso de aceptación y rechazo como en Metropolis Hastings, donde la probabilidad de aceptar es\n\\[\\min\\left(1, \\exp(H(\\rho,\\theta) - H(\\rho^{*},\\theta^{*}))\\right)\\] donde \\(\\rho^{*}\\) y \\(\\theta^{*}\\) son los valores de momento y posición nuevos y \\(H(\\rho,\\theta)\\) es el Hamiltoniano en el paso anterior.\nObservaciones:\n\nUn caso posible obtengamos desbordes o casi desbordes numéricos del momento o la posición (el Hamiltoniano en el punto inicial es órdenes de magnitud diferente que el inicial, ver el manual de Stan ). Esto indica problemas graves con el algoritmo de integración, y en general marcamos estas iteraciones como divergentes. Estas fallas pueden producir, como veremos, exploración insuficiente de la distribución objetivo.\nSi queremos usar HMC directamente, es delicado afinar el tamaño de paso, la distribución de propuesta para el momento, y el número de saltos \\(L\\). En Stan, que usa una variación de HMC, estos valores son ajustados en el periodo de calentamiento o warmup, antes de\n\n\n\nEjemplo: HMC en una distribución normal bivariada\nPrimero calculamos el gradiente que requerimos. En este caso, podemos hacerlo analíticamente:\n\nconstruir_log_p <- function(m, Sigma){\n Sigma_inv <- solve(Sigma)\n function(z){\n - 0.5 * (t(z-m) %*% Sigma_inv %*% (z-m))\n }\n}\nSigma <- matrix(c(1, 0.8, 0.8, 1), nrow = 2)\nm <- c(2, 3)\nlog_p <- construir_log_p(m, Sigma)\n# en diferenciación automática, el siguiente constructor\n# puede tomar como argumento log_p, pero aquí la escribimos\n# explícitamente\nconstruir_grad_log_p <- function(m, Sigma){\n Sigma_inv <- solve(Sigma)\n function(theta){\n - Sigma_inv %*% (theta-m)\n }\n}\ngrad_log_p <- construir_grad_log_p(m, Sigma)\nconstruir_H <- function(m, Sigma){\n Sigma_inv <- solve(Sigma)\n function(theta, rho){\n - log_p(theta) + 0.5 * sum(rho^2)\n }\n}\nH <- construir_H(m, Sigma)\nlog_p(c(1,3))\n\n [,1]\n[1,] -1.388889\n\ngrad_log_p(c(1,3))\n\n [,1]\n[1,] 2.777778\n[2,] -2.222222\n\n\nAhora, implementamos el algoritmo de HMC. Primero, definimos una función\n\nhamilton_mc <- function(n, theta_0 = c(0,0), log_p, grad_log_p, epsilon, L){\n p <- length(theta_0)\n theta <- matrix(0, n, p)\n theta[1, ] <- theta_0\n rho <- matrix(0, n, p)\n theta_completa <- matrix(0, n*L, p)\n theta_completa[1, 0] <- theta_0\n rho_completa <- matrix(0, n*L, p) \n indice_completa <- 2\n rechazo <- 0\n for(i in 2:n){\n prop_rho <- rnorm(p)\n rho[i-1, ] <- prop_rho\n prop_theta <- theta[i-1, ]\n for(t in 1:L){\n prop_rho <- prop_rho + 0.5 * epsilon * grad_log_p(prop_theta)\n prop_theta <- prop_theta + epsilon * prop_rho \n prop_rho <- prop_rho + 0.5 * epsilon * grad_log_p(prop_theta)\n theta_completa[indice_completa,] <- prop_theta\n rho_completa[indice_completa,] <- prop_rho\n indice_completa <- indice_completa + 1\n }\n \n q <- min(1, exp(H(theta[i-1, ], rho[i-1, ]) - \n H(prop_theta, prop_rho))) \n if(runif(1) < q){\n theta[i, ] <- prop_theta\n } else {\n rechazo <- rechazo + 1\n theta[i, ] <- theta[i-1, ]\n rho[i, ] <- rho[i-1, ]\n theta_completa[indice_completa - 1,] <- theta[i-1, ]\n rho_completa[indice_completa - 1,] <- rho[i-1, ]\n } \n }\n print(rechazo / n)\n list(sims = tibble(x = theta[,1], y = theta[,2]),\n trayectorias = tibble(x = theta_completa[,1], y = theta_completa[,2]) |>\n mutate(iteracion = rep(1:n, each = L), paso = rep(1:L, times = n)))\n}\n\nRevisamos que la muestra aproxima apropiadamente nuestra distribución\n\nset.seed(10)\nhmc_salida <- hamilton_mc(1000, c(0,0), log_p, grad_log_p, 0.2, 12)\n\n[1] 0.016\n\nggplot(hmc_salida$sims, aes(x = x, y = y)) + geom_point() +\n stat_ellipse(data = sims_normal, aes(x, y), \n level = c(0.9), type = \"norm\", colour = \"salmon\") +\n stat_ellipse(data = sims_normal, aes(x, y), \n level = c( 0.5), type = \"norm\", colour = \"salmon\") +\n stat_ellipse(level = c( 0.9), colour = \"green\", type = \"norm\") +\n stat_ellipse(level = c( 0.5), colour = \"green\", type = \"norm\") \n\n\n\n\n\n\n\n\n\ntray_tbl <- hmc_salida$trayectorias\nhead(tray_tbl)\n\n# A tibble: 6 × 4\n x y iteracion paso\n <dbl> <dbl> <int> <int>\n1 0 0 1 1\n2 -0.0185 0.0409 1 2\n3 -0.0757 0.231 1 3\n4 -0.148 0.545 1 4\n5 -0.201 0.940 1 5\n6 -0.192 1.37 1 6\n\n\n\nlibrary(gganimate)\nanim_hmc <- ggplot(tray_tbl |> mutate(iter = 4*as.numeric(paso == 1), \n s = as.numeric(paso == 2)) |> \n filter(iteracion < 30) |> \n mutate(tiempo = row_number()) |> \n mutate(tiempo = tiempo + cumsum(50 * s)), \n aes(x = x, y = y)) + \n geom_point(aes(colour = iter, alpha = iter, size = iter, group = tiempo)) +\n geom_path(colour = \"gray\", alpha = 0.5) +\n transition_reveal(tiempo) +\n elipses_normal +\n theme(legend.position = \"none\") \nanim_save(animation = anim_hmc, filename = \"figuras/hmc-normal.gif\", \n renderer = gifski_renderer())\n\n\n\n\nHMC\n\n\nObservaciones:\n\nNótese que ahora podemos dar pasos más grandes a lo largo de los lugares donde concentra mayor probabilidad.\nEsto implica dos cosas: evitamos el comportamiento de caminata aleatoria (pasos muy cortos), y también tasas de rechazo alto (cuando los pasos son muy grandes en HMC)\nEl algoritmo utiliza información adicional: además de calcular la posterior, como en metropolis, es necesario calcular también el gradiente de la posterior.\nEste algoritmo hace más trabajo para cada iteración (requiere la integración leapfrog), pero cada iteración es más informativa\nBien afinado, funciona para problemas de dimensión alta (cientos o miles de parámetros), donde geométricamente la densidad está concentrada en un espacio geométricamente chico. Existen todavía dificultades que discutiremos en otros modelos más adelante.\n\n\n\n\n\n\n\nTip\n\n\n\nObservamos que hasta ahora no hemos aplicado estos algoritmos para simular de la posterior de un modelo: hemos tomado distribuciones fijas y usamos MCMC para simular de ellas. El proceso para una posterior es el mismo, pero usualmente más complicado pues generalmente involucra mucho más parámetros y una posterior que no tiene una forma analítica conocida.\nSin embargo, la aplicación para una posterior es la misma: siempre podemos calcular el logaritmo de la posterior (al menos hasta una constante de proporcionalidad), y siempre podemos usar diferenciación automática para calcular el gradiente de la log posterior. Podemos aplicar entonces HMC o Metropolis.\n\n\n\n\nComparación de HMC y Metropolis\nFinalmente, haremos una comparación entre el desempeño de HMC y Metropolis en el caso de la distribución normal. Utilizaremos otra normal bivariada con más correlación.\n\nset.seed(737)\nSigma <- matrix(c(1, -0.9, -0.9, 1), nrow = 2)\nm <- c(1, 1)\nlog_p <- construir_log_p(m, Sigma)\ngrad_log_p <- construir_grad_log_p(m, Sigma)\nsystem.time(hmc_1 <- hamilton_mc(1000, c(1,2), log_p, grad_log_p, 0.2, 12))\n\n[1] 0.042\n\n\n user system elapsed \n 0.064 0.000 0.064 \n\nsystem.time(metropolis_1 <- metropolis_mc(1000, c(1,2), log_p, 0.2, 0.2))\n\n[1] 0.204\n\n\n user system elapsed \n 0.018 0.000 0.018 \n\nsystem.time(metropolis_2 <- metropolis_mc(1000, c(1,2), log_p, 1, 1))\n\n[1] 0.692\n\n\n user system elapsed \n 0.017 0.000 0.018 \n\n\n\nsims_hmc <- hmc_1$sims |> mutate(n_sim = row_number()) |> \n mutate(algoritmo = \"hmc\")\nsims_metropolis_1 <- metropolis_1 |> \n mutate(algoritmo = \"metropolis (corto)\") \nsims_metropolis_2 <- metropolis_2 |> \n mutate(algoritmo = \"metropolis (largo)\") \nsims_comp <- bind_rows(sims_hmc, sims_metropolis_1, sims_metropolis_2)\nanim_comp <- ggplot(sims_comp |> filter(n_sim < 200)) + \n transition_reveal(n_sim) +\n theme(legend.position = \"none\") +\n geom_path(aes(x, y), colour = \"gray\", alpha = 0.2) + \n geom_point(aes(x, y, group = n_sim)) +\n facet_wrap(~algoritmo)\nanim_save(animation = anim_comp, filename = \"figuras/comparacion-normal.gif\", height = 250, width = 500,\n units = \"px\",\n renderer = gifski_renderer())\n\n\n\n\nComparación\n\n\n\n\nHMC en Stan\nEn Stan se incluyen tres componentes adicionales importantes para estimar posteriores de manera eficiente:\n\nPeriodos de warm-up (calentamiento) y sampling (muestreo). En el periodo de calentamiento, el muestreador afina tamaños de paso, escalamiento de la distribución de propuesta (normal multivariada), y otros parámetros de manera automática.\nImplementación de diferenciación automática para no tener que calcular el grandiente de la log posterior directamente. A partir del código que damos, se crean automáticamente funciones que calculan el grandiente (no es una aproximación numérica).\nImplementación de HMC sin vueltas en U (NUTS): una afinación adicional es dinámicamente adaptar el número de pasos de integración para evitar “regresos”, como vimos que sucedía en los ejemplos de arriba. Ver por ejemplo aquí, o la documentación de Stan.", "crumbs": [ "8  Markov Chain Monte Carlo" ] @@ -564,7 +564,7 @@ "href": "08-mcmc.html#diagnósticos-de-convergencia", "title": "8  Markov Chain Monte Carlo", "section": "8.3 Diagnósticos de convergencia", - "text": "8.3 Diagnósticos de convergencia\nAunque casi nunca es posible demostrar rigurosamente que las simulaciones de un algoritmo MCMC dan buena aproximación de la distribución posterior de interés, especialmente con HMC y NUTS, tenemos muchos diagnósticos que fallan cuando existen problemas serios.\nEn primer lugar, será útil correr distintas cadenas con valores iniciales aleatorios diferentes, analizamos cada una y las comparamos entre sí. Recordamos que cada una de estas cadenas tiene como distribución estacionaria límite la distribución posterior. Diagnósticos que indican que las cadenas se comportan de manera muy distinta, explorando distintas regiones del espacio de parámetros, o que no han convergido porque exploran lentamente el espacio de parámetros, son señales de problemas.\nLos diagnósticos más comunes son:\n\nTraza de cadenas\nMedida R-hat de convergencia: mide la variabilidad entre cadenas y dentro de cadenas.\nNúmero de muestras efectivas (ESS) y autocorrelación.\nTransiciones divergentes.\n\n\nModelos con variables latentes\nVeremos el ejemplo de calificación de vinos de distintos países de McElreath (2020), sus diagnósticos, y aprovecharemos para introducir variables no observadas o latentes para enriquecer nuestras herramientas de modelación.\nNuestra pregunta general es si el país de origen de los vinos influye en su calidad. Los datos que tenemos son calificaciones de vinos de distintos países por distintos jueces. La calidad del vino no la observamos directamente, sino que es causa de las calificaciones que recibe. Para construir nuestro diagrama, las consideraciones básicas son:\n\nEl origen del vino es una causa del calidad del vino (es nuestra cantidad a estimar).\nLos jueces tienen distintas maneras de calificar, de manera que son causa de variación en las calificaciones (hay jueces más duros, otros más barcos, etc.) No observamos directamente que tan “duro” es cada juez.\nLos jueces califican vinos de distintos países de manera ciega. Sin embargo es posible que reconozcan el país de origen por las características de los vinos, de manera que puede existir un efecto directo de Origen en Calificación (no pasa por Calidad).\nEs posible que Jueces de distintos países tienen distintos estándares de calificación.\n\n\n\nCódigo\nlibrary(DiagrammeR)\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir = LR]\n node [shape=plaintext]\n Origen\n Score\n Origen_Juez\n node [shape = circle]\n Q\n J\n edge [minlen = 3]\n Origen -> Q\n Origen -> Score\n Q -> Score\n J -> Score\n Origen_Juez -> J\n}\n\")\n\n\n\n\n\n\nY vemos, por nuestro análisis del DAG, que podemos identificar el efecto de Origen sobre Calidad sin necesidad de estratificar por ninguna variable (no hay puertas traseras). Sin embaergo, podemos estratificar por Juez para obtener más precisión (ver sección anterior de buenos y malos controles).\n\n8.3.0.1 Primera iteración: modelo simple\nComenzamos con un modelo simple, y lo iremos construyendo para obtener la mejor estimación posible de la influencia del país de origen en la calidad del vino. Nuestro primer modelo consideramos que la calificación de cada vino depende de su calidad, y modelamos con una normal:\n\\[S_i \\sim \\text{Normal}(\\mu_i, \\sigma)\\] donde \\[\\mu_i = Q_{vino(i)}\\]. Nuestra medida de calidad tiene escala arbitaria. Como usaremos la calificación estandarizada, podemos poner \\[Q_j \\sim \\text{Normal}(0, 1).\\] finalmente, ponemos una inicial para \\(\\sigma\\), por ejemplo \\(\\sigma \\sim \\text{Exponential}(1)\\) (puedes experimentar con una normal truncada también)\n\nlibrary(cmdstanr)\n\nThis is cmdstanr version 0.7.1\n\n\n- CmdStanR documentation and vignettes: mc-stan.org/cmdstanr\n\n\n- CmdStan path: /home/runner/.cmdstan/cmdstan-2.34.0\n\n\n- CmdStan version: 2.34.0\n\n\n\nA newer version of CmdStan is available. See ?install_cmdstan() to install it.\nTo disable this check set option or environment variable CMDSTANR_NO_VER_CHECK=TRUE.\n\nmod_vinos_1 <- cmdstan_model(\"./src/vinos-1.stan\")\nprint(mod_vinos_1)\n\ndata {\n int<lower=0> N; //número de calificaciones\n int<lower=0> n_vinos; //número de vinos\n int<lower=0> n_jueces; //número de jueces\n vector[N] S;\n array[N] int juez;\n array[N] int vino;\n}\n\nparameters {\n vector[n_vinos] Q;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] media_score;\n // determinístico dado parámetros\n for (i in 1:N){\n media_score[i] = Q[vino[i]];\n }\n}\n\nmodel {\n // partes no determinísticas\n S ~ normal(media_score, sigma);\n Q ~ std_normal();\n sigma ~ exponential(1);\n}\n\n\n\n# Wines 2022 de Statistical Rethinking\nwines_2012 <- read_csv(\"../datos/wines_2012.csv\")\n\nRows: 180 Columns: 6\n── Column specification ────────────────────────────────────────────────────────\nDelimiter: \",\"\nchr (3): judge, flight, wine\ndbl (3): score, wine.amer, judge.amer\n\nℹ Use `spec()` to retrieve the full column specification for this data.\nℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.\n\nglimpse(wines_2012)\n\nRows: 180\nColumns: 6\n$ judge <chr> \"Jean-M Cardebat\", \"Jean-M Cardebat\", \"Jean-M Cardebat\", \"J…\n$ flight <chr> \"white\", \"white\", \"white\", \"white\", \"white\", \"white\", \"whit…\n$ wine <chr> \"A1\", \"B1\", \"C1\", \"D1\", \"E1\", \"F1\", \"G1\", \"H1\", \"I1\", \"J1\",…\n$ score <dbl> 10.0, 13.0, 14.0, 15.0, 8.0, 13.0, 15.0, 11.0, 9.0, 12.0, 1…\n$ wine.amer <dbl> 1, 1, 0, 0, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 0, 1, 0,…\n$ judge.amer <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,…\n\nwines_2012 <- wines_2012 |> \n mutate(juez_num = as.numeric(factor(judge)),\n vino_num = as.numeric(factor(wine))) |> \n mutate(score_est = (score - mean(score))/sd(score))\n\n\nn_jueces <- length(unique(wines_2012$juez_num))\nn_vinos <- length(unique(wines_2012$vino_num))\nc(\"num_vinos\" = n_jueces, \"num_jueces\" = n_vinos, \"num_datos\" = nrow(wines_2012))\n\n num_vinos num_jueces num_datos \n 9 20 180 \n\n\n\ndatos_lst <- list(\n N = nrow(wines_2012),\n n_vinos = n_vinos,\n n_jueces = n_jueces,\n S = wines_2012$score_est,\n vino = wines_2012$vino_num,\n juez = wines_2012$juez_num\n)\najuste_vinos_1 <- mod_vinos_1$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 1000,\n iter_sampling = 2000,\n refresh = 1000,\n step_size = 0.1,\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 1 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 1 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 2 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 2 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 3 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 3 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 3 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 4 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 4 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 1 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 1 finished in 0.3 seconds.\nChain 2 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 2 finished in 0.4 seconds.\nChain 3 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 3 finished in 0.4 seconds.\nChain 4 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 4 finished in 0.4 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.3 seconds.\nTotal execution time: 0.6 seconds.\n\n\nVemos que hay variabilidad en los vinos:\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, ess_bulk, ess_tail) |> \n filter(variable != \"lp__\") |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483\n\n\n\n\n\n\n\n\n\n\n\n8.3.1 Diagnóstico: Trazas de cadenas\nPara hacer diagnósticos, podemos comenzar con las trazas de una cadena para todas las estimaciones de calidad de vino. Cada cadena se inicia con distintos valores aleatorios, pero cumplen en teoría que su distribución de equilibrio es la posterior de interés pues sus transiciones usan el mismo mecanismo.\n\nlibrary(bayesplot)\nmcmc_trace(ajuste_vinos_1$draws(\"Q\", format = \"df\") |> filter(.chain == 1))\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nTip\n\n\n\nLa traza de una cadena es la gráfica de las simulaciones de cada parámetro. Generalmente buscamos que: no tenga tendencia, que no se quede “atorada” en algunos valores, y que no muestre oscilaciones de baja frecuencia (la cadena “vaga” por los valores que explora).\n\n\nSi incluímos todas las cadenas, nos fijemos en que todas ellas exploren regiones similares del espacio de parámetros:\n\ncolor_scheme_set(\"viridis\")\nmcmc_trace(ajuste_vinos_1$draws(\"Q\", format = \"df\")) \n\n\n\n\n\n\n\n\nLo que no queremos ver es lo siguiente, por ejemplo:\n\najuste_vinos_malo <- mod_vinos_1$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 5,\n iter_sampling = 100,\n refresh = 1000,\n step_size =1 ,\n seed = 123\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 WARNING: No variance estimation is \nChain 1 performed for num_warmup < 20 \nChain 1 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 1 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 1 Iteration: 105 / 105 [100%] (Sampling) \nChain 2 WARNING: No variance estimation is \nChain 2 performed for num_warmup < 20 \nChain 2 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 2 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 2 Iteration: 105 / 105 [100%] (Sampling) \nChain 3 WARNING: No variance estimation is \nChain 3 performed for num_warmup < 20 \nChain 3 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 3 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 3 Iteration: 105 / 105 [100%] (Sampling) \n\n\nChain 3 Informational Message: The current Metropolis proposal is about to be rejected because of the following issue:\n\n\nChain 3 Exception: normal_lpdf: Scale parameter is 0, but must be positive! (in '/tmp/RtmpoyEmkk/model-27505774c436.stan', line 25, column 2 to column 33)\n\n\nChain 3 If this warning occurs sporadically, such as for highly constrained variable types like covariance matrices, then the sampler is fine,\n\n\nChain 3 but if this warning occurs often then your model may be either severely ill-conditioned or misspecified.\n\n\nChain 3 \n\n\nChain 4 WARNING: No variance estimation is \nChain 4 performed for num_warmup < 20 \nChain 4 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 4 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 4 Iteration: 105 / 105 [100%] (Sampling) \nChain 1 finished in 0.0 seconds.\nChain 2 finished in 0.0 seconds.\nChain 3 finished in 0.0 seconds.\nChain 4 finished in 0.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.0 seconds.\nTotal execution time: 0.2 seconds.\n\n\nWarning: 324 of 400 (81.0%) transitions ended with a divergence.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 2 of 4 chains had an E-BFMI less than 0.3.\nSee https://mc-stan.org/misc/warnings for details.\n\n\n\ncolor_scheme_set(\"viridisA\")\nmcmc_trace(ajuste_vinos_malo$draws(\"Q\", format = \"df\")) \n\n\n\n\n\n\n\n\nHay varios problemas graves:\n\nAlgunas cadenas parecen “atoradas” en ciertos valores\nAlgunas cadenas parecen caminatas aleatorias (oscilaciones de baja frecuencia)\nLas cadenas no exploran de manera similar el espacio de parámetros\n\n\n\n\n\n\n\nTraza de cadenas\n\n\n\nEl diagnóstico de traza consiste en graficar las cadenas de los parámetros en el orden de la iteración. Buscamos ver que:\n\nLas cadenas no tienen tendencia o oscilaciones de frecuencia muy baja.\nLas cadenas no se atoran en valores específicos.\nLas distintas cadenas exploran de manera similar el espacio de parámetros.\n\nCuando falla alguna de estas, en el mejor de los casos las cadenas son ineficientes (veremos que requerimos un número mucho mayor de iteraciones), y en el peor de los casos dan resultados sesgados que no son confiables.\n\n\n\n\n8.3.2 Diagnóstico: valores R-hat\nCuando nuestro método de simulación converge a la distribución posterior, esperamos que las cadenas, durante todo su proceso, exploran la misma región del espacio de parámetros.\nPodemos entonces considerar, para cada parámetro:\n\nCuánta variación hay en cada cadena.\nQué tan distintas son las cadenas entre ellas.\n\nEsperamos que la variación entre cadenas es chica, y la variación dentro de cada cadena es similar para todas las cadenas. Calculamos entonces un cociente de varianzas: la varianza total sobre todas las simulaciones de todas las cadenas, y el promedio de varianzas de las cadenas. Si las cadenas están explorando regiones similares, esperamos que este cociente de varianzas sea cercano a 1.\nEscribiremos ahora esta idea para entender cómo se calculan estas cantidades. Supongamos que cada cadena se denota por \\(\\theta_m\\), para \\(M\\) cadenas, y las iteraciones de cada cadena son \\(\\theta_m^{(i)}\\) para \\(i=1,\\ldots, N\\) iteraciones. Definimos (ver el manual de Stan o Brooks et al. (2011) por ejemplo) primero la varianza entre cadenas, que es (ojo: usaremos definiciones aproximadas para entender más fácilmente):\n\\[b=\\frac{1}{M-1}\\sum_{m=1}^M (\\bar{\\theta}_m - \\bar{\\theta})^2\\] donde \\(\\bar{\\theta}_m\\) es el promedio de las iteraciones de la cadena \\(m\\), y \\(\\bar{\\theta}\\) es el promedio del las \\(\\bar{\\theta}_m\\).\nDefinimos también la varianza dentro de las cadenas, que es el promedio de la varianza de cada cadena:\n\\[w=\\frac{1}{M}\\sum_{m=1}^M \\frac{1}{N}\\sum_{i=1}^N (\\theta_m^{(i)} - \\bar{\\theta}_m)^2\\] Finalmente, la \\(R\\)-hat, o estadística de potencial de reducción de escala, es (para \\(N\\) grande),\n\\[\\hat{R} = \\sqrt{\\frac{b+w}{w}}\\]\nBuscamos entonces que este valor sea cercano a 1. Si es mayor a 1.05, es señal de posibles problemas de convergencia (pocas iteraciones u otras fallas en la convergencia). Si es menor que 1.01, generalmente decimos que “pasamos” esta prueba. Esto no es garantía de que la convergencia se ha alcanzado: la primera razón es que este diagnóstico, por ejemplo, sólo considera media y varianza, de forma que en principio podríamos pasar esta prueba aún cuando las cadenas tengan comportamiento distinto en otras estadísticas de orden más alto (por ejemplo, una cadena que oscila poco y de vez en cuando salta a un atípico vs otra que tiene variación moderada pueden ser similares en medias y varianzas).\nEn Stan, adicionalmente, se divide cada cadena en dos mitades, y el análisis se hace sobre \\(2M\\) medias cadenas. Esto ayuda a detectar por ejemplo problemas donde una cadena sube y luego baja, por ejemplo, de modo que puede tener el mismo promedio que otras que exploran correctamente.\nNota: Estas fórmulas pretenden explicar de manera simple el concepto de \\(R\\)-hat, y son correctas para \\(N\\) grande, lo cual casi siempre es el caso (al menos \\(N\\geq 100\\)). Puedes consultar una definición más estándar con correcciones por grados de libertad en el manual de Stan o cualquier libro de MCMC.\n\n\n\n\n\n\nDiagnóstico de R-hat\n\n\n\nEl diagnóstico de R-hat compara la varianza dentro de las cadenas y de cadena a cadena. Cuando este valor es relativamente grande (por ejemplo mayor a 1.05), es señal de que las cadenas no han explorado apropiadamente el espacio de parámetros (o decimos que no están “mezclando”). En general, buscamos que este valor sea menor a 1.02.\nSe llama también potencial de reducción a escala porque busca indicar cuánto se podría reducir la varianza de la distribución actual si dejáramos correr las cadenas por más iteraciones (pues a largo plazo no debe haber varianza entre cadenas).\n\n\nEn nuestro ejemplo apropiado, observamos valores muy cercanos a 1 para todos los parámetros:\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, ess_bulk, ess_tail) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483\n\n\n\n\n\n\n\n\nEn nuestro ejemplo “malo”, obtenemos valores no aceptabels de R-hat para varios parámetros.\n\najuste_vinos_malo$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, ess_bulk, ess_tail) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n-0.167\n0.345\n-0.538\n0.427\n2.367\n5.335\n4.502\n\n\nQ[2]\n-0.012\n0.289\n-0.306\n0.556\n1.633\n7.010\n4.670\n\n\nQ[3]\n0.226\n0.246\n-0.188\n0.596\n1.379\n9.802\n14.937\n\n\nQ[4]\n0.651\n0.385\n0.032\n1.088\n1.596\n7.207\n12.047\n\n\nQ[5]\n-0.173\n0.253\n-0.547\n0.191\n1.441\n8.933\n58.601\n\n\nQ[6]\n-0.387\n0.626\n-1.277\n0.704\n2.367\n5.372\n4.348\n\n\nQ[7]\n0.084\n0.364\n-0.291\n0.812\n1.340\n10.165\n27.683\n\n\nQ[8]\n0.272\n0.254\n-0.180\n0.558\n1.372\n9.580\n18.466\n\n\nQ[9]\n-0.117\n0.188\n-0.377\n0.247\n1.689\n13.208\n30.165\n\n\nQ[10]\n0.004\n0.347\n-0.460\n0.496\n1.557\n7.600\n25.190\n\n\nQ[11]\n0.068\n0.618\n-1.137\n0.840\n2.724\n5.072\n7.003\n\n\nQ[12]\n0.119\n0.270\n-0.245\n0.625\n1.237\n14.834\n42.161\n\n\nQ[13]\n0.089\n0.491\n-0.489\n1.235\n1.868\n6.388\n28.327\n\n\nQ[14]\n0.172\n0.736\n-0.780\n1.299\n2.064\n5.741\n18.739\n\n\nQ[15]\n0.082\n0.407\n-0.491\n0.605\n2.109\n5.718\n17.270\n\n\nQ[16]\n-0.055\n0.339\n-0.548\n0.394\n1.711\n6.843\n25.826\n\n\nQ[17]\n0.104\n0.310\n-0.444\n0.502\n1.811\n6.325\n20.519\n\n\nQ[18]\n-0.562\n0.429\n-1.076\n0.479\n1.959\n6.022\n28.327\n\n\nQ[19]\n-0.162\n0.281\n-0.600\n0.248\n1.561\n7.410\n41.928\n\n\nQ[20]\n0.122\n0.737\n-1.036\n0.922\n1.949\n6.030\n4.348\n\n\nsigma\n0.958\n0.239\n0.751\n1.092\n1.571\n7.369\n8.522\n\n\n\n\n\n\n\n\nNota: si algunos parámetros tienen valores R-hat cercanos a 1 pero otros no, en general no podemos confiar en los resultados de las simulaciones. Esto es señal de problemas de convergencia y deben ser diagnosticados.\n\n\n8.3.3 Diagnóstico: Tamaño de muestra efectivo\nLas simulaciones de MCMC típicamente están autocorrelacionadas (pues comenzamos en una región y muchas veces nos movemos poco). Esto significa que la cantidad de información de \\(N\\) simulaciones MCMC no es la misma que la que obtendríamos con \\(N\\) simulaciones independientes de la posterior.\nEste concepto también se usa en muestreo: por ejemplo, existe menos información en una muestra de 100 personas que fueron muestreadas por conglomerados de 50 casas (por ejemplo, seleccionando al azar hogares y luego a dos adultos dentro de cada hogar) que seleccionar 100 hogares y escoger a un al azar un adulto de cada hogar. La segunda muestra tienen más información de la población, pues en la primera muestra parte de la información es “compartida” por el hecho de vivir en el mismo hogar. Para encontrar un número “efectivo” de muestra que haga comparables estos dos diseños, comparamos la varianza que obtendríamos del estimador de interes en cada caso. Si consideramos como base el segundo diseño (muestro aleatorio independiente), el primer diseño tendrá más varianza. Eso quiere decir que para que hubiera la misma varianza en los dos diseños, bastaría una muestra más chica (digamos 60 hogares) del segundo diseño independiente. Decimos que el tamaño efectivo de muestra del primer diseño es de 60 personas (el caso donde las varianzas de los dos diseños son iguales).\nEn el caso de series de tiempo, tenemos que considerar autocorrelación en la serie. Supongamos que quisiéramos estimar la media de una serie de tiempo (suponemos que a largo plazo el promedio de la serie de tiempo es una constante finita). Una muestra con autocorrelación alta produce malos estimadores de esta media incluso para tamaños de muestra relativamente grande:\n\nset.seed(123)\nmu_verdadera <- 10\nsimular_series <- function(T = 500, num_series = 100, ar = 0.9){\n map_df(1:num_series, function(rep){\n serie <- 10 + arima.sim(n = T, list(ar = ar), n.start = 200, sd = sqrt(1-ar^2))\n tibble(t = 1:T, serie = serie, serie_id = rep, ar = ar)\n })\n}\nseries_1_tbl <- simular_series(T= 200, n = 4, ar = 0.80)\nseries_2_tbl <- simular_series(T= 200, n = 4, ar = 0.00001)\nseries_tbl <- bind_rows(series_1_tbl, series_2_tbl)\nseries_tbl |> \n ggplot(aes(t, serie, group = serie_id, colour = factor(serie_id))) + \n geom_line(alpha = 0.9) + \n geom_hline(yintercept = mu_verdadera, linetype = 2) + \n facet_wrap(~ar, ncol = 1)\n\n\n\n\n\n\n\n\nCalculamos las medias para un ejemplo con autocorrelación y otro sin ellas:\n\nseries_95_tbl <- simular_series(T= 300, n = 500, ar = 0.80) \nseries_05_tbl <- simular_series(T= 300, n = 500, ar = 0.00001) \nseries_tbl <- bind_rows(series_95_tbl, series_05_tbl)\nseries_tbl |> group_by(serie_id, ar) |> \n summarise(media = mean(serie)) |> \n ggplot(aes(media)) + geom_histogram() + \n geom_vline(xintercept = mu_verdadera, linetype = 2) + \n labs(title = \"Distribución de medias de series de tiempo\") +\n facet_wrap(~ar)\n\n`summarise()` has grouped output by 'serie_id'. You can override using the\n`.groups` argument.\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nY vemos que la precisión de la estimación cuando la correlación es relativamente baja es mucho más alta que cuando la correlación es alta. ¿Cuál es el tamaño efectivo de muestra para series con autocorrelación ar= 0.8? Vemos que es aproximadamente 35, o dicho de otra manera, la serie sin correlación nos da casi 10 veces más información por observación que la correlacionada:\n\nseries_95_tbl <- simular_series(T= 300, n = 1000, ar = 0.8) \nseries_05_tbl <- simular_series(T= 35, n = 1000, ar = 0.00001) \nseries_tbl <- bind_rows(series_95_tbl, series_05_tbl)\nseries_tbl |> group_by(serie_id, ar) |> \n summarise(media = mean(serie)) |> \n ggplot(aes(media)) + geom_histogram() + \n geom_vline(xintercept = mu_verdadera, linetype = 2) + \n labs(title = \"Distribución de medias de series de tiempo\") +\n facet_wrap(~ar)\n\n`summarise()` has grouped output by 'serie_id'. You can override using the\n`.groups` argument.\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nEs posible hacer una estimación teórica del tamaño efectivo de muestra. Para esto, podemos notar que la varianza del promedio de una serie de tiempo depende de la estructura de autocorrelación. Supondremos que la serie de tiempo es estacionaria y cada \\(y_t\\) tiene varianza \\(\\sigma^2\\) y correlación \\(\\rho\\) con \\(y_{t-1}\\). Entonces:\n\\[Var(\\bar{y})=\\frac{1}{n^2}\\text{Var} \\left(\\sum_{t=1}^n y_t \\right) =\n\\frac{n\\sigma^2}{n^2}\\sum_{t=1}^n \\text{Var}(y_t) + \\frac{2\\sigma^2}{n^2}\\sum_{t=1}^{n-1}\\sum_{s=t+1}^n\\text{Corr}(y_t, y_s)\\]\nQue se simplifica a (para \\(n\\) grande):\n\\[\\text{Var}(\\bar{y}) = \\frac{\\sigma^2}{n} + \\frac{2\\sigma^2}{n}\\sum_{h=1}^{n-1}(1-h/n)\\rho_{h} \\approx \\frac{\\sigma^2}{n}\\left (1+2\\sum_{h=1}^{n-1}\\rho_t\\right )\\] Si suponemos \\(\\rho_h = \\text{corr}(y_t, y_{t+h})\\) para cualquier \\(t\\). En nuestro caso anterior, el factor de corrección es aproximadamente:\n\n1 + 2*(0.8)^(1:1000) |> sum()\n\n[1] 9\n\n\n\n\n\n\n\n\nTamaño efectivo de muestra\n\n\n\nSi hacemos \\(N\\) iteraciones en una cadena estacionaria con función de autocorrelación \\(\\rho_h\\), el tamaño efectivo de muestra teórico se define como\n\\[N_{eff} = \\frac{N}{1 + 2\\sum_{h=1}^{\\infty}\\rho_h}\\]\nSi pudiéramos hacer simulaciones independientes de la posterior, \\(N_{eff}\\) es el tamaño de muestra requerido para obtener la misma información que la cadena autocorrelacionada de tamaño \\(N\\). Usualmente, aunque no siempre, \\(N_{eff}<N\\) para cadenas de MCMC.\n\n\nObservaciones:\n\nEsta es una definición teórica para entender el concepto. Para ver cómo se estima en la práctica puedes consultar el manual de Stan o (Brooks et al. 2011).\nEn algunos muestreadores que dan pasos cortos como en los ejemplos de Metropolis-Hastings que vimos, a veces es necesario hacer cientos de miles de iteraciones para obtener un tamaño efectivo de muestra apropiado para hacer inferencia. Stan generalmente obtiene tamaños efectivos de muestra mucho más altos con menos iteraciones (aunque cada iteración es más costosa).\nConsiderando experiencia y teoría, tamaños efectivos de muestra mínimos se considera de 400 o más (ver aquí).\n\nEn nuestro ejemplo, tenemos tamaños de muestra efectivos satisfactorios:\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483\n\n\n\n\n\n\n\n\n\nNótese que versiones más recientes de Stan reportan dos tamaños efectivos de muestra (ESS), uno para cantidades que dependen del centro de la distribución, como la media y mediana (bulk ESS, que es similar a la definición que vimos arriba, pero usando valores normalizados por rango), y otro para cantidades que dependen de las colas, como percentiles extremos (tail ESS, que estima el tamaño de muestra efectivo para los percentiles 5% y 95% ). En este caso, ambos son altos.\n\nFinalmente, podemos checar el error montecarlo, que es error de estimación usual\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483", + "text": "8.3 Diagnósticos de convergencia\nAunque casi nunca es posible demostrar rigurosamente que las simulaciones de un algoritmo MCMC dan buena aproximación de la distribución posterior de interés, especialmente con HMC y NUTS, tenemos muchos diagnósticos que fallan cuando existen problemas serios.\nEn primer lugar, será útil correr distintas cadenas con valores iniciales aleatorios diferentes, analizamos cada una y las comparamos entre sí. Recordamos que cada una de estas cadenas tiene como distribución estacionaria límite la distribución posterior. Diagnósticos que indican que las cadenas se comportan de manera muy distinta, explorando distintas regiones del espacio de parámetros, o que no han convergido porque exploran lentamente el espacio de parámetros, son señales de problemas.\nLos diagnósticos más comunes son:\n\nTraza de cadenas\nMedida R-hat de convergencia: mide la variabilidad entre cadenas y dentro de cadenas.\nNúmero de muestras efectivas (ESS) y autocorrelación.\nTransiciones divergentes.\n\n\nModelos con variables latentes\nVeremos el ejemplo de calificación de vinos de distintos países de McElreath (2020), sus diagnósticos, y aprovecharemos para introducir variables no observadas o latentes para enriquecer nuestras herramientas de modelación.\nNuestra pregunta general es si el país de origen de los vinos influye en su calidad. Los datos que tenemos son calificaciones de vinos de distintos países por distintos jueces. La calidad del vino no la observamos directamente, sino que es causa de las calificaciones que recibe. Para construir nuestro diagrama, las consideraciones básicas son:\n\nEl origen del vino es una causa del calidad del vino (es nuestra cantidad a estimar).\nLos jueces tienen distintas maneras de calificar, de manera que son causa de variación en las calificaciones (hay jueces más duros, otros más barcos, etc.) No observamos directamente que tan “duro” es cada juez.\nLos jueces califican vinos de distintos países de manera ciega. Sin embargo es posible que reconozcan el país de origen por las características de los vinos, de manera que puede existir un efecto directo de Origen en Calificación (no pasa por Calidad).\nEs posible que Jueces de distintos países tienen distintos estándares de calificación.\n\n\n\nCódigo\nlibrary(DiagrammeR)\ngrViz(\"\ndigraph {\n graph [ranksep = 0.2, rankdir = LR]\n node [shape=plaintext]\n Origen\n Score\n Origen_Juez\n node [shape = circle]\n Q\n J\n edge [minlen = 3]\n Origen -> Q\n Origen -> Score\n Q -> Score\n J -> Score\n Origen_Juez -> J\n}\n\")\n\n\n\n\n\n\nY vemos, por nuestro análisis del DAG, que podemos identificar el efecto de Origen sobre Calidad sin necesidad de estratificar por ninguna variable (no hay puertas traseras). Sin embaergo, podemos estratificar por Juez para obtener más precisión (ver sección anterior de buenos y malos controles).\n\n8.3.0.1 Primera iteración: modelo simple\nComenzamos con un modelo simple, y lo iremos construyendo para obtener la mejor estimación posible de la influencia del país de origen en la calidad del vino. Nuestro primer modelo consideramos que la calificación de cada vino depende de su calidad, y modelamos con una normal:\n\\[S_i \\sim \\text{Normal}(\\mu_i, \\sigma)\\] donde \\[\\mu_i = Q_{vino(i)}\\]. Nuestra medida de calidad tiene escala arbitaria. Como usaremos la calificación estandarizada, podemos poner \\[Q_j \\sim \\text{Normal}(0, 1).\\] finalmente, ponemos una inicial para \\(\\sigma\\), por ejemplo \\(\\sigma \\sim \\text{Exponential}(1)\\) (puedes experimentar con una normal truncada también)\n\nlibrary(cmdstanr)\n\nThis is cmdstanr version 0.7.1\n\n\n- CmdStanR documentation and vignettes: mc-stan.org/cmdstanr\n\n\n- CmdStan path: /home/runner/.cmdstan/cmdstan-2.34.0\n\n\n- CmdStan version: 2.34.0\n\n\n\nA newer version of CmdStan is available. See ?install_cmdstan() to install it.\nTo disable this check set option or environment variable CMDSTANR_NO_VER_CHECK=TRUE.\n\nmod_vinos_1 <- cmdstan_model(\"./src/vinos-1.stan\")\nprint(mod_vinos_1)\n\ndata {\n int<lower=0> N; //número de calificaciones\n int<lower=0> n_vinos; //número de vinos\n int<lower=0> n_jueces; //número de jueces\n vector[N] S;\n array[N] int juez;\n array[N] int vino;\n}\n\nparameters {\n vector[n_vinos] Q;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] media_score;\n // determinístico dado parámetros\n for (i in 1:N){\n media_score[i] = Q[vino[i]];\n }\n}\n\nmodel {\n // partes no determinísticas\n S ~ normal(media_score, sigma);\n Q ~ std_normal();\n sigma ~ exponential(1);\n}\n\n\n\n# Wines 2022 de Statistical Rethinking\nwines_2012 <- read_csv(\"../datos/wines_2012.csv\")\n\nRows: 180 Columns: 6\n── Column specification ────────────────────────────────────────────────────────\nDelimiter: \",\"\nchr (3): judge, flight, wine\ndbl (3): score, wine.amer, judge.amer\n\nℹ Use `spec()` to retrieve the full column specification for this data.\nℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.\n\nglimpse(wines_2012)\n\nRows: 180\nColumns: 6\n$ judge <chr> \"Jean-M Cardebat\", \"Jean-M Cardebat\", \"Jean-M Cardebat\", \"J…\n$ flight <chr> \"white\", \"white\", \"white\", \"white\", \"white\", \"white\", \"whit…\n$ wine <chr> \"A1\", \"B1\", \"C1\", \"D1\", \"E1\", \"F1\", \"G1\", \"H1\", \"I1\", \"J1\",…\n$ score <dbl> 10.0, 13.0, 14.0, 15.0, 8.0, 13.0, 15.0, 11.0, 9.0, 12.0, 1…\n$ wine.amer <dbl> 1, 1, 0, 0, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 0, 1, 0,…\n$ judge.amer <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,…\n\nwines_2012 <- wines_2012 |> \n mutate(juez_num = as.numeric(factor(judge)),\n vino_num = as.numeric(factor(wine))) |> \n mutate(score_est = (score - mean(score))/sd(score))\n\n\nn_jueces <- length(unique(wines_2012$juez_num))\nn_vinos <- length(unique(wines_2012$vino_num))\nc(\"num_vinos\" = n_jueces, \"num_jueces\" = n_vinos, \"num_datos\" = nrow(wines_2012))\n\n num_vinos num_jueces num_datos \n 9 20 180 \n\n\n\ndatos_lst <- list(\n N = nrow(wines_2012),\n n_vinos = n_vinos,\n n_jueces = n_jueces,\n S = wines_2012$score_est,\n vino = wines_2012$vino_num,\n juez = wines_2012$juez_num\n)\najuste_vinos_1 <- mod_vinos_1$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 1000,\n iter_sampling = 2000,\n refresh = 1000,\n step_size = 0.1,\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 1 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 1 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 2 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 2 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 3 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 3 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 3 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 4 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 4 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 1 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 1 finished in 0.3 seconds.\nChain 2 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 3 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 4 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 2 finished in 0.4 seconds.\nChain 3 finished in 0.4 seconds.\nChain 4 finished in 0.4 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.4 seconds.\nTotal execution time: 0.6 seconds.\n\n\nVemos que hay variabilidad en los vinos:\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, ess_bulk, ess_tail) |> \n filter(variable != \"lp__\") |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483\n\n\n\n\n\n\n\n\n\n\n\n8.3.1 Diagnóstico: Trazas de cadenas\nPara hacer diagnósticos, podemos comenzar con las trazas de una cadena para todas las estimaciones de calidad de vino. Cada cadena se inicia con distintos valores aleatorios, pero cumplen en teoría que su distribución de equilibrio es la posterior de interés pues sus transiciones usan el mismo mecanismo.\n\nlibrary(bayesplot)\nmcmc_trace(ajuste_vinos_1$draws(\"Q\", format = \"df\") |> filter(.chain == 1))\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nTip\n\n\n\nLa traza de una cadena es la gráfica de las simulaciones de cada parámetro. Generalmente buscamos que: no tenga tendencia, que no se quede “atorada” en algunos valores, y que no muestre oscilaciones de baja frecuencia (la cadena “vaga” por los valores que explora).\n\n\nSi incluímos todas las cadenas, nos fijemos en que todas ellas exploren regiones similares del espacio de parámetros:\n\ncolor_scheme_set(\"viridis\")\nmcmc_trace(ajuste_vinos_1$draws(\"Q\", format = \"df\")) \n\n\n\n\n\n\n\n\nLo que no queremos ver es lo siguiente, por ejemplo:\n\najuste_vinos_malo <- mod_vinos_1$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 5,\n iter_sampling = 100,\n refresh = 1000,\n step_size =1 ,\n seed = 123\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 WARNING: No variance estimation is \nChain 1 performed for num_warmup < 20 \nChain 1 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 1 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 1 Iteration: 105 / 105 [100%] (Sampling) \nChain 2 WARNING: No variance estimation is \nChain 2 performed for num_warmup < 20 \nChain 2 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 2 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 2 Iteration: 105 / 105 [100%] (Sampling) \nChain 3 WARNING: No variance estimation is \nChain 3 performed for num_warmup < 20 \nChain 3 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 3 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 3 Iteration: 105 / 105 [100%] (Sampling) \n\n\nChain 3 Informational Message: The current Metropolis proposal is about to be rejected because of the following issue:\n\n\nChain 3 Exception: normal_lpdf: Scale parameter is 0, but must be positive! (in '/tmp/RtmpSzeTvI/model-28032f01014c.stan', line 25, column 2 to column 33)\n\n\nChain 3 If this warning occurs sporadically, such as for highly constrained variable types like covariance matrices, then the sampler is fine,\n\n\nChain 3 but if this warning occurs often then your model may be either severely ill-conditioned or misspecified.\n\n\nChain 3 \n\n\nChain 4 WARNING: No variance estimation is \nChain 4 performed for num_warmup < 20 \nChain 4 Iteration: 1 / 105 [ 0%] (Warmup) \nChain 4 Iteration: 6 / 105 [ 5%] (Sampling) \nChain 4 Iteration: 105 / 105 [100%] (Sampling) \nChain 1 finished in 0.0 seconds.\nChain 2 finished in 0.0 seconds.\nChain 3 finished in 0.0 seconds.\nChain 4 finished in 0.0 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.0 seconds.\nTotal execution time: 0.2 seconds.\n\n\nWarning: 324 of 400 (81.0%) transitions ended with a divergence.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 2 of 4 chains had an E-BFMI less than 0.3.\nSee https://mc-stan.org/misc/warnings for details.\n\n\n\ncolor_scheme_set(\"viridisA\")\nmcmc_trace(ajuste_vinos_malo$draws(\"Q\", format = \"df\")) \n\n\n\n\n\n\n\n\nHay varios problemas graves:\n\nAlgunas cadenas parecen “atoradas” en ciertos valores\nAlgunas cadenas parecen caminatas aleatorias (oscilaciones de baja frecuencia)\nLas cadenas no exploran de manera similar el espacio de parámetros\n\n\n\n\n\n\n\nTraza de cadenas\n\n\n\nEl diagnóstico de traza consiste en graficar las cadenas de los parámetros en el orden de la iteración. Buscamos ver que:\n\nLas cadenas no tienen tendencia o oscilaciones de frecuencia muy baja.\nLas cadenas no se atoran en valores específicos.\nLas distintas cadenas exploran de manera similar el espacio de parámetros.\n\nCuando falla alguna de estas, en el mejor de los casos las cadenas son ineficientes (veremos que requerimos un número mucho mayor de iteraciones), y en el peor de los casos dan resultados sesgados que no son confiables.\n\n\n\n\n8.3.2 Diagnóstico: valores R-hat\nCuando nuestro método de simulación converge a la distribución posterior, esperamos que las cadenas, durante todo su proceso, exploran la misma región del espacio de parámetros.\nPodemos entonces considerar, para cada parámetro:\n\nCuánta variación hay en cada cadena.\nQué tan distintas son las cadenas entre ellas.\n\nEsperamos que la variación entre cadenas es chica, y la variación dentro de cada cadena es similar para todas las cadenas. Calculamos entonces un cociente de varianzas: la varianza total sobre todas las simulaciones de todas las cadenas, y el promedio de varianzas de las cadenas. Si las cadenas están explorando regiones similares, esperamos que este cociente de varianzas sea cercano a 1.\nEscribiremos ahora esta idea para entender cómo se calculan estas cantidades. Supongamos que cada cadena se denota por \\(\\theta_m\\), para \\(M\\) cadenas, y las iteraciones de cada cadena son \\(\\theta_m^{(i)}\\) para \\(i=1,\\ldots, N\\) iteraciones. Definimos (ver el manual de Stan o Brooks et al. (2011) por ejemplo) primero la varianza entre cadenas, que es (ojo: usaremos definiciones aproximadas para entender más fácilmente):\n\\[b=\\frac{1}{M-1}\\sum_{m=1}^M (\\bar{\\theta}_m - \\bar{\\theta})^2\\] donde \\(\\bar{\\theta}_m\\) es el promedio de las iteraciones de la cadena \\(m\\), y \\(\\bar{\\theta}\\) es el promedio del las \\(\\bar{\\theta}_m\\).\nDefinimos también la varianza dentro de las cadenas, que es el promedio de la varianza de cada cadena:\n\\[w=\\frac{1}{M}\\sum_{m=1}^M \\frac{1}{N}\\sum_{i=1}^N (\\theta_m^{(i)} - \\bar{\\theta}_m)^2\\] Finalmente, la \\(R\\)-hat, o estadística de potencial de reducción de escala, es (para \\(N\\) grande),\n\\[\\hat{R} = \\sqrt{\\frac{b+w}{w}}\\]\nBuscamos entonces que este valor sea cercano a 1. Si es mayor a 1.05, es señal de posibles problemas de convergencia (pocas iteraciones u otras fallas en la convergencia). Si es menor que 1.01, generalmente decimos que “pasamos” esta prueba. Esto no es garantía de que la convergencia se ha alcanzado: la primera razón es que este diagnóstico, por ejemplo, sólo considera media y varianza, de forma que en principio podríamos pasar esta prueba aún cuando las cadenas tengan comportamiento distinto en otras estadísticas de orden más alto (por ejemplo, una cadena que oscila poco y de vez en cuando salta a un atípico vs otra que tiene variación moderada pueden ser similares en medias y varianzas).\nEn Stan, adicionalmente, se divide cada cadena en dos mitades, y el análisis se hace sobre \\(2M\\) medias cadenas. Esto ayuda a detectar por ejemplo problemas donde una cadena sube y luego baja, por ejemplo, de modo que puede tener el mismo promedio que otras que exploran correctamente.\nNota: Estas fórmulas pretenden explicar de manera simple el concepto de \\(R\\)-hat, y son correctas para \\(N\\) grande, lo cual casi siempre es el caso (al menos \\(N\\geq 100\\)). Puedes consultar una definición más estándar con correcciones por grados de libertad en el manual de Stan o cualquier libro de MCMC.\n\n\n\n\n\n\nDiagnóstico de R-hat\n\n\n\nEl diagnóstico de R-hat compara la varianza dentro de las cadenas y de cadena a cadena. Cuando este valor es relativamente grande (por ejemplo mayor a 1.05), es señal de que las cadenas no han explorado apropiadamente el espacio de parámetros (o decimos que no están “mezclando”). En general, buscamos que este valor sea menor a 1.02.\nSe llama también potencial de reducción a escala porque busca indicar cuánto se podría reducir la varianza de la distribución actual si dejáramos correr las cadenas por más iteraciones (pues a largo plazo no debe haber varianza entre cadenas).\n\n\nEn nuestro ejemplo apropiado, observamos valores muy cercanos a 1 para todos los parámetros:\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, ess_bulk, ess_tail) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483\n\n\n\n\n\n\n\n\nEn nuestro ejemplo “malo”, obtenemos valores no aceptabels de R-hat para varios parámetros.\n\najuste_vinos_malo$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, ess_bulk, ess_tail) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n-0.167\n0.345\n-0.538\n0.427\n2.367\n5.335\n4.502\n\n\nQ[2]\n-0.012\n0.289\n-0.306\n0.556\n1.633\n7.010\n4.670\n\n\nQ[3]\n0.226\n0.246\n-0.188\n0.596\n1.379\n9.802\n14.937\n\n\nQ[4]\n0.651\n0.385\n0.032\n1.088\n1.596\n7.207\n12.047\n\n\nQ[5]\n-0.173\n0.253\n-0.547\n0.191\n1.441\n8.933\n58.601\n\n\nQ[6]\n-0.387\n0.626\n-1.277\n0.704\n2.367\n5.372\n4.348\n\n\nQ[7]\n0.084\n0.364\n-0.291\n0.812\n1.340\n10.165\n27.683\n\n\nQ[8]\n0.272\n0.254\n-0.180\n0.558\n1.372\n9.580\n18.466\n\n\nQ[9]\n-0.117\n0.188\n-0.377\n0.247\n1.689\n13.208\n30.165\n\n\nQ[10]\n0.004\n0.347\n-0.460\n0.496\n1.557\n7.600\n25.190\n\n\nQ[11]\n0.068\n0.618\n-1.137\n0.840\n2.724\n5.072\n7.003\n\n\nQ[12]\n0.119\n0.270\n-0.245\n0.625\n1.237\n14.834\n42.161\n\n\nQ[13]\n0.089\n0.491\n-0.489\n1.235\n1.868\n6.388\n28.327\n\n\nQ[14]\n0.172\n0.736\n-0.780\n1.299\n2.064\n5.741\n18.739\n\n\nQ[15]\n0.082\n0.407\n-0.491\n0.605\n2.109\n5.718\n17.270\n\n\nQ[16]\n-0.055\n0.339\n-0.548\n0.394\n1.711\n6.843\n25.826\n\n\nQ[17]\n0.104\n0.310\n-0.444\n0.502\n1.811\n6.325\n20.519\n\n\nQ[18]\n-0.562\n0.429\n-1.076\n0.479\n1.959\n6.022\n28.327\n\n\nQ[19]\n-0.162\n0.281\n-0.600\n0.248\n1.561\n7.410\n41.928\n\n\nQ[20]\n0.122\n0.737\n-1.036\n0.922\n1.949\n6.030\n4.348\n\n\nsigma\n0.958\n0.239\n0.751\n1.092\n1.571\n7.369\n8.522\n\n\n\n\n\n\n\n\nNota: si algunos parámetros tienen valores R-hat cercanos a 1 pero otros no, en general no podemos confiar en los resultados de las simulaciones. Esto es señal de problemas de convergencia y deben ser diagnosticados.\n\n\n8.3.3 Diagnóstico: Tamaño de muestra efectivo\nLas simulaciones de MCMC típicamente están autocorrelacionadas (pues comenzamos en una región y muchas veces nos movemos poco). Esto significa que la cantidad de información de \\(N\\) simulaciones MCMC no es la misma que la que obtendríamos con \\(N\\) simulaciones independientes de la posterior.\nEste concepto también se usa en muestreo: por ejemplo, existe menos información en una muestra de 100 personas que fueron muestreadas por conglomerados de 50 casas (por ejemplo, seleccionando al azar hogares y luego a dos adultos dentro de cada hogar) que seleccionar 100 hogares y escoger a un al azar un adulto de cada hogar. La segunda muestra tienen más información de la población, pues en la primera muestra parte de la información es “compartida” por el hecho de vivir en el mismo hogar. Para encontrar un número “efectivo” de muestra que haga comparables estos dos diseños, comparamos la varianza que obtendríamos del estimador de interes en cada caso. Si consideramos como base el segundo diseño (muestro aleatorio independiente), el primer diseño tendrá más varianza. Eso quiere decir que para que hubiera la misma varianza en los dos diseños, bastaría una muestra más chica (digamos 60 hogares) del segundo diseño independiente. Decimos que el tamaño efectivo de muestra del primer diseño es de 60 personas (el caso donde las varianzas de los dos diseños son iguales).\nEn el caso de series de tiempo, tenemos que considerar autocorrelación en la serie. Supongamos que quisiéramos estimar la media de una serie de tiempo (suponemos que a largo plazo el promedio de la serie de tiempo es una constante finita). Una muestra con autocorrelación alta produce malos estimadores de esta media incluso para tamaños de muestra relativamente grande:\n\nset.seed(123)\nmu_verdadera <- 10\nsimular_series <- function(T = 500, num_series = 100, ar = 0.9){\n map_df(1:num_series, function(rep){\n serie <- 10 + arima.sim(n = T, list(ar = ar), n.start = 200, sd = sqrt(1-ar^2))\n tibble(t = 1:T, serie = serie, serie_id = rep, ar = ar)\n })\n}\nseries_1_tbl <- simular_series(T= 200, n = 4, ar = 0.80)\nseries_2_tbl <- simular_series(T= 200, n = 4, ar = 0.00001)\nseries_tbl <- bind_rows(series_1_tbl, series_2_tbl)\nseries_tbl |> \n ggplot(aes(t, serie, group = serie_id, colour = factor(serie_id))) + \n geom_line(alpha = 0.9) + \n geom_hline(yintercept = mu_verdadera, linetype = 2) + \n facet_wrap(~ar, ncol = 1)\n\n\n\n\n\n\n\n\nCalculamos las medias para un ejemplo con autocorrelación y otro sin ellas:\n\nseries_95_tbl <- simular_series(T= 300, n = 500, ar = 0.80) \nseries_05_tbl <- simular_series(T= 300, n = 500, ar = 0.00001) \nseries_tbl <- bind_rows(series_95_tbl, series_05_tbl)\nseries_tbl |> group_by(serie_id, ar) |> \n summarise(media = mean(serie)) |> \n ggplot(aes(media)) + geom_histogram() + \n geom_vline(xintercept = mu_verdadera, linetype = 2) + \n labs(title = \"Distribución de medias de series de tiempo\") +\n facet_wrap(~ar)\n\n`summarise()` has grouped output by 'serie_id'. You can override using the\n`.groups` argument.\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nY vemos que la precisión de la estimación cuando la correlación es relativamente baja es mucho más alta que cuando la correlación es alta. ¿Cuál es el tamaño efectivo de muestra para series con autocorrelación ar= 0.8? Vemos que es aproximadamente 35, o dicho de otra manera, la serie sin correlación nos da casi 10 veces más información por observación que la correlacionada:\n\nseries_95_tbl <- simular_series(T= 300, n = 1000, ar = 0.8) \nseries_05_tbl <- simular_series(T= 35, n = 1000, ar = 0.00001) \nseries_tbl <- bind_rows(series_95_tbl, series_05_tbl)\nseries_tbl |> group_by(serie_id, ar) |> \n summarise(media = mean(serie)) |> \n ggplot(aes(media)) + geom_histogram() + \n geom_vline(xintercept = mu_verdadera, linetype = 2) + \n labs(title = \"Distribución de medias de series de tiempo\") +\n facet_wrap(~ar)\n\n`summarise()` has grouped output by 'serie_id'. You can override using the\n`.groups` argument.\n`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.\n\n\n\n\n\n\n\n\n\nEs posible hacer una estimación teórica del tamaño efectivo de muestra. Para esto, podemos notar que la varianza del promedio de una serie de tiempo depende de la estructura de autocorrelación. Supondremos que la serie de tiempo es estacionaria y cada \\(y_t\\) tiene varianza \\(\\sigma^2\\) y correlación \\(\\rho\\) con \\(y_{t-1}\\). Entonces:\n\\[Var(\\bar{y})=\\frac{1}{n^2}\\text{Var} \\left(\\sum_{t=1}^n y_t \\right) =\n\\frac{n\\sigma^2}{n^2}\\sum_{t=1}^n \\text{Var}(y_t) + \\frac{2\\sigma^2}{n^2}\\sum_{t=1}^{n-1}\\sum_{s=t+1}^n\\text{Corr}(y_t, y_s)\\]\nQue se simplifica a (para \\(n\\) grande):\n\\[\\text{Var}(\\bar{y}) = \\frac{\\sigma^2}{n} + \\frac{2\\sigma^2}{n}\\sum_{h=1}^{n-1}(1-h/n)\\rho_{h} \\approx \\frac{\\sigma^2}{n}\\left (1+2\\sum_{h=1}^{n-1}\\rho_t\\right )\\] Si suponemos \\(\\rho_h = \\text{corr}(y_t, y_{t+h})\\) para cualquier \\(t\\). En nuestro caso anterior, el factor de corrección es aproximadamente:\n\n1 + 2*(0.8)^(1:1000) |> sum()\n\n[1] 9\n\n\n\n\n\n\n\n\nTamaño efectivo de muestra\n\n\n\nSi hacemos \\(N\\) iteraciones en una cadena estacionaria con función de autocorrelación \\(\\rho_h\\), el tamaño efectivo de muestra teórico se define como\n\\[N_{eff} = \\frac{N}{1 + 2\\sum_{h=1}^{\\infty}\\rho_h}\\]\nSi pudiéramos hacer simulaciones independientes de la posterior, \\(N_{eff}\\) es el tamaño de muestra requerido para obtener la misma información que la cadena autocorrelacionada de tamaño \\(N\\). Usualmente, aunque no siempre, \\(N_{eff}<N\\) para cadenas de MCMC.\n\n\nObservaciones:\n\nEsta es una definición teórica para entender el concepto. Para ver cómo se estima en la práctica puedes consultar el manual de Stan o (Brooks et al. 2011).\nEn algunos muestreadores que dan pasos cortos como en los ejemplos de Metropolis-Hastings que vimos, a veces es necesario hacer cientos de miles de iteraciones para obtener un tamaño efectivo de muestra apropiado para hacer inferencia. Stan generalmente obtiene tamaños efectivos de muestra mucho más altos con menos iteraciones (aunque cada iteración es más costosa).\nConsiderando experiencia y teoría, tamaños efectivos de muestra mínimos se considera de 400 o más (ver aquí).\n\nEn nuestro ejemplo, tenemos tamaños de muestra efectivos satisfactorios:\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483\n\n\n\n\n\n\n\n\n\nNótese que versiones más recientes de Stan reportan dos tamaños efectivos de muestra (ESS), uno para cantidades que dependen del centro de la distribución, como la media y mediana (bulk ESS, que es similar a la definición que vimos arriba, pero usando valores normalizados por rango), y otro para cantidades que dependen de las colas, como percentiles extremos (tail ESS, que estima el tamaño de muestra efectivo para los percentiles 5% y 95% ). En este caso, ambos son altos.\n\nFinalmente, podemos checar el error montecarlo, que es error de estimación usual\n\najuste_vinos_1$summary(c(\"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nQ[1]\n0.137\n0.317\n-0.396\n0.672\n1.001\n20694.09\n5373.128\n\n\nQ[2]\n0.103\n0.321\n-0.425\n0.629\n1.001\n20994.93\n5362.172\n\n\nQ[3]\n0.271\n0.318\n-0.247\n0.798\n1.000\n20676.69\n5913.964\n\n\nQ[4]\n0.555\n0.313\n0.043\n1.069\n1.000\n18730.09\n5575.563\n\n\nQ[5]\n-0.120\n0.315\n-0.636\n0.390\n1.001\n19760.24\n5848.199\n\n\nQ[6]\n-0.370\n0.312\n-0.880\n0.145\n1.000\n16654.60\n5972.842\n\n\nQ[7]\n0.286\n0.314\n-0.231\n0.795\n1.001\n17442.52\n6084.769\n\n\nQ[8]\n0.271\n0.319\n-0.256\n0.805\n1.000\n18199.26\n5596.789\n\n\nQ[9]\n0.080\n0.314\n-0.438\n0.584\n1.000\n19534.73\n5983.451\n\n\nQ[10]\n0.118\n0.308\n-0.386\n0.626\n1.000\n21143.80\n5814.923\n\n\nQ[11]\n-0.010\n0.321\n-0.546\n0.510\n1.000\n20940.00\n5531.936\n\n\nQ[12]\n-0.029\n0.322\n-0.560\n0.500\n1.001\n18276.46\n5849.228\n\n\nQ[13]\n-0.105\n0.312\n-0.609\n0.414\n1.003\n20575.88\n5957.570\n\n\nQ[14]\n0.005\n0.313\n-0.505\n0.525\n1.001\n17541.60\n5723.524\n\n\nQ[15]\n-0.215\n0.318\n-0.740\n0.312\n1.001\n17150.01\n5412.980\n\n\nQ[16]\n-0.201\n0.315\n-0.722\n0.315\n1.001\n17596.06\n5120.461\n\n\nQ[17]\n-0.142\n0.316\n-0.665\n0.379\n1.000\n20718.38\n6172.910\n\n\nQ[18]\n-0.860\n0.314\n-1.384\n-0.343\n1.000\n18745.31\n6126.091\n\n\nQ[19]\n-0.161\n0.311\n-0.666\n0.343\n1.000\n18166.25\n6352.717\n\n\nQ[20]\n0.380\n0.313\n-0.127\n0.896\n1.000\n21072.45\n5060.363\n\n\nsigma\n0.997\n0.054\n0.912\n1.092\n1.000\n13245.07\n6385.483", "crumbs": [ "8  Markov Chain Monte Carlo" ] @@ -574,7 +574,7 @@ "href": "08-mcmc.html#extendiendo-el-modelo-de-variable-latente", "title": "8  Markov Chain Monte Carlo", "section": "8.4 Extendiendo el modelo de variable latente", - "text": "8.4 Extendiendo el modelo de variable latente\nAhora continuamos con nuestro modelo de calidad de vinos. Incluímos el origen del vino (que tiene dos niveles):\n\nwines_2012 <- wines_2012 |> mutate(origen_num = as.numeric(factor(wine.amer)))\nwines_2012 |> select(wine.amer, origen_num) |> unique()\n\n# A tibble: 2 × 2\n wine.amer origen_num\n <dbl> <dbl>\n1 1 2\n2 0 1\n\nn_jueces <- length(unique(wines_2012$juez_num))\nn_vinos <- length(unique(wines_2012$vino_num))\nn_origen <- length(unique(wines_2012$origen_num))\nc(\"num_vinos\" = n_jueces, \"num_jueces\" = n_vinos, \"num_datos\" = nrow(wines_2012))\n\n num_vinos num_jueces num_datos \n 9 20 180 \n\n\n\nmod_vinos_2 <-cmdstan_model(\"./src/vinos-2.stan\")\nprint(mod_vinos_2)\n\ndata {\n int<lower=0> N; //número de calificaciones\n int<lower=0> n_vinos; //número de vinos\n int<lower=0> n_jueces; //número de jueces\n int<lower=0> n_origen; //número de jueces\n vector[N] S;\n array[N] int juez;\n array[N] int vino;\n array[N] int origen;\n}\n\nparameters {\n vector[n_vinos] Q;\n vector[n_origen] O;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] media_score;\n // determinístico dado parámetros\n for (i in 1:N){\n media_score[i] = Q[vino[i]] + O[origen[i]];\n }\n}\n\nmodel {\n // partes no determinísticas\n S ~ normal(media_score, sigma);\n Q ~ std_normal();\n O ~ std_normal();\n sigma ~ exponential(1);\n}\n\ngenerated quantities {\n real dif_origen;\n dif_origen = O[1] - O[2];\n}\n\n\n\ndatos_lst <- list(\n N = nrow(wines_2012),\n n_vinos = n_vinos,\n n_jueces = n_jueces,\n n_origen = n_origen,\n S = wines_2012$score_est,\n vino = wines_2012$vino_num,\n juez = wines_2012$juez_num,\n origen = wines_2012$origen_num\n)\najuste_vinos_2 <- mod_vinos_2$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 1000,\n iter_sampling = 2000,\n refresh = 1000,\n step_size = 0.1,\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 1 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 2 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 3 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 3 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 4 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 4 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 3 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 1 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 2 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 3 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 1 finished in 0.6 seconds.\nChain 2 finished in 0.6 seconds.\nChain 3 finished in 0.6 seconds.\nChain 4 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 4 finished in 0.6 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.6 seconds.\nTotal execution time: 0.8 seconds.\n\n\n\najuste_vinos_2$summary(c(\"O\", \"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nO[1]\n0.099\n0.350\n-0.476\n0.681\n1.002\n2412.789\n4204.645\n\n\nO[2]\n-0.075\n0.298\n-0.569\n0.420\n1.001\n1894.755\n3151.806\n\n\nQ[1]\n0.206\n0.412\n-0.468\n0.882\n1.000\n3592.155\n5240.623\n\n\nQ[2]\n0.009\n0.447\n-0.734\n0.747\n1.001\n4003.812\n5697.399\n\n\nQ[3]\n0.338\n0.418\n-0.354\n1.031\n1.000\n3308.706\n5152.561\n\n\nQ[4]\n0.458\n0.448\n-0.278\n1.194\n1.001\n4037.965\n5292.574\n\n\nQ[5]\n-0.212\n0.442\n-0.935\n0.508\n1.001\n3648.474\n4531.175\n\n\nQ[6]\n-0.298\n0.418\n-0.982\n0.395\n1.001\n3439.901\n4588.545\n\n\nQ[7]\n0.197\n0.443\n-0.544\n0.925\n1.001\n3844.284\n5522.440\n\n\nQ[8]\n0.337\n0.414\n-0.347\n1.014\n1.001\n3470.029\n4716.944\n\n\nQ[9]\n0.152\n0.414\n-0.526\n0.834\n1.001\n3398.534\n5020.712\n\n\nQ[10]\n0.185\n0.412\n-0.496\n0.872\n1.001\n3476.594\n4876.944\n\n\nQ[11]\n0.060\n0.414\n-0.615\n0.745\n1.001\n3467.460\n4832.557\n\n\nQ[12]\n0.038\n0.414\n-0.641\n0.727\n1.000\n3244.006\n4972.325\n\n\nQ[13]\n-0.039\n0.413\n-0.721\n0.636\n1.001\n3434.090\n5449.640\n\n\nQ[14]\n-0.081\n0.450\n-0.818\n0.667\n1.001\n3721.005\n4902.528\n\n\nQ[15]\n-0.308\n0.446\n-1.034\n0.424\n1.001\n3871.176\n4955.067\n\n\nQ[16]\n-0.132\n0.416\n-0.822\n0.543\n1.000\n3254.726\n5149.031\n\n\nQ[17]\n-0.072\n0.415\n-0.741\n0.613\n1.001\n3582.440\n4455.786\n\n\nQ[18]\n-0.793\n0.423\n-1.500\n-0.095\n1.000\n3485.233\n4641.234\n\n\nQ[19]\n-0.253\n0.448\n-1.007\n0.474\n1.002\n3771.965\n5226.927\n\n\nQ[20]\n0.297\n0.443\n-0.436\n1.015\n1.001\n3595.291\n5448.456\n\n\nsigma\n0.998\n0.055\n0.912\n1.093\n1.000\n10061.554\n5795.223\n\n\n\n\n\n\n\n\nTodo parece bien con los diagnósticos. Podemos graficar las estimaciones (nota: aquí estan intervalos de 50% y 90%):\n\nlibrary(bayesplot)\ncolor_scheme_set(\"red\")\nmcmc_intervals(ajuste_vinos_2$draws(c(\"Q\", \"O\", \"sigma\")))\n\n\n\n\n\n\n\n\n\nParece no haber mucha diferencia en calidad debida origen del vinos (tienen relativamente poca variabilidad y están traslapadas: aunque podríamos mejor calcular el contraste si queremos examinar esto con más cuidado).\n\nTodo parece ir bien, así que podemos expandir el modelo para incluir la forma de calificar de los jueces. En primer lugar, definimos un nivel general \\(H\\) que indica qué tan alto o bajo califica un juez en general. Adicionalmente, incluímos un parámetro de discriminación \\(D\\) de los jueces, que indica qué tanto del rango de la escala usa cada juez El modelo para el valor esperado del Score de un vino \\(i\\) calificado por el juez \\(j\\) es:\n\\[\\mu_{i} = Q_{vino(i)} + U_{origen(i)} - H_{juez(i)}\\] Podemos pensar que el valor \\(H\\) de cada juez es qué tan duro es en sus calificaciones. Para cada vino, un juez con valor alto de \\(H\\) tendrá a calificar más bajo un vino de misma calidad y origen que otro juez con un valor más bajo de \\(H\\). Podemos incluír un parámetro de discriminación \\(D\\) para cada juez, que indica qué tanto del rango de la escala usa cada juez de la siguiente forma:\n\\[\\mu_{i} = (Q_{vino(i)} + U_{origen(i)} - H_{juez(i)})D_{juez(i)}\\] Un juez con valor alto de \\(D\\) es más extremo en sus calificaciones: un vino por arriba de su promedio lo califica más alto en la escala, y un vino por debajo de su promedio lo califica más bajo. El extremo es que \\(D=0\\), que quiere decir que el juez tiende a calificar a todos los vinos con un score.\n\nmod_vinos_3 <-cmdstan_model(\"./src/vinos-3.stan\")\nprint(mod_vinos_3)\n\ndata {\n int<lower=0> N; //número de calificaciones\n int<lower=0> n_vinos; //número de vinos\n int<lower=0> n_jueces; //número de jueces\n int<lower=0> n_origen; //número de jueces\n vector[N] S;\n array[N] int juez;\n array[N] int vino;\n array[N] int origen;\n}\n\nparameters {\n vector[n_vinos] Q;\n vector[n_origen] O;\n vector[n_jueces] H;\n vector<lower=0>[n_jueces] D;\n\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] media_score;\n // determinístico dado parámetros\n for (i in 1:N){\n media_score[i] = (Q[vino[i]] + O[origen[i]] - H[juez[i]]) * D[juez[i]];\n }\n}\n\nmodel {\n // partes no determinísticas\n S ~ normal(media_score, sigma);\n Q ~ std_normal();\n O ~ std_normal();\n H ~ std_normal();\n D ~ std_normal();\n sigma ~ exponential(1);\n}\n\ngenerated quantities {\n real dif_origen;\n dif_origen = O[1] - O[2];\n}\n\n\n\ndatos_lst <- list(\n N = nrow(wines_2012),\n n_vinos = n_vinos,\n n_jueces = n_jueces,\n n_origen = n_origen,\n S = wines_2012$score_est,\n vino = wines_2012$vino_num,\n juez = wines_2012$juez_num,\n origen = wines_2012$origen_num\n)\najuste_vinos_3 <- mod_vinos_3$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 1000,\n iter_sampling = 2000,\n refresh = 1000,\n step_size = 0.1,\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 2 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 3 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 4 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 1 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 2 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 3 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 3 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 4 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 4 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 1 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 2 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 3 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 1 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 1 finished in 1.4 seconds.\nChain 2 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 2 finished in 1.5 seconds.\nChain 3 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 4 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 3 finished in 1.5 seconds.\nChain 4 finished in 1.5 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 1.5 seconds.\nTotal execution time: 1.7 seconds.\n\n\nChecamos diagnósticos:\n\najuste_vinos_3$summary(c(\"O\", \"Q\", \"H\", \"D\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nO[1]\n0.181\n0.476\n-0.615\n0.956\n1.001\n3765.989\n4950.363\n\n\nO[2]\n-0.127\n0.444\n-0.851\n0.603\n1.001\n3813.505\n4494.836\n\n\nQ[1]\n0.368\n0.556\n-0.525\n1.304\n1.000\n5727.932\n6428.301\n\n\nQ[2]\n0.166\n0.570\n-0.759\n1.108\n1.000\n5663.956\n5912.333\n\n\nQ[3]\n0.515\n0.538\n-0.365\n1.400\n1.001\n6728.405\n6116.070\n\n\nQ[4]\n0.833\n0.570\n-0.075\n1.779\n1.000\n6969.773\n5395.361\n\n\nQ[5]\n-0.479\n0.556\n-1.372\n0.437\n1.001\n6477.503\n5430.105\n\n\nQ[6]\n-0.824\n0.594\n-1.797\n0.165\n1.001\n3820.716\n4280.100\n\n\nQ[7]\n0.211\n0.590\n-0.739\n1.185\n1.000\n5341.614\n5699.260\n\n\nQ[8]\n0.623\n0.552\n-0.274\n1.525\n1.001\n5797.117\n5654.560\n\n\nQ[9]\n0.292\n0.553\n-0.631\n1.191\n1.000\n6851.184\n5645.657\n\n\nQ[10]\n0.341\n0.534\n-0.550\n1.196\n1.000\n6961.356\n5808.247\n\n\nQ[11]\n0.205\n0.541\n-0.711\n1.082\n1.001\n6051.072\n5165.780\n\n\nQ[12]\n-0.091\n0.545\n-0.961\n0.821\n1.001\n5718.268\n5309.599\n\n\nQ[13]\n0.072\n0.551\n-0.849\n0.955\n1.001\n6459.464\n5836.498\n\n\nQ[14]\n-0.148\n0.541\n-1.030\n0.728\n1.000\n7359.575\n5321.920\n\n\nQ[15]\n-0.510\n0.563\n-1.446\n0.401\n1.000\n5951.653\n5523.262\n\n\nQ[16]\n-0.128\n0.559\n-1.046\n0.800\n1.001\n4795.742\n5328.219\n\n\nQ[17]\n0.105\n0.562\n-0.836\n0.992\n1.000\n5704.539\n5511.541\n\n\nQ[18]\n-1.504\n0.559\n-2.440\n-0.606\n1.000\n6210.482\n5604.212\n\n\nQ[19]\n-0.359\n0.535\n-1.245\n0.521\n1.000\n6851.111\n6289.493\n\n\nQ[20]\n0.496\n0.568\n-0.440\n1.435\n1.000\n6488.383\n6042.595\n\n\nH[1]\n0.595\n0.590\n-0.297\n1.600\n1.001\n4890.795\n5083.860\n\n\nH[2]\n-0.277\n0.430\n-0.987\n0.412\n1.001\n4067.421\n4471.063\n\n\nH[3]\n-0.487\n0.752\n-1.690\n0.755\n1.001\n6634.445\n5038.125\n\n\nH[4]\n1.230\n0.604\n0.334\n2.282\n1.000\n5810.318\n5565.047\n\n\nH[5]\n-1.789\n0.614\n-2.861\n-0.845\n1.001\n5710.315\n5603.079\n\n\nH[6]\n-1.176\n0.658\n-2.289\n-0.172\n1.001\n5852.321\n4696.880\n\n\nH[7]\n-0.237\n0.570\n-1.187\n0.624\n1.000\n4864.331\n4506.914\n\n\nH[8]\n1.220\n0.565\n0.358\n2.210\n1.000\n4741.553\n5182.626\n\n\nH[9]\n0.849\n0.802\n-0.532\n2.101\n1.000\n7080.074\n4764.104\n\n\nD[1]\n0.470\n0.253\n0.104\n0.922\n1.001\n3175.320\n3157.776\n\n\nD[2]\n0.935\n0.355\n0.359\n1.537\n1.001\n2500.634\n2606.835\n\n\nD[3]\n0.248\n0.184\n0.023\n0.605\n1.001\n3663.955\n3477.833\n\n\nD[4]\n0.445\n0.194\n0.176\n0.805\n1.001\n4330.755\n3565.457\n\n\nD[5]\n0.450\n0.151\n0.240\n0.728\n1.000\n5467.003\n4588.211\n\n\nD[6]\n0.341\n0.171\n0.094\n0.648\n1.002\n3379.508\n2023.933\n\n\nD[7]\n0.595\n0.409\n0.052\n1.339\n1.002\n1855.105\n2665.182\n\n\nD[8]\n0.620\n0.248\n0.283\n1.084\n1.000\n3914.767\n4854.722\n\n\nD[9]\n0.198\n0.142\n0.017\n0.464\n1.001\n4130.257\n3929.585\n\n\nsigma\n0.822\n0.050\n0.744\n0.909\n1.000\n4920.030\n5690.416\n\n\n\n\n\n\n\n\nY vemos efectivamente que el uso de la escala de los jueces es considerablemente diferente, y que hemos absorbido parte de la variación con los parámetros \\(H\\) y \\(D\\) (\\(sigma\\) es más baja que en los modelos anteriores):\n\nmcmc_intervals(ajuste_vinos_3$draws(c(\"H\", \"D\", \"sigma\")))\n\n\n\n\n\n\n\n\n\nmcmc_intervals(ajuste_vinos_3$draws(c(\"Q\")))\n\n\n\n\n\n\n\nmcmc_intervals(ajuste_vinos_1$draws(c(\"Q\")))\n\n\n\n\n\n\n\n\nCon el modelo completo, examinamos ahora el contraste de interés: ¿hay diferencias en las calificaciones de vinos de diferentes orígenes? La respuesta es que no hay mucha evidencia de que haya una diferencia, aunque hay variación considerable en este contraste:\n\najuste_vinos_3$summary(c(\"dif_origen\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) \n\n# A tibble: 1 × 8\n variable mean sd q5 q95 rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 dif_origen 0.308 0.499 -0.521 1.12 1 4346. 5291.", + "text": "8.4 Extendiendo el modelo de variable latente\nAhora continuamos con nuestro modelo de calidad de vinos. Incluímos el origen del vino (que tiene dos niveles):\n\nwines_2012 <- wines_2012 |> mutate(origen_num = as.numeric(factor(wine.amer)))\nwines_2012 |> select(wine.amer, origen_num) |> unique()\n\n# A tibble: 2 × 2\n wine.amer origen_num\n <dbl> <dbl>\n1 1 2\n2 0 1\n\nn_jueces <- length(unique(wines_2012$juez_num))\nn_vinos <- length(unique(wines_2012$vino_num))\nn_origen <- length(unique(wines_2012$origen_num))\nc(\"num_vinos\" = n_jueces, \"num_jueces\" = n_vinos, \"num_datos\" = nrow(wines_2012))\n\n num_vinos num_jueces num_datos \n 9 20 180 \n\n\n\nmod_vinos_2 <-cmdstan_model(\"./src/vinos-2.stan\")\nprint(mod_vinos_2)\n\ndata {\n int<lower=0> N; //número de calificaciones\n int<lower=0> n_vinos; //número de vinos\n int<lower=0> n_jueces; //número de jueces\n int<lower=0> n_origen; //número de jueces\n vector[N] S;\n array[N] int juez;\n array[N] int vino;\n array[N] int origen;\n}\n\nparameters {\n vector[n_vinos] Q;\n vector[n_origen] O;\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] media_score;\n // determinístico dado parámetros\n for (i in 1:N){\n media_score[i] = Q[vino[i]] + O[origen[i]];\n }\n}\n\nmodel {\n // partes no determinísticas\n S ~ normal(media_score, sigma);\n Q ~ std_normal();\n O ~ std_normal();\n sigma ~ exponential(1);\n}\n\ngenerated quantities {\n real dif_origen;\n dif_origen = O[1] - O[2];\n}\n\n\n\ndatos_lst <- list(\n N = nrow(wines_2012),\n n_vinos = n_vinos,\n n_jueces = n_jueces,\n n_origen = n_origen,\n S = wines_2012$score_est,\n vino = wines_2012$vino_num,\n juez = wines_2012$juez_num,\n origen = wines_2012$origen_num\n)\najuste_vinos_2 <- mod_vinos_2$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 1000,\n iter_sampling = 2000,\n refresh = 1000,\n step_size = 0.1,\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 1 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 2 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 3 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 3 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 4 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 4 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 1 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 2 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 3 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 1 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 1 finished in 0.6 seconds.\nChain 2 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 3 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 4 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 2 finished in 0.7 seconds.\nChain 3 finished in 0.6 seconds.\nChain 4 finished in 0.6 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.6 seconds.\nTotal execution time: 0.8 seconds.\n\n\n\najuste_vinos_2$summary(c(\"O\", \"Q\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nO[1]\n0.099\n0.350\n-0.476\n0.681\n1.002\n2412.789\n4204.645\n\n\nO[2]\n-0.075\n0.298\n-0.569\n0.420\n1.001\n1894.755\n3151.806\n\n\nQ[1]\n0.206\n0.412\n-0.468\n0.882\n1.000\n3592.155\n5240.623\n\n\nQ[2]\n0.009\n0.447\n-0.734\n0.747\n1.001\n4003.812\n5697.399\n\n\nQ[3]\n0.338\n0.418\n-0.354\n1.031\n1.000\n3308.706\n5152.561\n\n\nQ[4]\n0.458\n0.448\n-0.278\n1.194\n1.001\n4037.965\n5292.574\n\n\nQ[5]\n-0.212\n0.442\n-0.935\n0.508\n1.001\n3648.474\n4531.175\n\n\nQ[6]\n-0.298\n0.418\n-0.982\n0.395\n1.001\n3439.901\n4588.545\n\n\nQ[7]\n0.197\n0.443\n-0.544\n0.925\n1.001\n3844.284\n5522.440\n\n\nQ[8]\n0.337\n0.414\n-0.347\n1.014\n1.001\n3470.029\n4716.944\n\n\nQ[9]\n0.152\n0.414\n-0.526\n0.834\n1.001\n3398.534\n5020.712\n\n\nQ[10]\n0.185\n0.412\n-0.496\n0.872\n1.001\n3476.594\n4876.944\n\n\nQ[11]\n0.060\n0.414\n-0.615\n0.745\n1.001\n3467.460\n4832.557\n\n\nQ[12]\n0.038\n0.414\n-0.641\n0.727\n1.000\n3244.006\n4972.325\n\n\nQ[13]\n-0.039\n0.413\n-0.721\n0.636\n1.001\n3434.090\n5449.640\n\n\nQ[14]\n-0.081\n0.450\n-0.818\n0.667\n1.001\n3721.005\n4902.528\n\n\nQ[15]\n-0.308\n0.446\n-1.034\n0.424\n1.001\n3871.176\n4955.067\n\n\nQ[16]\n-0.132\n0.416\n-0.822\n0.543\n1.000\n3254.726\n5149.031\n\n\nQ[17]\n-0.072\n0.415\n-0.741\n0.613\n1.001\n3582.440\n4455.786\n\n\nQ[18]\n-0.793\n0.423\n-1.500\n-0.095\n1.000\n3485.233\n4641.234\n\n\nQ[19]\n-0.253\n0.448\n-1.007\n0.474\n1.002\n3771.965\n5226.927\n\n\nQ[20]\n0.297\n0.443\n-0.436\n1.015\n1.001\n3595.291\n5448.456\n\n\nsigma\n0.998\n0.055\n0.912\n1.093\n1.000\n10061.554\n5795.223\n\n\n\n\n\n\n\n\nTodo parece bien con los diagnósticos. Podemos graficar las estimaciones (nota: aquí estan intervalos de 50% y 90%):\n\nlibrary(bayesplot)\ncolor_scheme_set(\"red\")\nmcmc_intervals(ajuste_vinos_2$draws(c(\"Q\", \"O\", \"sigma\")))\n\n\n\n\n\n\n\n\n\nParece no haber mucha diferencia en calidad debida origen del vinos (tienen relativamente poca variabilidad y están traslapadas: aunque podríamos mejor calcular el contraste si queremos examinar esto con más cuidado).\n\nTodo parece ir bien, así que podemos expandir el modelo para incluir la forma de calificar de los jueces. En primer lugar, definimos un nivel general \\(H\\) que indica qué tan alto o bajo califica un juez en general. Adicionalmente, incluímos un parámetro de discriminación \\(D\\) de los jueces, que indica qué tanto del rango de la escala usa cada juez El modelo para el valor esperado del Score de un vino \\(i\\) calificado por el juez \\(j\\) es:\n\\[\\mu_{i} = Q_{vino(i)} + U_{origen(i)} - H_{juez(i)}\\] Podemos pensar que el valor \\(H\\) de cada juez es qué tan duro es en sus calificaciones. Para cada vino, un juez con valor alto de \\(H\\) tendrá a calificar más bajo un vino de misma calidad y origen que otro juez con un valor más bajo de \\(H\\). Podemos incluír un parámetro de discriminación \\(D\\) para cada juez, que indica qué tanto del rango de la escala usa cada juez de la siguiente forma:\n\\[\\mu_{i} = (Q_{vino(i)} + U_{origen(i)} - H_{juez(i)})D_{juez(i)}\\] Un juez con valor alto de \\(D\\) es más extremo en sus calificaciones: un vino por arriba de su promedio lo califica más alto en la escala, y un vino por debajo de su promedio lo califica más bajo. El extremo es que \\(D=0\\), que quiere decir que el juez tiende a calificar a todos los vinos con un score.\n\nmod_vinos_3 <-cmdstan_model(\"./src/vinos-3.stan\")\nprint(mod_vinos_3)\n\ndata {\n int<lower=0> N; //número de calificaciones\n int<lower=0> n_vinos; //número de vinos\n int<lower=0> n_jueces; //número de jueces\n int<lower=0> n_origen; //número de jueces\n vector[N] S;\n array[N] int juez;\n array[N] int vino;\n array[N] int origen;\n}\n\nparameters {\n vector[n_vinos] Q;\n vector[n_origen] O;\n vector[n_jueces] H;\n vector<lower=0>[n_jueces] D;\n\n real <lower=0> sigma;\n}\n\ntransformed parameters {\n vector[N] media_score;\n // determinístico dado parámetros\n for (i in 1:N){\n media_score[i] = (Q[vino[i]] + O[origen[i]] - H[juez[i]]) * D[juez[i]];\n }\n}\n\nmodel {\n // partes no determinísticas\n S ~ normal(media_score, sigma);\n Q ~ std_normal();\n O ~ std_normal();\n H ~ std_normal();\n D ~ std_normal();\n sigma ~ exponential(1);\n}\n\ngenerated quantities {\n real dif_origen;\n dif_origen = O[1] - O[2];\n}\n\n\n\ndatos_lst <- list(\n N = nrow(wines_2012),\n n_vinos = n_vinos,\n n_jueces = n_jueces,\n n_origen = n_origen,\n S = wines_2012$score_est,\n vino = wines_2012$vino_num,\n juez = wines_2012$juez_num,\n origen = wines_2012$origen_num\n)\najuste_vinos_3 <- mod_vinos_3$sample(\n data = datos_lst,\n chains = 4,\n parallel_chains = 4,\n iter_warmup = 1000,\n iter_sampling = 2000,\n refresh = 1000,\n step_size = 0.1,\n)\n\nRunning MCMC with 4 parallel chains...\n\nChain 1 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 2 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 3 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 4 Iteration: 1 / 3000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 1 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 2 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 2 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 3 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 3 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 4 Iteration: 1000 / 3000 [ 33%] (Warmup) \nChain 4 Iteration: 1001 / 3000 [ 33%] (Sampling) \nChain 1 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 2 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 3 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 4 Iteration: 2000 / 3000 [ 66%] (Sampling) \nChain 1 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 1 finished in 1.5 seconds.\nChain 2 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 3 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 2 finished in 1.6 seconds.\nChain 3 finished in 1.5 seconds.\nChain 4 Iteration: 3000 / 3000 [100%] (Sampling) \nChain 4 finished in 1.6 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 1.5 seconds.\nTotal execution time: 1.8 seconds.\n\n\nChecamos diagnósticos:\n\najuste_vinos_3$summary(c(\"O\", \"Q\", \"H\", \"D\", \"sigma\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |>\n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) |> \n filter(variable != \"lp__\") |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nq5\nq95\nrhat\ness_bulk\ness_tail\n\n\n\n\nO[1]\n0.181\n0.476\n-0.615\n0.956\n1.001\n3765.989\n4950.363\n\n\nO[2]\n-0.127\n0.444\n-0.851\n0.603\n1.001\n3813.505\n4494.836\n\n\nQ[1]\n0.368\n0.556\n-0.525\n1.304\n1.000\n5727.932\n6428.301\n\n\nQ[2]\n0.166\n0.570\n-0.759\n1.108\n1.000\n5663.956\n5912.333\n\n\nQ[3]\n0.515\n0.538\n-0.365\n1.400\n1.001\n6728.405\n6116.070\n\n\nQ[4]\n0.833\n0.570\n-0.075\n1.779\n1.000\n6969.773\n5395.361\n\n\nQ[5]\n-0.479\n0.556\n-1.372\n0.437\n1.001\n6477.503\n5430.105\n\n\nQ[6]\n-0.824\n0.594\n-1.797\n0.165\n1.001\n3820.716\n4280.100\n\n\nQ[7]\n0.211\n0.590\n-0.739\n1.185\n1.000\n5341.614\n5699.260\n\n\nQ[8]\n0.623\n0.552\n-0.274\n1.525\n1.001\n5797.117\n5654.560\n\n\nQ[9]\n0.292\n0.553\n-0.631\n1.191\n1.000\n6851.184\n5645.657\n\n\nQ[10]\n0.341\n0.534\n-0.550\n1.196\n1.000\n6961.356\n5808.247\n\n\nQ[11]\n0.205\n0.541\n-0.711\n1.082\n1.001\n6051.072\n5165.780\n\n\nQ[12]\n-0.091\n0.545\n-0.961\n0.821\n1.001\n5718.268\n5309.599\n\n\nQ[13]\n0.072\n0.551\n-0.849\n0.955\n1.001\n6459.464\n5836.498\n\n\nQ[14]\n-0.148\n0.541\n-1.030\n0.728\n1.000\n7359.575\n5321.920\n\n\nQ[15]\n-0.510\n0.563\n-1.446\n0.401\n1.000\n5951.653\n5523.262\n\n\nQ[16]\n-0.128\n0.559\n-1.046\n0.800\n1.001\n4795.742\n5328.219\n\n\nQ[17]\n0.105\n0.562\n-0.836\n0.992\n1.000\n5704.539\n5511.541\n\n\nQ[18]\n-1.504\n0.559\n-2.440\n-0.606\n1.000\n6210.482\n5604.212\n\n\nQ[19]\n-0.359\n0.535\n-1.245\n0.521\n1.000\n6851.111\n6289.493\n\n\nQ[20]\n0.496\n0.568\n-0.440\n1.435\n1.000\n6488.383\n6042.595\n\n\nH[1]\n0.595\n0.590\n-0.297\n1.600\n1.001\n4890.795\n5083.860\n\n\nH[2]\n-0.277\n0.430\n-0.987\n0.412\n1.001\n4067.421\n4471.063\n\n\nH[3]\n-0.487\n0.752\n-1.690\n0.755\n1.001\n6634.445\n5038.125\n\n\nH[4]\n1.230\n0.604\n0.334\n2.282\n1.000\n5810.318\n5565.047\n\n\nH[5]\n-1.789\n0.614\n-2.861\n-0.845\n1.001\n5710.315\n5603.079\n\n\nH[6]\n-1.176\n0.658\n-2.289\n-0.172\n1.001\n5852.321\n4696.880\n\n\nH[7]\n-0.237\n0.570\n-1.187\n0.624\n1.000\n4864.331\n4506.914\n\n\nH[8]\n1.220\n0.565\n0.358\n2.210\n1.000\n4741.553\n5182.626\n\n\nH[9]\n0.849\n0.802\n-0.532\n2.101\n1.000\n7080.074\n4764.104\n\n\nD[1]\n0.470\n0.253\n0.104\n0.922\n1.001\n3175.320\n3157.776\n\n\nD[2]\n0.935\n0.355\n0.359\n1.537\n1.001\n2500.634\n2606.835\n\n\nD[3]\n0.248\n0.184\n0.023\n0.605\n1.001\n3663.955\n3477.833\n\n\nD[4]\n0.445\n0.194\n0.176\n0.805\n1.001\n4330.755\n3565.457\n\n\nD[5]\n0.450\n0.151\n0.240\n0.728\n1.000\n5467.003\n4588.211\n\n\nD[6]\n0.341\n0.171\n0.094\n0.648\n1.002\n3379.508\n2023.933\n\n\nD[7]\n0.595\n0.409\n0.052\n1.339\n1.002\n1855.105\n2665.182\n\n\nD[8]\n0.620\n0.248\n0.283\n1.084\n1.000\n3914.767\n4854.722\n\n\nD[9]\n0.198\n0.142\n0.017\n0.464\n1.001\n4130.257\n3929.585\n\n\nsigma\n0.822\n0.050\n0.744\n0.909\n1.000\n4920.030\n5690.416\n\n\n\n\n\n\n\n\nY vemos efectivamente que el uso de la escala de los jueces es considerablemente diferente, y que hemos absorbido parte de la variación con los parámetros \\(H\\) y \\(D\\) (\\(sigma\\) es más baja que en los modelos anteriores):\n\nmcmc_intervals(ajuste_vinos_3$draws(c(\"H\", \"D\", \"sigma\")))\n\n\n\n\n\n\n\n\n\nmcmc_intervals(ajuste_vinos_3$draws(c(\"Q\")))\n\n\n\n\n\n\n\nmcmc_intervals(ajuste_vinos_1$draws(c(\"Q\")))\n\n\n\n\n\n\n\n\nCon el modelo completo, examinamos ahora el contraste de interés: ¿hay diferencias en las calificaciones de vinos de diferentes orígenes? La respuesta es que no hay mucha evidencia de que haya una diferencia, aunque hay variación considerable en este contraste:\n\najuste_vinos_3$summary(c(\"dif_origen\")) |> \n select(variable, mean, sd, q5, q95, rhat, contains(\"ess\")) |> \n mutate(across(c(mean, sd, q5, q95, rhat, ess_bulk, ess_tail), ~round(., 3))) \n\n# A tibble: 1 × 8\n variable mean sd q5 q95 rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 dif_origen 0.308 0.499 -0.521 1.12 1 4346. 5291.", "crumbs": [ "8  Markov Chain Monte Carlo" ] @@ -584,7 +584,7 @@ "href": "08-mcmc.html#transiciones-divergentes", "title": "8  Markov Chain Monte Carlo", "section": "8.5 Transiciones divergentes", - "text": "8.5 Transiciones divergentes\nFinalmente, discutiremos otro tipo de diagnósticos de Stan. Cuando una trayectoria tuvo un cambio grande en energía \\(H\\) desde su valor actual a la propuesta final, usualmente del orden de 10^3 por ejemplo, esto implica un rechazo “fuerte” en el nuevo punto de la trayectoria, e implica que la el integrador numérico falló de manera grave.\n\n\n\n\n\n\nTransiciones divergentes\n\n\n\nCuando en Stan obtenemos un número considerable de transiciones divergentes, generalmente esto indica que el integrador numérico de Stan no está funcionando bien, y por lo tanto la exploración puede ser deficiente y/o puede estar sesgada al espacio de parámetros donde no ocurren estos rechazos.\n\n\nEsto puede pasar cuando encontramos zonas de alta curvatura en el espacio de parámetros. Que una posterior esté altamente concentrada o más dispersa generalmente no es un problema, pero si la concentración varía fuertemente (curvatura) entonces puede ser difícil encontrar la escala correcta para que el integrador funcione apropiadamente.\n\n8.5.1 El embudo de Neal\nPara ver un ejemplo, consideremos un ejemplo de una distribución cuya forma aparecerá más tarde en modelos jerárquicos. Primero, la marginal de \\(y\\) es normal con media 0 y desviación estándar 3. La distribución condicional \\(p(x|y)\\) de \\(x = c(x_1,\\ldots, x_9)\\) dado \\(y\\) es normal multivariada, todas con media cero y desviación estándar \\(e^{y/2}\\). Veamos qué pasa si intentamos simular de esta distribución en Stan:\n\nmod_embudo <- cmdstan_model(\"./src/embudo-neal.stan\")\najuste_embudo <- mod_embudo$sample(\n chains = 1,\n iter_warmup = 1000,\n iter_sampling = 3000,\n refresh = 1000)\n\nRunning MCMC with 1 chain...\n\nChain 1 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 1 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 1 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 1 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 1 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 1 finished in 0.1 seconds.\n\n\nWarning: 86 of 3000 (3.0%) transitions ended with a divergence.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 1 of 1 chains had an E-BFMI less than 0.3.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nY vemos que aparecen algunos problemas.\n\nsimulaciones <- ajuste_embudo$draws(format = \"df\")\ndiagnosticos <- ajuste_embudo$sampler_diagnostics(format = \"df\")\nsims_diag <- simulaciones |> inner_join(diagnosticos, by = c(\".draw\", \".iteration\", \".chain\"))\najuste_embudo$summary() |> \n select(variable, mean, rhat, contains(\"ess\")) \n\n# A tibble: 11 × 5\n variable mean rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl>\n 1 lp__ -5.55 1.35 2.45 NA \n 2 y 0.189 1.34 2.46 2.23\n 3 x[1] 0.208 1.28 2494. 417. \n 4 x[2] -0.0835 1.25 1208. 346. \n 5 x[3] -0.0653 1.18 294. 300. \n 6 x[4] -0.0787 1.28 1015. 288. \n 7 x[5] -0.0731 1.28 1912. 251. \n 8 x[6] 0.0298 1.34 2737. 266. \n 9 x[7] 0.0539 1.17 452. 248. \n10 x[8] -0.0301 1.30 2469. 313. \n11 x[9] 0.0600 1.23 1814. 348. \n\nggplot(sims_diag, aes(y = y, x = `x[1]`)) +\n geom_point(alpha = 0.1) +\n geom_point(data = sims_diag |> filter(divergent__ == 1), color = \"red\", size = 2) +\n geom_hline(yintercept = -2.5, linetype = 2) \n\n\n\n\n\n\n\n\nY vemos que hay transiciones divergentes. Cuando el muestreador entra en el cuello del embudo, es muy fácil que se “despeñe” en probabilidad y que no pueda explorar correctamente la forma del cuello. Esto lo podemos ver, por ejemplo, si hacemos más simulaciones:\n\nmod_embudo <- cmdstan_model(\"./src/embudo-neal.stan\")\nprint(mod_embudo)\n\nparameters {\n real y;\n vector[9] x;\n}\nmodel {\n y ~ normal(0, 3);\n x ~ normal(0, exp(y/2));\n}\n\najuste_embudo <- mod_embudo$sample(\n chains = 1,\n iter_warmup = 1000,\n iter_sampling = 30000,\n refresh = 10000)\n\nRunning MCMC with 1 chain...\n\nChain 1 Iteration: 1 / 31000 [ 0%] (Warmup) \nChain 1 Iteration: 1001 / 31000 [ 3%] (Sampling) \nChain 1 Iteration: 11000 / 31000 [ 35%] (Sampling) \nChain 1 Iteration: 21000 / 31000 [ 67%] (Sampling) \nChain 1 Iteration: 31000 / 31000 [100%] (Sampling) \nChain 1 finished in 0.8 seconds.\n\n\nWarning: 1200 of 30000 (4.0%) transitions ended with a divergence.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 16 of 30000 (0.0%) transitions hit the maximum treedepth limit of 10.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 1 of 1 chains had an E-BFMI less than 0.3.\nSee https://mc-stan.org/misc/warnings for details.\n\najuste_embudo$summary() |> \n select(variable, mean, rhat, contains(\"ess\")) \n\n# A tibble: 11 × 5\n variable mean rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl>\n 1 lp__ -14.2 1.01 55.4 13.7\n 2 y 2.08 1.01 57.6 27.2\n 3 x[1] 0.227 1.00 13728. 2727. \n 4 x[2] 0.175 1.00 10467. 2770. \n 5 x[3] -0.0281 1.01 6702. 2551. \n 6 x[4] -0.112 1.01 7941. 2514. \n 7 x[5] -0.0890 1.01 6287. 2346. \n 8 x[6] 0.0658 1.00 10519. 2765. \n 9 x[7] -0.121 1.00 12467. 2538. \n10 x[8] -0.107 1.00 7124. 2443. \n11 x[9] 0.00905 1.00 2954. 2351. \n\nsimulaciones <- ajuste_embudo$draws(format = \"df\")\ndiagnosticos <- ajuste_embudo$sampler_diagnostics(format = \"df\")\nsims_diag <- simulaciones |> inner_join(diagnosticos, by = c(\".draw\", \".iteration\", \".chain\"))\nggplot(sims_diag, aes(y = y, x = `x[1]`)) +\n geom_point(alpha = 0.1) +\n geom_point(data = sims_diag |> filter(divergent__ == 1), color = \"red\", size = 2) +\n geom_hline(yintercept = -2.5, linetype = 2) \n\n\n\n\n\n\n\n\nY vemos que ahora que en el primer ejemplo estábamos probablemente sobreestimando la media de \\(y\\). Las divergencias indican que esto puede estar ocurriendo. En este ejemplo particular, también vemos que las R-hat y los tamaños efectivos de muestra son bajos.\nEste es un ejemplo extremo. Sin embargo, podemos reparametrizar para hacer las cosas más fáciles para el muestreador. Podemos simular \\(y\\), y después, simular \\(x\\) como \\(x \\sim e^{y/2} z\\) donde \\(z\\) es normal estándar.\n\nmod_embudo_reparam <- cmdstan_model(\"./src/embudo-neal-reparam.stan\")\nprint(mod_embudo_reparam)\n\nparameters {\n real y;\n vector[9] z;\n}\n\ntransformed parameters {\n vector[9] x;\n\n x = exp(y/2) * z;\n\n}\n\nmodel {\n y ~ normal(0, 3);\n z ~ std_normal();\n}\n\najuste_embudo <- mod_embudo_reparam$sample(\n chains = 4,\n iter_warmup = 1000,\n iter_sampling = 10000,\n refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 1 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 1 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 1 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 1 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 1 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 1 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 1 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 1 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 1 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 1 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 1 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 1 finished in 0.2 seconds.\nChain 2 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 2 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 2 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 2 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 2 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 2 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 2 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 2 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 2 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 2 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 2 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 2 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 2 finished in 0.2 seconds.\nChain 3 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 3 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 3 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 3 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 3 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 3 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 3 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 3 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 3 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 3 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 3 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 3 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 3 finished in 0.2 seconds.\nChain 4 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 4 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 4 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 4 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 4 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 4 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 4 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 4 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 4 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 4 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 4 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 4 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 4 finished in 0.2 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.2 seconds.\nTotal execution time: 1.0 seconds.\n\n\nY con este truco de reparametrización el muestreador funciona correctamente (observa que la media de \\(y\\) está estimada correctamente, y no hay divergencias).\n\najuste_embudo$summary() |> \n select(variable, mean, rhat, contains(\"ess\")) |> \n mutate(across(c(mean, rhat, ess_bulk, ess_tail), ~round(., 3))) \n\n# A tibble: 20 × 5\n variable mean rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl>\n 1 lp__ -5.00 1 16285. 24865.\n 2 y 0.002 1 74705. 28688.\n 3 z[1] -0.001 1 85160. 29570.\n 4 z[2] -0.002 1 84329. 30159.\n 5 z[3] -0.006 1 83548. 29967.\n 6 z[4] 0.002 1 81672. 29573.\n 7 z[5] 0 1 81966. 31008.\n 8 z[6] -0.004 1 85319. 29486.\n 9 z[7] 0.001 1 85417. 28666.\n10 z[8] 0 1 83917. 28876.\n11 z[9] 0.004 1 83128. 30034.\n12 x[1] -0.022 1 41969. 31013.\n13 x[2] -0.036 1 39866. 29902.\n14 x[3] -0.133 1 40322. 30635.\n15 x[4] 0.023 1 41022. 29315.\n16 x[5] -0.008 1 41923. 31293.\n17 x[6] -0.116 1 41851. 29370.\n18 x[7] 0.005 1 42307. 30895.\n19 x[8] -0.043 1 40895. 29853.\n20 x[9] -0.021 1 39208. 28808.\n\n\n\n\n\n\nBrooks, Steve, Andrew Gelman, Galin Jones, y Xiao-Li Meng. 2011. Handbook of Markov Chain Monte Carlo. CRC press.\n\n\nMcElreath, R. 2020. Statistical Rethinking: A Bayesian Course with Examples in R and Stan. A Chapman & Hall libro. CRC Press. https://books.google.com.mx/books?id=Ie2vxQEACAAJ.", + "text": "8.5 Transiciones divergentes\nFinalmente, discutiremos otro tipo de diagnósticos de Stan. Cuando una trayectoria tuvo un cambio grande en energía \\(H\\) desde su valor actual a la propuesta final, usualmente del orden de 10^3 por ejemplo, esto implica un rechazo “fuerte” en el nuevo punto de la trayectoria, e implica que la el integrador numérico falló de manera grave.\n\n\n\n\n\n\nTransiciones divergentes\n\n\n\nCuando en Stan obtenemos un número considerable de transiciones divergentes, generalmente esto indica que el integrador numérico de Stan no está funcionando bien, y por lo tanto la exploración puede ser deficiente y/o puede estar sesgada al espacio de parámetros donde no ocurren estos rechazos.\n\n\nEsto puede pasar cuando encontramos zonas de alta curvatura en el espacio de parámetros. Que una posterior esté altamente concentrada o más dispersa generalmente no es un problema, pero si la concentración varía fuertemente (curvatura) entonces puede ser difícil encontrar la escala correcta para que el integrador funcione apropiadamente.\n\n8.5.1 El embudo de Neal\nPara ver un ejemplo, consideremos un ejemplo de una distribución cuya forma aparecerá más tarde en modelos jerárquicos. Primero, la marginal de \\(y\\) es normal con media 0 y desviación estándar 3. La distribución condicional \\(p(x|y)\\) de \\(x = c(x_1,\\ldots, x_9)\\) dado \\(y\\) es normal multivariada, todas con media cero y desviación estándar \\(e^{y/2}\\). Veamos qué pasa si intentamos simular de esta distribución en Stan:\n\nmod_embudo <- cmdstan_model(\"./src/embudo-neal.stan\")\najuste_embudo <- mod_embudo$sample(\n chains = 1,\n iter_warmup = 1000,\n iter_sampling = 3000,\n refresh = 1000)\n\nRunning MCMC with 1 chain...\n\nChain 1 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 1 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 1 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 1 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 1 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 1 finished in 0.1 seconds.\n\n\nWarning: 86 of 3000 (3.0%) transitions ended with a divergence.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 1 of 1 chains had an E-BFMI less than 0.3.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nY vemos que aparecen algunos problemas.\n\nsimulaciones <- ajuste_embudo$draws(format = \"df\")\ndiagnosticos <- ajuste_embudo$sampler_diagnostics(format = \"df\")\nsims_diag <- simulaciones |> inner_join(diagnosticos, by = c(\".draw\", \".iteration\", \".chain\"))\najuste_embudo$summary() |> \n select(variable, mean, rhat, contains(\"ess\")) \n\n# A tibble: 11 × 5\n variable mean rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl>\n 1 lp__ -5.55 1.35 2.45 NA \n 2 y 0.189 1.34 2.46 2.23\n 3 x[1] 0.208 1.28 2494. 417. \n 4 x[2] -0.0835 1.25 1208. 346. \n 5 x[3] -0.0653 1.18 294. 300. \n 6 x[4] -0.0787 1.28 1015. 288. \n 7 x[5] -0.0731 1.28 1912. 251. \n 8 x[6] 0.0298 1.34 2737. 266. \n 9 x[7] 0.0539 1.17 452. 248. \n10 x[8] -0.0301 1.30 2469. 313. \n11 x[9] 0.0600 1.23 1814. 348. \n\nggplot(sims_diag, aes(y = y, x = `x[1]`)) +\n geom_point(alpha = 0.1) +\n geom_point(data = sims_diag |> filter(divergent__ == 1), color = \"red\", size = 2) +\n geom_hline(yintercept = -2.5, linetype = 2) \n\n\n\n\n\n\n\n\nY vemos que hay transiciones divergentes. Cuando el muestreador entra en el cuello del embudo, es muy fácil que se “despeñe” en probabilidad y que no pueda explorar correctamente la forma del cuello. Esto lo podemos ver, por ejemplo, si hacemos más simulaciones:\n\nmod_embudo <- cmdstan_model(\"./src/embudo-neal.stan\")\nprint(mod_embudo)\n\nparameters {\n real y;\n vector[9] x;\n}\nmodel {\n y ~ normal(0, 3);\n x ~ normal(0, exp(y/2));\n}\n\najuste_embudo <- mod_embudo$sample(\n chains = 1,\n iter_warmup = 1000,\n iter_sampling = 30000,\n refresh = 10000)\n\nRunning MCMC with 1 chain...\n\nChain 1 Iteration: 1 / 31000 [ 0%] (Warmup) \nChain 1 Iteration: 1001 / 31000 [ 3%] (Sampling) \nChain 1 Iteration: 11000 / 31000 [ 35%] (Sampling) \nChain 1 Iteration: 21000 / 31000 [ 67%] (Sampling) \nChain 1 Iteration: 31000 / 31000 [100%] (Sampling) \nChain 1 finished in 0.8 seconds.\n\n\nWarning: 1200 of 30000 (4.0%) transitions ended with a divergence.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 16 of 30000 (0.0%) transitions hit the maximum treedepth limit of 10.\nSee https://mc-stan.org/misc/warnings for details.\n\n\nWarning: 1 of 1 chains had an E-BFMI less than 0.3.\nSee https://mc-stan.org/misc/warnings for details.\n\najuste_embudo$summary() |> \n select(variable, mean, rhat, contains(\"ess\")) \n\n# A tibble: 11 × 5\n variable mean rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl>\n 1 lp__ -14.2 1.01 55.4 13.7\n 2 y 2.08 1.01 57.6 27.2\n 3 x[1] 0.227 1.00 13728. 2727. \n 4 x[2] 0.175 1.00 10467. 2770. \n 5 x[3] -0.0281 1.01 6702. 2551. \n 6 x[4] -0.112 1.01 7941. 2514. \n 7 x[5] -0.0890 1.01 6287. 2346. \n 8 x[6] 0.0658 1.00 10519. 2765. \n 9 x[7] -0.121 1.00 12467. 2538. \n10 x[8] -0.107 1.00 7124. 2443. \n11 x[9] 0.00905 1.00 2954. 2351. \n\nsimulaciones <- ajuste_embudo$draws(format = \"df\")\ndiagnosticos <- ajuste_embudo$sampler_diagnostics(format = \"df\")\nsims_diag <- simulaciones |> inner_join(diagnosticos, by = c(\".draw\", \".iteration\", \".chain\"))\nggplot(sims_diag, aes(y = y, x = `x[1]`)) +\n geom_point(alpha = 0.1) +\n geom_point(data = sims_diag |> filter(divergent__ == 1), color = \"red\", size = 2) +\n geom_hline(yintercept = -2.5, linetype = 2) \n\n\n\n\n\n\n\n\nY vemos que ahora que en el primer ejemplo estábamos probablemente sobreestimando la media de \\(y\\). Las divergencias indican que esto puede estar ocurriendo. En este ejemplo particular, también vemos que las R-hat y los tamaños efectivos de muestra son bajos.\nEste es un ejemplo extremo. Sin embargo, podemos reparametrizar para hacer las cosas más fáciles para el muestreador. Podemos simular \\(y\\), y después, simular \\(x\\) como \\(x \\sim e^{y/2} z\\) donde \\(z\\) es normal estándar.\n\nmod_embudo_reparam <- cmdstan_model(\"./src/embudo-neal-reparam.stan\")\nprint(mod_embudo_reparam)\n\nparameters {\n real y;\n vector[9] z;\n}\n\ntransformed parameters {\n vector[9] x;\n\n x = exp(y/2) * z;\n\n}\n\nmodel {\n y ~ normal(0, 3);\n z ~ std_normal();\n}\n\najuste_embudo <- mod_embudo_reparam$sample(\n chains = 4,\n iter_warmup = 1000,\n iter_sampling = 10000,\n refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 1 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 1 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 1 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 1 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 1 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 1 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 1 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 1 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 1 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 1 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 1 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 1 finished in 0.2 seconds.\nChain 2 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 2 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 2 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 2 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 2 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 2 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 2 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 2 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 2 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 2 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 2 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 2 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 2 finished in 0.2 seconds.\nChain 3 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 3 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 3 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 3 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 3 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 3 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 3 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 3 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 3 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 3 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 3 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 3 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 3 finished in 0.2 seconds.\nChain 4 Iteration: 1 / 11000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 11000 [ 9%] (Warmup) \nChain 4 Iteration: 1001 / 11000 [ 9%] (Sampling) \nChain 4 Iteration: 2000 / 11000 [ 18%] (Sampling) \nChain 4 Iteration: 3000 / 11000 [ 27%] (Sampling) \nChain 4 Iteration: 4000 / 11000 [ 36%] (Sampling) \nChain 4 Iteration: 5000 / 11000 [ 45%] (Sampling) \nChain 4 Iteration: 6000 / 11000 [ 54%] (Sampling) \nChain 4 Iteration: 7000 / 11000 [ 63%] (Sampling) \nChain 4 Iteration: 8000 / 11000 [ 72%] (Sampling) \nChain 4 Iteration: 9000 / 11000 [ 81%] (Sampling) \nChain 4 Iteration: 10000 / 11000 [ 90%] (Sampling) \nChain 4 Iteration: 11000 / 11000 [100%] (Sampling) \nChain 4 finished in 0.2 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.2 seconds.\nTotal execution time: 1.1 seconds.\n\n\nY con este truco de reparametrización el muestreador funciona correctamente (observa que la media de \\(y\\) está estimada correctamente, y no hay divergencias).\n\najuste_embudo$summary() |> \n select(variable, mean, rhat, contains(\"ess\")) |> \n mutate(across(c(mean, rhat, ess_bulk, ess_tail), ~round(., 3))) \n\n# A tibble: 20 × 5\n variable mean rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl>\n 1 lp__ -5.00 1 16285. 24865.\n 2 y 0.002 1 74705. 28688.\n 3 z[1] -0.001 1 85160. 29570.\n 4 z[2] -0.002 1 84329. 30159.\n 5 z[3] -0.006 1 83548. 29967.\n 6 z[4] 0.002 1 81672. 29573.\n 7 z[5] 0 1 81966. 31008.\n 8 z[6] -0.004 1 85319. 29486.\n 9 z[7] 0.001 1 85417. 28666.\n10 z[8] 0 1 83917. 28876.\n11 z[9] 0.004 1 83128. 30034.\n12 x[1] -0.022 1 41969. 31013.\n13 x[2] -0.036 1 39866. 29902.\n14 x[3] -0.133 1 40322. 30635.\n15 x[4] 0.023 1 41022. 29315.\n16 x[5] -0.008 1 41923. 31293.\n17 x[6] -0.116 1 41851. 29370.\n18 x[7] 0.005 1 42307. 30895.\n19 x[8] -0.043 1 40895. 29853.\n20 x[9] -0.021 1 39208. 28808.\n\n\n\n\n\n\nBrooks, Steve, Andrew Gelman, Galin Jones, y Xiao-Li Meng. 2011. Handbook of Markov Chain Monte Carlo. CRC press.\n\n\nMcElreath, R. 2020. Statistical Rethinking: A Bayesian Course with Examples in R and Stan. A Chapman & Hall libro. CRC Press. https://books.google.com.mx/books?id=Ie2vxQEACAAJ.", "crumbs": [ "8  Markov Chain Monte Carlo" ] @@ -594,7 +594,7 @@ "href": "09-modelos-jerarquicos.html", "title": "9  Modelos jerárquicos", "section": "", - "text": "9.1 Primer ejemplo: construyendo un modelo jerárquico.\nConsideramos un ejemplo simple, donde queremos estimar el efecto del hospital en la tasa de mortalidad de pacientes de cirugía de corazón. Este ejemplo se puede encontrar en Albert (2009). Plantearemos 3 alternativas de modelación para resolver el problema: modelo de unidades iguales, modelo de unidades independientes y finalmente modelo jerárquico.\nTenemos datos todas las cirugías de transplante de corazón llevadas a cabo en Estados Unidos en un periodo de 24 meses, entre octubre de 1987 y diciembre de 1989. Para cada uno de los 131 hospitales, se registró el número de cirugías de transplante de corazón, y el número de muertes durante los 30 días posteriores a la cirugía \\(y\\). Además, se cuenta con una predicción de la probabilidad de muerte de cada paciente individual. Esta predicción esta basada en un modelo logístico que incluye información a nivel paciente como condición médica antes de la cirugía, género, sexo y raza. En cada hospital se suman las probabilidades de muerte de sus pacientes para calcular el número esperado de muertes \\(e\\), que llamamos como la exposición del hospital. \\(e\\) refleja el riesgo de muerte debido a la mezcla de pacientes que componen un hospital particular.\nEl diagrama simple que consideraremos es uno donde hospital es causa tanto de su exposición \\(e\\) (por su tamaño, tipo de casos que atrae, etc), como de el número de personas fallecidas. A su vez, la exposición \\(e\\) es causa del número de muertes \\(y\\). Nos interesa estimar el efecto directo de hospital en el número de muertes.\nCódigo\nlibrary(tidyverse)\nlibrary(kableExtra)\nlibrary(DiagrammeR)\nggplot2::theme_set(ggplot2::theme_light())\ndatos_hosp <- read_csv(\"../datos/hearttransplants.csv\") |> \n mutate(hospital = row_number())\nhead(datos_hosp)\n\n# A tibble: 6 × 3\n e y hospital\n <dbl> <dbl> <int>\n1 532 0 1\n2 584 0 2\n3 672 2 3\n4 722 1 4\n5 904 1 5\n6 1236 0 6\nConsideramos la cantidad \\(y/e\\) como una estimación cruda de la tasa de mortalidad. En la siguiente gráfica, observamos que parece ser la variabilidad es alta cuando el número de expuestos es relativamente baja. Nótese que la tasa de mortalidad no es muy alta en general, y que el número de muertes es relativamente bajo en muchos hospitales (puede tomar valores 0, 1, 2, etc.) Esto produce variabilidad alta para exposiciones bajas.\nggplot(datos_hosp, aes(x = e, y = 1000 * y / e, color = log(1 + y))) +\n geom_point() + scale_x_log10() + xlab(\"Número de expuestos e\")\nConsideramos primero un modelo donde consideramos que todos los hospitales tienen una misma tasa de mortalidad. Si \\(e_j\\) es la exposición del hospital \\(j\\) y \\(y_j\\) el número de muertes, entonces podemos considerar un modelo de la forma\n\\[y_j \\sim \\text{Poisson}(e_j \\lambda),\\] Es decir, el número de muertes es Poisson con valor esperado igual al número de expuestos multiplicado por la tasa común de mortalidad.\nlibrary(cmdstanr)\nmod_agregado <- cmdstan_model(\"./src/heart-agregado.stan\")\ndatos_agregado <- list(N = nrow(datos_hosp), y = datos_hosp$y, e = datos_hosp$e)\najuste_agregado <- mod_agregado$sample(data = datos_agregado, chains = 4, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 0.1 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 0.1 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 0.1 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 0.1 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.1 seconds.\nTotal execution time: 0.6 seconds.\najuste_agregado$summary(\"lambda\")\n\n# A tibble: 1 × 10\n variable mean median sd mad q5 q95 rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 lambda 0.941 0.940 0.0578 0.0577 0.847 1.04 1.01 1481. 2106.\nLos diagnósticos básicos parecen ser apropiados. Procedemos a hacer un chequeo predictivo posterior:\nset.seed(912)\najuste_agregado$draws(\"y_sim\", format = \"df\") |> \n as_tibble() |> \n pivot_longer(cols = starts_with(\"y_sim\"), names_to = \"variable\") |> \n separate(variable, into = c(\"variable\", \"hospital\"), sep = \"[\\\\[\\\\]]\") |>\n mutate(hospital = as.integer(hospital)) |>\n left_join(datos_hosp, by = \"hospital\") |>\n filter(hospital %in% sample(1:94, 20)) |>\n ggplot(aes(x = value)) + geom_histogram(binwidth = 1) +\n facet_wrap(~ hospital) + \n geom_vline(aes(xintercept = y), color = \"red\")\nY vemos fallas en el ajuste del modelo, con varias observaciones en los extremos de las colas.\nPodemos considerar un modelo donde cada hospital tiene su propia tasa de mortalidad.\nlibrary(cmdstanr)\nmod_ind <- cmdstan_model(\"./src/heart-individual.stan\")\nprint(mod_ind)\n\ndata {\n int<lower=0> N;\n array[N] int e;\n array[N] int y;\n}\n\nparameters {\n vector<lower=0>[N] lambda;\n}\n\ntransformed parameters {\n vector[N] media_hospital;\n // lambda es por cada 1000 expuestos:\n for (i in 1:N){\n media_hospital[i] = lambda[i] * e[i] / 1000;\n }\n}\n\nmodel {\n // partes no determinísticas\n y ~ poisson(media_hospital);\n lambda ~ exponential(1);\n}\n\ngenerated quantities {\n array[N] int y_sim;\n for (i in 1:N){\n y_sim[i] = poisson_rng(media_hospital[i]);\n }\n}\n\ndatos_ind <- list(N = nrow(datos_hosp), y = datos_hosp$y, e = datos_hosp$e)\najuste_ind <- mod_ind$sample(data = datos_ind, chains = 4, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 0.3 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 0.3 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 0.3 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 0.3 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.3 seconds.\nTotal execution time: 1.3 seconds.\n\nresumen <- ajuste_ind$summary(\"lambda\") |> \n select(variable, mean, sd, rhat, ess_bulk)\nresumen |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nrhat\ness_bulk\n\n\n\n\nlambda[1]\n0.6583536\n0.6586216\n1.0006192\n5165.406\n\n\nlambda[2]\n0.6275285\n0.6100568\n1.0006134\n5304.057\n\n\nlambda[3]\n1.7901338\n1.0150032\n1.0025797\n7752.468\n\n\nlambda[4]\n1.1631030\n0.8126933\n1.0029684\n6266.203\n\n\nlambda[5]\n1.0546849\n0.7280221\n1.0031314\n7189.272\n\n\nlambda[6]\n0.4379974\n0.4299703\n1.0009799\n5048.264\n\n\nlambda[7]\n0.4997928\n0.4831605\n1.0016690\n5114.259\n\n\nlambda[8]\n0.8132338\n0.5780811\n1.0020729\n7136.650\n\n\nlambda[9]\n2.2283861\n1.1061633\n0.9995477\n7795.995\n\n\nlambda[10]\n0.4943771\n0.4791999\n1.0015410\n6199.135\n\n\nlambda[11]\n0.5702635\n0.5669676\n0.9999858\n4844.867\n\n\nlambda[12]\n0.7276062\n0.5194843\n0.9996745\n7401.780\n\n\nlambda[13]\n0.5402685\n0.5416521\n1.0009094\n4667.626\n\n\nlambda[14]\n1.4168025\n0.8179681\n1.0001357\n8158.471\n\n\nlambda[15]\n1.8374637\n0.8959153\n1.0003162\n7266.626\n\n\nlambda[16]\n0.4686611\n0.4580127\n1.0018647\n5925.258\n\n\nlambda[17]\n0.4299892\n0.4270344\n1.0000900\n4716.068\n\n\nlambda[18]\n1.4398167\n0.7206289\n1.0014807\n7010.188\n\n\nlambda[19]\n0.4361010\n0.3004024\n1.0020841\n7361.362\n\n\nlambda[20]\n0.9095600\n0.6463542\n0.9999059\n6731.727\n\n\nlambda[21]\n0.8950893\n0.6226518\n1.0012198\n7102.283\n\n\nlambda[22]\n0.9026263\n0.6513811\n1.0023325\n7832.570\n\n\nlambda[23]\n2.0032715\n0.9300883\n1.0002577\n8627.692\n\n\nlambda[24]\n1.5902697\n0.8109377\n1.0013903\n8360.192\n\n\nlambda[25]\n1.3937997\n0.6810875\n1.0001507\n7706.375\n\n\nlambda[26]\n0.6984656\n0.5001702\n0.9999789\n6761.789\n\n\nlambda[27]\n0.4461970\n0.4635060\n1.0008701\n6028.760\n\n\nlambda[28]\n1.2594830\n0.6986847\n1.0012426\n7572.902\n\n\nlambda[29]\n1.1320465\n0.6506051\n1.0010134\n7522.168\n\n\nlambda[30]\n1.8764928\n0.8466750\n1.0000906\n8114.597\n\n\nlambda[31]\n1.7583001\n0.8069553\n1.0031715\n7914.872\n\n\nlambda[32]\n1.6035141\n0.7899954\n1.0008976\n8036.806\n\n\nlambda[33]\n1.1555324\n0.6697436\n1.0003042\n7501.702\n\n\nlambda[34]\n1.5264033\n0.6616486\n1.0025811\n7766.213\n\n\nlambda[35]\n0.7899508\n0.5578459\n0.9999789\n7090.187\n\n\nlambda[36]\n1.4532723\n0.7375873\n1.0007186\n9869.132\n\n\nlambda[37]\n0.4285978\n0.4199888\n0.9999393\n5751.457\n\n\nlambda[38]\n1.9897239\n0.8793718\n1.0003754\n9144.105\n\n\nlambda[39]\n0.7450916\n0.5182003\n0.9995554\n8130.725\n\n\nlambda[40]\n1.1374976\n0.6525920\n1.0017931\n8589.492\n\n\nlambda[41]\n1.4244404\n0.7006266\n1.0023593\n6858.366\n\n\nlambda[42]\n1.6637849\n0.7509851\n0.9996539\n7139.173\n\n\nlambda[43]\n1.8140081\n0.8307266\n1.0031303\n8294.113\n\n\nlambda[44]\n0.8571984\n0.4790812\n1.0023603\n7703.580\n\n\nlambda[45]\n1.0880935\n0.6318477\n1.0006352\n7566.251\n\n\nlambda[46]\n1.4361456\n0.6503897\n0.9994384\n8163.939\n\n\nlambda[47]\n0.8847706\n0.5167225\n1.0009238\n8324.206\n\n\nlambda[48]\n1.0750511\n0.5339827\n1.0016644\n8622.261\n\n\nlambda[49]\n0.3018790\n0.2959550\n1.0005851\n5793.900\n\n\nlambda[50]\n0.3197025\n0.3256233\n0.9994628\n5081.758\n\n\nlambda[51]\n0.7794332\n0.4571045\n1.0016552\n9014.116\n\n\nlambda[52]\n1.5544563\n0.6441122\n1.0010498\n9468.760\n\n\nlambda[53]\n1.4271320\n0.5891077\n1.0008465\n8036.982\n\n\nlambda[54]\n0.5978108\n0.4191586\n1.0009834\n7923.881\n\n\nlambda[55]\n0.5552029\n0.3868425\n0.9998611\n7153.238\n\n\nlambda[56]\n0.8218314\n0.4135715\n0.9999527\n8158.309\n\n\nlambda[57]\n0.5449502\n0.3894453\n0.9999776\n6458.686\n\n\nlambda[58]\n0.5348793\n0.3716342\n1.0007056\n6879.272\n\n\nlambda[59]\n0.9940355\n0.4830594\n1.0003936\n10337.022\n\n\nlambda[60]\n0.4437015\n0.3096729\n1.0029815\n6798.740\n\n\nlambda[61]\n0.8094635\n0.4614335\n0.9997315\n7392.990\n\n\nlambda[62]\n1.6002911\n0.6164370\n1.0024416\n7827.165\n\n\nlambda[63]\n0.2097533\n0.2161231\n1.0001642\n5961.516\n\n\nlambda[64]\n0.5998704\n0.3543889\n1.0010214\n7784.407\n\n\nlambda[65]\n0.8302986\n0.4806738\n1.0025724\n8145.229\n\n\nlambda[66]\n0.5185593\n0.3582384\n1.0000323\n6377.592\n\n\nlambda[67]\n0.5622628\n0.3337068\n1.0017643\n7154.676\n\n\nlambda[68]\n2.0368689\n0.6876336\n1.0055722\n9092.125\n\n\nlambda[69]\n1.5065795\n0.5699950\n1.0005292\n8331.294\n\n\nlambda[70]\n0.3844750\n0.2785353\n1.0024007\n6767.158\n\n\nlambda[71]\n1.4130430\n0.5030808\n1.0027316\n9470.380\n\n\nlambda[72]\n0.9854344\n0.4297633\n1.0011536\n9078.722\n\n\nlambda[73]\n0.3803165\n0.2642860\n0.9998781\n6647.621\n\n\nlambda[74]\n0.7987972\n0.3949402\n1.0025064\n8176.634\n\n\nlambda[75]\n1.0660119\n0.4160935\n1.0009367\n8879.975\n\n\nlambda[76]\n0.4578378\n0.2659640\n1.0003575\n8105.424\n\n\nlambda[77]\n0.6694614\n0.3042366\n1.0001769\n7553.550\n\n\nlambda[78]\n0.6279796\n0.3145321\n1.0010509\n8771.816\n\n\nlambda[79]\n0.9175721\n0.4044257\n1.0010852\n9683.504\n\n\nlambda[80]\n1.0506304\n0.4302338\n1.0022860\n7827.670\n\n\nlambda[81]\n0.5012500\n0.3018368\n1.0017463\n7269.050\n\n\nlambda[82]\n0.9981823\n0.3795039\n1.0020283\n8411.693\n\n\nlambda[83]\n1.4705479\n0.4957901\n1.0014892\n8909.492\n\n\nlambda[84]\n0.4915877\n0.1923660\n1.0009710\n8681.406\n\n\nlambda[85]\n0.1462425\n0.1448864\n1.0002353\n5320.621\n\n\nlambda[86]\n0.9944543\n0.3670536\n1.0001632\n9571.313\n\n\nlambda[87]\n1.3736207\n0.4610920\n1.0023358\n8707.553\n\n\nlambda[88]\n1.1210221\n0.3999280\n1.0004132\n11185.793\n\n\nlambda[89]\n0.5515533\n0.2814439\n1.0009379\n9472.479\n\n\nlambda[90]\n0.5020421\n0.2537327\n0.9997052\n7704.323\n\n\nlambda[91]\n1.1323293\n0.3517581\n1.0021811\n11321.426\n\n\nlambda[92]\n0.7582604\n0.2697603\n1.0006837\n9264.479\n\n\nlambda[93]\n1.4530631\n0.3388141\n1.0010033\n9858.270\n\n\nlambda[94]\n1.3687930\n0.3160478\n1.0007887\n8029.575\nEl problema en este caso es que tenemos intervalos que simplemente no son creíbles, en particular con aquellos hospitales que tienen poca exposición.\nset.seed(912)\najuste_ind$draws(\"lambda\", format = \"df\") |> \n as_tibble() |> \n pivot_longer(cols = starts_with(\"lambda\"), names_to = \"variable\") |> \n separate(variable, into = c(\"variable\", \"hospital\"), sep = \"[\\\\[\\\\]]\") |>\n mutate(hospital = as.integer(hospital)) |>\n left_join(datos_hosp, by = \"hospital\") |>\n mutate(hospital = factor(hospital)) |>\n group_by(hospital, e, y) |> \n summarise(inf = quantile(value, 0.1), sup = quantile(value, 0.9)) |>\n ggplot(aes(x = e)) + geom_linerange(aes(ymin = inf, ymax = sup)) +\n geom_point(aes(y = 1000 * y / e), color = \"red\") +\n scale_x_log10() + xlab(\"Número de expuestos e\") + ylab(\"Muertes por mil expuestos\")\nEn este caso, la variabilidad es muy alta para hospitales con poca exposición, tanto en los datos observados como en los intervalos. Los intervalos no aportan mucha información. En este punto utilizar iniciales fuertes para las \\(\\lambda_j\\) si tenemos la información disponible. Sin embargo, los resultados serán altamente sensible a esta información inicial.\nUna alternativa intermedia es poner una distribución inicial sobre las tasas que pueda adaptarse a los datos. Esta es una estrategia intermedia, donde permitimos variación en las \\(\\lambda_j\\) que sea consistente con la variación que observamos a lo largo de los hospitales.\nlibrary(cmdstanr)\nmod_jer <- cmdstan_model(\"./src/heart-jerarquico.stan\")\nprint(mod_jer)\n\ndata {\n int<lower=0> N;\n array[N] int e;\n array[N] int y;\n}\n\nparameters {\n vector<lower=0>[N] lambda;\n real<lower=0> alpha;\n real<lower=0> mu;\n}\n\ntransformed parameters {\n vector[N] media_hospital;\n // lambda es por cada 1000 expuestos:\n for (i in 1:N){\n media_hospital[i] = lambda[i] * e[i] /1000;\n }\n}\n\nmodel {\n // partes no determinísticas\n y ~ poisson(media_hospital);\n lambda ~ gamma(alpha, alpha / mu);\n mu ~ exponential(1);\n alpha ~ exponential(1);\n}\n\ngenerated quantities {\n array[N] int y_sim;\n for (i in 1:N){\n y_sim[i] = poisson_rng(media_hospital[i]);\n }\n}\n\ndatos_jer <- list(N = nrow(datos_hosp), y = datos_hosp$y, e = datos_hosp$e)\najuste_jer <- mod_jer$sample(data = datos_ind, \n chains = 4, step_size = 0.5, iter_sampling = 3000, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 1 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 1 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 1 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 1 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 1 finished in 0.7 seconds.\nChain 2 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 2 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 2 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 2 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 2 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 2 finished in 0.7 seconds.\nChain 3 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 3 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 3 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 3 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 3 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 3 finished in 0.7 seconds.\nChain 4 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 4 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 4 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 4 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 4 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 4 finished in 0.7 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.7 seconds.\nTotal execution time: 3.3 seconds.\n\nresumen <- ajuste_jer$summary(c(\"alpha\", \"mu\")) |> \n select(variable, mean, sd, rhat, ess_bulk)\nresumen |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nrhat\ness_bulk\n\n\n\n\nalpha\n4.3771616\n1.3246645\n1.000421\n2640.041\n\n\nmu\n0.9626838\n0.0818993\n1.000104\n9910.558\nEl problema en este caso es que tenemos intervalos que simplemente no son creíbles, en particular con aquellos hospitales que tienen poca exposición.\nset.seed(912)\najuste_jer$draws(\"lambda\", format = \"df\") |> \n as_tibble() |> \n pivot_longer(cols = starts_with(\"lambda\"), names_to = \"variable\") |> \n separate(variable, into = c(\"variable\", \"hospital\"), sep = \"[\\\\[\\\\]]\") |>\n mutate(hospital = as.integer(hospital)) |>\n left_join(datos_hosp, by = \"hospital\") |>\n mutate(hospital = factor(hospital)) |>\n group_by(hospital, e, y) |> \n summarise(inf = quantile(value, 0.1), sup = quantile(value, 0.9), median = median(value)) |>\n ggplot(aes(x = e)) + geom_linerange(aes(ymin = inf, ymax = sup)) +\n geom_point(aes(y = 1000 * y / e), color = \"red\") +\n geom_point(aes(y = median)) +\n scale_x_log10() + xlab(\"Número de expuestos e\") + ylab(\"Muertes por mil expuestos\")\nEjercicio: repetir el análisis posterior predictivo que vimos para el modelo agregado.", + "text": "9.1 Primer ejemplo: construyendo un modelo jerárquico.\nConsideramos un ejemplo simple, donde queremos estimar el efecto del hospital en la tasa de mortalidad de pacientes de cirugía de corazón. Este ejemplo se puede encontrar en Albert (2009). Plantearemos 3 alternativas de modelación para resolver el problema: modelo de unidades iguales, modelo de unidades independientes y finalmente modelo jerárquico.\nTenemos datos todas las cirugías de transplante de corazón llevadas a cabo en Estados Unidos en un periodo de 24 meses, entre octubre de 1987 y diciembre de 1989. Para cada uno de los 131 hospitales, se registró el número de cirugías de transplante de corazón, y el número de muertes durante los 30 días posteriores a la cirugía \\(y\\). Además, se cuenta con una predicción de la probabilidad de muerte de cada paciente individual. Esta predicción esta basada en un modelo logístico que incluye información a nivel paciente como condición médica antes de la cirugía, género, sexo y raza. En cada hospital se suman las probabilidades de muerte de sus pacientes para calcular el número esperado de muertes \\(e\\), que llamamos como la exposición del hospital. \\(e\\) refleja el riesgo de muerte debido a la mezcla de pacientes que componen un hospital particular.\nEl diagrama simple que consideraremos es uno donde hospital es causa tanto de su exposición \\(e\\) (por su tamaño, tipo de casos que atrae, etc), como de el número de personas fallecidas. A su vez, la exposición \\(e\\) es causa del número de muertes \\(y\\). Nos interesa estimar el efecto directo de hospital en el número de muertes.\nCódigo\nlibrary(tidyverse)\nlibrary(kableExtra)\nlibrary(DiagrammeR)\nggplot2::theme_set(ggplot2::theme_light())\ndatos_hosp <- read_csv(\"../datos/hearttransplants.csv\") |> \n mutate(hospital = row_number())\nhead(datos_hosp)\n\n# A tibble: 6 × 3\n e y hospital\n <dbl> <dbl> <int>\n1 532 0 1\n2 584 0 2\n3 672 2 3\n4 722 1 4\n5 904 1 5\n6 1236 0 6\nConsideramos la cantidad \\(y/e\\) como una estimación cruda de la tasa de mortalidad. En la siguiente gráfica, observamos que parece ser la variabilidad es alta cuando el número de expuestos es relativamente baja. Nótese que la tasa de mortalidad no es muy alta en general, y que el número de muertes es relativamente bajo en muchos hospitales (puede tomar valores 0, 1, 2, etc.) Esto produce variabilidad alta para exposiciones bajas.\nggplot(datos_hosp, aes(x = e, y = 1000 * y / e, color = log(1 + y))) +\n geom_point() + scale_x_log10() + xlab(\"Número de expuestos e\")\nConsideramos primero un modelo donde consideramos que todos los hospitales tienen una misma tasa de mortalidad. Si \\(e_j\\) es la exposición del hospital \\(j\\) y \\(y_j\\) el número de muertes, entonces podemos considerar un modelo de la forma\n\\[y_j \\sim \\text{Poisson}(e_j \\lambda),\\] Es decir, el número de muertes es Poisson con valor esperado igual al número de expuestos multiplicado por la tasa común de mortalidad.\nlibrary(cmdstanr)\nmod_agregado <- cmdstan_model(\"./src/heart-agregado.stan\")\ndatos_agregado <- list(N = nrow(datos_hosp), y = datos_hosp$y, e = datos_hosp$e)\najuste_agregado <- mod_agregado$sample(data = datos_agregado, chains = 4, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 0.1 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 0.1 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 0.1 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 0.1 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.1 seconds.\nTotal execution time: 0.6 seconds.\najuste_agregado$summary(\"lambda\")\n\n# A tibble: 1 × 10\n variable mean median sd mad q5 q95 rhat ess_bulk ess_tail\n <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>\n1 lambda 0.942 0.939 0.0567 0.0556 0.852 1.04 1.00 1288. 1799.\nLos diagnósticos básicos parecen ser apropiados. Procedemos a hacer un chequeo predictivo posterior:\nset.seed(912)\najuste_agregado$draws(\"y_sim\", format = \"df\") |> \n as_tibble() |> \n pivot_longer(cols = starts_with(\"y_sim\"), names_to = \"variable\") |> \n separate(variable, into = c(\"variable\", \"hospital\"), sep = \"[\\\\[\\\\]]\") |>\n mutate(hospital = as.integer(hospital)) |>\n left_join(datos_hosp, by = \"hospital\") |>\n filter(hospital %in% sample(1:94, 20)) |>\n ggplot(aes(x = value)) + geom_histogram(binwidth = 1) +\n facet_wrap(~ hospital) + \n geom_vline(aes(xintercept = y), color = \"red\")\nY vemos fallas en el ajuste del modelo, con varias observaciones en los extremos de las colas.\nPodemos considerar un modelo donde cada hospital tiene su propia tasa de mortalidad.\nlibrary(cmdstanr)\nmod_ind <- cmdstan_model(\"./src/heart-individual.stan\")\nprint(mod_ind)\n\ndata {\n int<lower=0> N;\n array[N] int e;\n array[N] int y;\n}\n\nparameters {\n vector<lower=0>[N] lambda;\n}\n\ntransformed parameters {\n vector[N] media_hospital;\n // lambda es por cada 1000 expuestos:\n for (i in 1:N){\n media_hospital[i] = lambda[i] * e[i] / 1000;\n }\n}\n\nmodel {\n // partes no determinísticas\n y ~ poisson(media_hospital);\n lambda ~ exponential(1);\n}\n\ngenerated quantities {\n array[N] int y_sim;\n for (i in 1:N){\n y_sim[i] = poisson_rng(media_hospital[i]);\n }\n}\n\ndatos_ind <- list(N = nrow(datos_hosp), y = datos_hosp$y, e = datos_hosp$e)\najuste_ind <- mod_ind$sample(data = datos_ind, chains = 4, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 1 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 1 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 1 finished in 0.3 seconds.\nChain 2 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 2 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 2 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 2 finished in 0.3 seconds.\nChain 3 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 3 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 3 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 3 finished in 0.3 seconds.\nChain 4 Iteration: 1 / 2000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 2000 [ 50%] (Warmup) \nChain 4 Iteration: 1001 / 2000 [ 50%] (Sampling) \nChain 4 Iteration: 2000 / 2000 [100%] (Sampling) \nChain 4 finished in 0.3 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.3 seconds.\nTotal execution time: 1.3 seconds.\n\nresumen <- ajuste_ind$summary(\"lambda\") |> \n select(variable, mean, sd, rhat, ess_bulk)\nresumen |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nrhat\ness_bulk\n\n\n\n\nlambda[1]\n0.6583536\n0.6586216\n1.0006192\n5165.406\n\n\nlambda[2]\n0.6275285\n0.6100568\n1.0006134\n5304.057\n\n\nlambda[3]\n1.7901338\n1.0150032\n1.0025797\n7752.468\n\n\nlambda[4]\n1.1631030\n0.8126933\n1.0029684\n6266.203\n\n\nlambda[5]\n1.0546849\n0.7280221\n1.0031314\n7189.272\n\n\nlambda[6]\n0.4379974\n0.4299703\n1.0009799\n5048.264\n\n\nlambda[7]\n0.4997928\n0.4831605\n1.0016690\n5114.259\n\n\nlambda[8]\n0.8132338\n0.5780811\n1.0020729\n7136.650\n\n\nlambda[9]\n2.2283861\n1.1061633\n0.9995477\n7795.995\n\n\nlambda[10]\n0.4943771\n0.4791999\n1.0015410\n6199.135\n\n\nlambda[11]\n0.5702635\n0.5669676\n0.9999858\n4844.867\n\n\nlambda[12]\n0.7276062\n0.5194843\n0.9996745\n7401.780\n\n\nlambda[13]\n0.5402685\n0.5416521\n1.0009094\n4667.626\n\n\nlambda[14]\n1.4168025\n0.8179681\n1.0001357\n8158.471\n\n\nlambda[15]\n1.8374637\n0.8959153\n1.0003162\n7266.626\n\n\nlambda[16]\n0.4686611\n0.4580127\n1.0018647\n5925.258\n\n\nlambda[17]\n0.4299892\n0.4270344\n1.0000900\n4716.068\n\n\nlambda[18]\n1.4398167\n0.7206289\n1.0014807\n7010.188\n\n\nlambda[19]\n0.4361010\n0.3004024\n1.0020841\n7361.362\n\n\nlambda[20]\n0.9095600\n0.6463542\n0.9999059\n6731.727\n\n\nlambda[21]\n0.8950893\n0.6226518\n1.0012198\n7102.283\n\n\nlambda[22]\n0.9026263\n0.6513811\n1.0023325\n7832.570\n\n\nlambda[23]\n2.0032715\n0.9300883\n1.0002577\n8627.692\n\n\nlambda[24]\n1.5902697\n0.8109377\n1.0013903\n8360.192\n\n\nlambda[25]\n1.3937997\n0.6810875\n1.0001507\n7706.375\n\n\nlambda[26]\n0.6984656\n0.5001702\n0.9999789\n6761.789\n\n\nlambda[27]\n0.4461970\n0.4635060\n1.0008701\n6028.760\n\n\nlambda[28]\n1.2594830\n0.6986847\n1.0012426\n7572.902\n\n\nlambda[29]\n1.1320465\n0.6506051\n1.0010134\n7522.168\n\n\nlambda[30]\n1.8764928\n0.8466750\n1.0000906\n8114.597\n\n\nlambda[31]\n1.7583001\n0.8069553\n1.0031715\n7914.872\n\n\nlambda[32]\n1.6035141\n0.7899954\n1.0008976\n8036.806\n\n\nlambda[33]\n1.1555324\n0.6697436\n1.0003042\n7501.702\n\n\nlambda[34]\n1.5264033\n0.6616486\n1.0025811\n7766.213\n\n\nlambda[35]\n0.7899508\n0.5578459\n0.9999789\n7090.187\n\n\nlambda[36]\n1.4532723\n0.7375873\n1.0007186\n9869.132\n\n\nlambda[37]\n0.4285978\n0.4199888\n0.9999393\n5751.457\n\n\nlambda[38]\n1.9897239\n0.8793718\n1.0003754\n9144.105\n\n\nlambda[39]\n0.7450916\n0.5182003\n0.9995554\n8130.725\n\n\nlambda[40]\n1.1374976\n0.6525920\n1.0017931\n8589.492\n\n\nlambda[41]\n1.4244404\n0.7006266\n1.0023593\n6858.366\n\n\nlambda[42]\n1.6637849\n0.7509851\n0.9996539\n7139.173\n\n\nlambda[43]\n1.8140081\n0.8307266\n1.0031303\n8294.113\n\n\nlambda[44]\n0.8571984\n0.4790812\n1.0023603\n7703.580\n\n\nlambda[45]\n1.0880935\n0.6318477\n1.0006352\n7566.251\n\n\nlambda[46]\n1.4361456\n0.6503897\n0.9994384\n8163.939\n\n\nlambda[47]\n0.8847706\n0.5167225\n1.0009238\n8324.206\n\n\nlambda[48]\n1.0750511\n0.5339827\n1.0016644\n8622.261\n\n\nlambda[49]\n0.3018790\n0.2959550\n1.0005851\n5793.900\n\n\nlambda[50]\n0.3197025\n0.3256233\n0.9994628\n5081.758\n\n\nlambda[51]\n0.7794332\n0.4571045\n1.0016552\n9014.116\n\n\nlambda[52]\n1.5544563\n0.6441122\n1.0010498\n9468.760\n\n\nlambda[53]\n1.4271320\n0.5891077\n1.0008465\n8036.982\n\n\nlambda[54]\n0.5978108\n0.4191586\n1.0009834\n7923.881\n\n\nlambda[55]\n0.5552029\n0.3868425\n0.9998611\n7153.238\n\n\nlambda[56]\n0.8218314\n0.4135715\n0.9999527\n8158.309\n\n\nlambda[57]\n0.5449502\n0.3894453\n0.9999776\n6458.686\n\n\nlambda[58]\n0.5348793\n0.3716342\n1.0007056\n6879.272\n\n\nlambda[59]\n0.9940355\n0.4830594\n1.0003936\n10337.022\n\n\nlambda[60]\n0.4437015\n0.3096729\n1.0029815\n6798.740\n\n\nlambda[61]\n0.8094635\n0.4614335\n0.9997315\n7392.990\n\n\nlambda[62]\n1.6002911\n0.6164370\n1.0024416\n7827.165\n\n\nlambda[63]\n0.2097533\n0.2161231\n1.0001642\n5961.516\n\n\nlambda[64]\n0.5998704\n0.3543889\n1.0010214\n7784.407\n\n\nlambda[65]\n0.8302986\n0.4806738\n1.0025724\n8145.229\n\n\nlambda[66]\n0.5185593\n0.3582384\n1.0000323\n6377.592\n\n\nlambda[67]\n0.5622628\n0.3337068\n1.0017643\n7154.676\n\n\nlambda[68]\n2.0368689\n0.6876336\n1.0055722\n9092.125\n\n\nlambda[69]\n1.5065795\n0.5699950\n1.0005292\n8331.294\n\n\nlambda[70]\n0.3844750\n0.2785353\n1.0024007\n6767.158\n\n\nlambda[71]\n1.4130430\n0.5030808\n1.0027316\n9470.380\n\n\nlambda[72]\n0.9854344\n0.4297633\n1.0011536\n9078.722\n\n\nlambda[73]\n0.3803165\n0.2642860\n0.9998781\n6647.621\n\n\nlambda[74]\n0.7987972\n0.3949402\n1.0025064\n8176.634\n\n\nlambda[75]\n1.0660119\n0.4160935\n1.0009367\n8879.975\n\n\nlambda[76]\n0.4578378\n0.2659640\n1.0003575\n8105.424\n\n\nlambda[77]\n0.6694614\n0.3042366\n1.0001769\n7553.550\n\n\nlambda[78]\n0.6279796\n0.3145321\n1.0010509\n8771.816\n\n\nlambda[79]\n0.9175721\n0.4044257\n1.0010852\n9683.504\n\n\nlambda[80]\n1.0506304\n0.4302338\n1.0022860\n7827.670\n\n\nlambda[81]\n0.5012500\n0.3018368\n1.0017463\n7269.050\n\n\nlambda[82]\n0.9981823\n0.3795039\n1.0020283\n8411.693\n\n\nlambda[83]\n1.4705479\n0.4957901\n1.0014892\n8909.492\n\n\nlambda[84]\n0.4915877\n0.1923660\n1.0009710\n8681.406\n\n\nlambda[85]\n0.1462425\n0.1448864\n1.0002353\n5320.621\n\n\nlambda[86]\n0.9944543\n0.3670536\n1.0001632\n9571.313\n\n\nlambda[87]\n1.3736207\n0.4610920\n1.0023358\n8707.553\n\n\nlambda[88]\n1.1210221\n0.3999280\n1.0004132\n11185.793\n\n\nlambda[89]\n0.5515533\n0.2814439\n1.0009379\n9472.479\n\n\nlambda[90]\n0.5020421\n0.2537327\n0.9997052\n7704.323\n\n\nlambda[91]\n1.1323293\n0.3517581\n1.0021811\n11321.426\n\n\nlambda[92]\n0.7582604\n0.2697603\n1.0006837\n9264.479\n\n\nlambda[93]\n1.4530631\n0.3388141\n1.0010033\n9858.270\n\n\nlambda[94]\n1.3687930\n0.3160478\n1.0007887\n8029.575\nEl problema en este caso es que tenemos intervalos que simplemente no son creíbles, en particular con aquellos hospitales que tienen poca exposición.\nset.seed(912)\najuste_ind$draws(\"lambda\", format = \"df\") |> \n as_tibble() |> \n pivot_longer(cols = starts_with(\"lambda\"), names_to = \"variable\") |> \n separate(variable, into = c(\"variable\", \"hospital\"), sep = \"[\\\\[\\\\]]\") |>\n mutate(hospital = as.integer(hospital)) |>\n left_join(datos_hosp, by = \"hospital\") |>\n mutate(hospital = factor(hospital)) |>\n group_by(hospital, e, y) |> \n summarise(inf = quantile(value, 0.1), sup = quantile(value, 0.9)) |>\n ggplot(aes(x = e)) + geom_linerange(aes(ymin = inf, ymax = sup)) +\n geom_point(aes(y = 1000 * y / e), color = \"red\") +\n scale_x_log10() + xlab(\"Número de expuestos e\") + ylab(\"Muertes por mil expuestos\")\nEn este caso, la variabilidad es muy alta para hospitales con poca exposición, tanto en los datos observados como en los intervalos. Los intervalos no aportan mucha información. En este punto utilizar iniciales fuertes para las \\(\\lambda_j\\) si tenemos la información disponible. Sin embargo, los resultados serán altamente sensible a esta información inicial.\nUna alternativa intermedia es poner una distribución inicial sobre las tasas que pueda adaptarse a los datos. Esta es una estrategia intermedia, donde permitimos variación en las \\(\\lambda_j\\) que sea consistente con la variación que observamos a lo largo de los hospitales.\nlibrary(cmdstanr)\nmod_jer <- cmdstan_model(\"./src/heart-jerarquico.stan\")\nprint(mod_jer)\n\ndata {\n int<lower=0> N;\n array[N] int e;\n array[N] int y;\n}\n\nparameters {\n vector<lower=0>[N] lambda;\n real<lower=0> alpha;\n real<lower=0> mu;\n}\n\ntransformed parameters {\n vector[N] media_hospital;\n // lambda es por cada 1000 expuestos:\n for (i in 1:N){\n media_hospital[i] = lambda[i] * e[i] /1000;\n }\n}\n\nmodel {\n // partes no determinísticas\n y ~ poisson(media_hospital);\n lambda ~ gamma(alpha, alpha / mu);\n mu ~ exponential(1);\n alpha ~ exponential(1);\n}\n\ngenerated quantities {\n array[N] int y_sim;\n for (i in 1:N){\n y_sim[i] = poisson_rng(media_hospital[i]);\n }\n}\n\ndatos_jer <- list(N = nrow(datos_hosp), y = datos_hosp$y, e = datos_hosp$e)\najuste_jer <- mod_jer$sample(data = datos_ind, \n chains = 4, step_size = 0.5, iter_sampling = 3000, refresh = 1000)\n\nRunning MCMC with 4 sequential chains...\n\nChain 1 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 1 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 1 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 1 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 1 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 1 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 1 finished in 0.7 seconds.\nChain 2 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 2 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 2 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 2 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 2 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 2 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 2 finished in 0.7 seconds.\nChain 3 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 3 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 3 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 3 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 3 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 3 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 3 finished in 0.7 seconds.\nChain 4 Iteration: 1 / 4000 [ 0%] (Warmup) \nChain 4 Iteration: 1000 / 4000 [ 25%] (Warmup) \nChain 4 Iteration: 1001 / 4000 [ 25%] (Sampling) \nChain 4 Iteration: 2000 / 4000 [ 50%] (Sampling) \nChain 4 Iteration: 3000 / 4000 [ 75%] (Sampling) \nChain 4 Iteration: 4000 / 4000 [100%] (Sampling) \nChain 4 finished in 0.7 seconds.\n\nAll 4 chains finished successfully.\nMean chain execution time: 0.7 seconds.\nTotal execution time: 3.3 seconds.\n\nresumen <- ajuste_jer$summary(c(\"alpha\", \"mu\")) |> \n select(variable, mean, sd, rhat, ess_bulk)\nresumen |> kable()\n\n\n\n\n\nvariable\nmean\nsd\nrhat\ness_bulk\n\n\n\n\nalpha\n4.3771616\n1.3246645\n1.000421\n2640.041\n\n\nmu\n0.9626838\n0.0818993\n1.000104\n9910.558\nEl problema en este caso es que tenemos intervalos que simplemente no son creíbles, en particular con aquellos hospitales que tienen poca exposición.\nset.seed(912)\najuste_jer$draws(\"lambda\", format = \"df\") |> \n as_tibble() |> \n pivot_longer(cols = starts_with(\"lambda\"), names_to = \"variable\") |> \n separate(variable, into = c(\"variable\", \"hospital\"), sep = \"[\\\\[\\\\]]\") |>\n mutate(hospital = as.integer(hospital)) |>\n left_join(datos_hosp, by = \"hospital\") |>\n mutate(hospital = factor(hospital)) |>\n group_by(hospital, e, y) |> \n summarise(inf = quantile(value, 0.1), sup = quantile(value, 0.9), median = median(value)) |>\n ggplot(aes(x = e)) + geom_linerange(aes(ymin = inf, ymax = sup)) +\n geom_point(aes(y = 1000 * y / e), color = \"red\") +\n geom_point(aes(y = median)) +\n scale_x_log10() + xlab(\"Número de expuestos e\") + ylab(\"Muertes por mil expuestos\")\nEjercicio: repetir el análisis posterior predictivo que vimos para el modelo agregado.", "crumbs": [ "9  Modelos jerárquicos" ]